diff --git a/.github/actions/macos-setup/action.yml b/.github/actions/macos-setup/action.yml index 4c248abd11..caa6f193bb 100644 --- a/.github/actions/macos-setup/action.yml +++ b/.github/actions/macos-setup/action.yml @@ -26,7 +26,7 @@ runs: run: | cd .testing echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -fcheck=bounds" >> config.mk - echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> 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 diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml deleted file mode 100644 index ace02ee790..0000000000 --- a/.github/workflows/coupled-api.yml +++ /dev/null @@ -1,30 +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@v4 - with: - submodules: recursive - - - uses: ./.github/actions/ubuntu-setup - - - uses: ./.github/actions/testing-setup - with: - build_symmetric: '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 diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml deleted file mode 100644 index 22b9e471bc..0000000000 --- a/.github/workflows/coverage.yml +++ /dev/null @@ -1,42 +0,0 @@ -name: Code coverage - -on: [push, pull_request] - -jobs: - build-coverage: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v4 - with: - submodules: recursive - - - uses: ./.github/actions/ubuntu-setup - - - uses: ./.github/actions/testing-setup - - - name: Compile unit tests - run: make -j build.unit - - - name: Run unit tests - run: make run.cov.unit - - - name: Report unit test coverage to CI - run: make report.cov.unit - env: - CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - - - name: Compile ocean-only MOM6 with code coverage - run: make -j build/cov/MOM6 - - - name: Run coverage tests - run: make -k run.cov - - - name: Report coverage to CI - run: make report.cov - env: - CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} diff --git a/.github/workflows/documentation-and-style.yml b/.github/workflows/documentation-and-style.yml deleted file mode 100644 index 857db917b6..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@v4 - 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 3cd19ee18c..0000000000 --- a/.github/workflows/expression.yml +++ /dev/null @@ -1,29 +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@v4 - with: - submodules: recursive - - - uses: ./.github/actions/ubuntu-setup - - - 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/macos-regression.yml b/.github/workflows/macos-regression.yml deleted file mode 100644 index 16e2e15f80..0000000000 --- a/.github/workflows/macos-regression.yml +++ /dev/null @@ -1,35 +0,0 @@ -name: MacOS regression - -on: [pull_request] - -jobs: - test-macos-regression: - - runs-on: macOS-latest - - env: - CC: gcc - FC: gfortran - FMS_COMMIT: 2019.01.03 - - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v4 - with: - submodules: recursive - - - uses: ./.github/actions/macos-setup - - - 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/macos-stencil.yml b/.github/workflows/macos-stencil.yml deleted file mode 100644 index a30ad17199..0000000000 --- a/.github/workflows/macos-stencil.yml +++ /dev/null @@ -1,35 +0,0 @@ -name: MacOS stencil tests - -on: [push, pull_request] - -jobs: - test-macos-stencil: - - runs-on: macOS-latest - - env: - CC: gcc - FC: gfortran - FMS_COMMIT: 2019.01.03 - - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v4 - with: - submodules: recursive - - - uses: ./.github/actions/macos-setup - - - 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/other.yml b/.github/workflows/other.yml deleted file mode 100644 index 9a941bafa9..0000000000 --- a/.github/workflows/other.yml +++ /dev/null @@ -1,29 +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@v4 - with: - submodules: recursive - - - uses: ./.github/actions/ubuntu-setup - - - 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 a66ba90643..0000000000 --- a/.github/workflows/perfmon.yml +++ /dev/null @@ -1,75 +0,0 @@ -name: Performance Monitor - -on: [push, pull_request] - -jobs: - build-test-perfmon: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v4 - with: - submodules: recursive - - - uses: ./.github/actions/ubuntu-setup - - - uses: ./.github/actions/testing-setup - - - name: Compile optimized models - if: ${{ github.event_name == 'pull_request' }} - 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 - if: ${{ github.event_name == 'pull_request' }} - run: >- - pip install f90nml && - make profile - DO_REGRESSION_TESTS=true - - - name: Generate perf data - if: ${{ github.event_name == 'pull_request' }} - run: | - sudo sysctl -w kernel.perf_event_paranoid=2 - make perf DO_REGRESSION_TESTS=true - - # This job assumes that build/target_codebase was cloned above - - name: Compile timing tests for reference code - if: ${{ github.event_name == 'pull_request' }} - run: >- - make -j build.timing_target - MOM_TARGET_SLUG=$GITHUB_REPOSITORY - MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF - DO_REGRESSION_TESTS=true - - - name: Compile timing tests - run: | - make -j build.timing - - # DO_REGERESSION_TESTS=true is needed here to set the internal macro TARGET_CODEBASE - - name: Run timing tests for reference code - if: ${{ github.event_name == 'pull_request' }} - run: >- - make -j run.timing_target - DO_REGRESSION_TESTS=true - - - name: Run timing tests - run: | - make -j run.timing - - - name: Display timing results - run: | - make -j show.timing - - - name: Display comparison of timing results - if: ${{ github.event_name == 'pull_request' }} - run: >- - make -j compare.timing - DO_REGRESSION_TESTS=true diff --git a/.github/workflows/regression.yml b/.github/workflows/regression.yml deleted file mode 100644 index 107948d5da..0000000000 --- a/.github/workflows/regression.yml +++ /dev/null @@ -1,29 +0,0 @@ -name: Regression - -on: [pull_request] - -jobs: - build-test-regression: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v4 - with: - submodules: recursive - - - uses: ./.github/actions/ubuntu-setup - - - 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 d46da6e4fa..0000000000 --- a/.github/workflows/stencil.yml +++ /dev/null @@ -1,29 +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@v4 - with: - submodules: recursive - - - uses: ./.github/actions/ubuntu-setup - - - 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..c15daee448 --- /dev/null +++ b/.github/workflows/verify-linux.yml @@ -0,0 +1,928 @@ +name: Linux verification + +on: [push, pull_request] + +jobs: + # Documentation + check-style-and-docstrings: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + 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 + + # Dependencies + + build-fms: + runs-on: ubuntu-latest + + steps: + - name: Checkout + uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Build libFMS.a + run: make -C .testing build/deps/lib/libFMS.a -j + + - name: Upload libFMS.a and dependencies + uses: actions/upload-artifact@v4 + with: + name: fms-artifact + path: | + .testing/build/deps/include/ + .testing/build/deps/lib/libFMS.a + retention-days: 1 + + # Executables + + build-symmetric: + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile MOM6 with symmetric indexing + run: | + make -C .testing build/symmetric/MOM6 -j \ + -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/MOM6 + retention-days: 1 + + build-asymmetric: + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile MOM6 with asymmetric indexing + run: | + make -C .testing build/asymmetric/MOM6 -j \ + -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-asymmetric-artifact + path: .testing/build/asymmetric/MOM6 + retention-days: 1 + + build-repro: + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile repro + run: | + make -C .testing build/repro/MOM6 -j \ + -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-repro-artifact + path: .testing/build/repro/MOM6 + retention-days: 1 + + build-openmp: + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile MOM6 supporting OpenMP + run: make -C .testing build/openmp/MOM6 -j -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-openmp-artifact + path: .testing/build/openmp/MOM6 + retention-days: 1 + + build-target: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile target MOM6 + run: | + make -C .testing build/target/MOM6 -j \ + -o build/deps/lib/libFMS.a \ + MOM_TARGET_SLUG=$GITHUB_REPOSITORY \ + MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF \ + DO_REGRESSION_TESTS=True + + - uses: actions/upload-artifact@v4 + with: + name: mom6-target-artifact + path: .testing/build/target/MOM6 + retention-days: 1 + + build-opt: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile optimized model + run: | + make -C .testing build/opt/MOM6 -j \ + -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-opt-artifact + path: .testing/build/opt/MOM6 + retention-days: 1 + + - name: Compile unit tests + run: | + make -C .testing build.timing -j \ + -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-unit-artifact + path: | + .testing/build/timing/time_MOM_EOS + .testing/build/timing/time_MOM_remapping + retention-days: 1 + + build-opt-target: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile target MOM6 + run: | + make -C .testing build/opt_target/MOM6 -j \ + -o build/deps/lib/libFMS.a \ + MOM_TARGET_SLUG=$GITHUB_REPOSITORY \ + MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF \ + DO_REGRESSION_TESTS=True + + - uses: actions/upload-artifact@v4 + with: + name: mom6-opt-target-artifact + path: .testing/build/opt_target/MOM6 + retention-days: 1 + + - name: Compile target unit tests + run: | + make -C .testing build.timing_target -j \ + -o build/deps/lib/libFMS.a + MOM_TARGET_SLUG=$GITHUB_REPOSITORY \ + MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF \ + DO_REGRESSION_TESTS=true + + # XXX: This attempts to create an empty artifact! + - uses: actions/upload-artifact@v4 + with: + name: mom6-unit-target-artifact + path: | + .testing/build/target_codebase/.testing/build/timing/time_MOM_EOS + .testing/build/target_codebase/.testing/build/timing/time_MOM_remapping + retention-days: 1 + + build-coverage: + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile MOM6 with code coverage + run: make -C .testing build/cov/MOM6 -j -o build/deps/lib/libFMS.a + + - name: Compile MOM6 unit tests + run: | + make -C .testing build/unit/test_MOM_file_parser -j \ + -o build/deps/lib/libFMS.a + make -C .testing build.unit -j \ + -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-coverage-artifact + path: | + .testing/build/cov/MOM6 + .testing/build/cov/*.gcno + .testing/build/unit/test_MOM_EOS + .testing/build/unit/test_MOM_file_parser + .testing/build/unit/test_MOM_mixedlayer_restrat + .testing/build/unit/test_MOM_remapping + .testing/build/unit/test_MOM_string_functions + .testing/build/unit/test_numerical_testing_type + .testing/build/unit/*.gcno + retention-days: 1 + + build-coupled-api: + runs-on: ubuntu-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile MOM6 for the GFDL coupled driver + run: | + make -C .testing check_mom6_api_coupled -j \ + -o build/deps/lib/libFMS.a + + #--- + + test-grid: + runs-on: ubuntu-latest + needs: + - build-symmetric + - build-asymmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Download asymmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-asymmetric-artifact + path: .testing/build/asymmetric/ + + - name: Verify symmetric-asymmetric grid invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + chmod u+rx .testing/build/asymmetric/MOM6 + make -C .testing test.grid -o build/symmetric/MOM6 -o build/asymmetric/MOM6 + + test-layout: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify processor domain layout + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.layout -o build/symmetric/MOM6 + + test-rotate: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify rotational invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.rotate -o build/symmetric/MOM6 + + test-restart: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify restart invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.restart -o build/symmetric/MOM6 + + test-nan: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify aggressive initialization + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.nan -o build/symmetric/MOM6 + + test-dim-t: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify time dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.t -o build/symmetric/MOM6 + + test-dim-l: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify horizontal length dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.l -o build/symmetric/MOM6 + + test-dim-h: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify vertical thickness dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.h -o build/symmetric/MOM6 + + test-dim-z: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify vertical coordinate dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.z -o build/symmetric/MOM6 + + test-dim-q: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify heat dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.z -o build/symmetric/MOM6 + + test-dim-r: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify density dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.r -o build/symmetric/MOM6 + + test-openmp: + runs-on: ubuntu-latest + needs: + - build-symmetric + - build-openmp + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Download OpenMP MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-openmp-artifact + path: .testing/build/openmp/ + + - name: Verify OpenMP invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + chmod u+rx .testing/build/openmp/MOM6 + make -C .testing test.openmp -o build/symmetric/MOM6 -o build/openmp/MOM6 + + test-repro: + runs-on: ubuntu-latest + needs: + - build-symmetric + - build-repro + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download DEBUG MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Download REPRO MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-repro-artifact + path: .testing/build/repro/ + + - name: Verify REPRO equivalence + run: | + chmod u+rx .testing/build/symmetric/MOM6 + chmod u+rx .testing/build/repro/MOM6 + make -C .testing test.repro \ + -o build/symmetric/MOM6 \ + -o build/repro/MOM6 + + test-regression: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + needs: + - build-symmetric + - build-target + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Download target MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-target-artifact + path: .testing/build/target/ + + - name: Check for regressions + run: | + chmod u+rx .testing/build/symmetric/MOM6 + chmod u+rx .testing/build/target/MOM6 + make -C .testing test.regression \ + -o build/symmetric/MOM6 \ + -o build/target/MOM6 \ + DO_REGRESSION_TESTS=true + + run-coverage: + runs-on: ubuntu-latest + needs: build-coverage + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download unit coverage tests + uses: actions/download-artifact@v4 + with: + name: mom6-coverage-artifact + path: .testing/build/ + + - name: Generate MOM6 coverage + run: | + chmod u+rx .testing/build/cov/MOM6 + make -C .testing -j run.cov \ + -o build/cov/MOM6 + + - name: Generate unit test coverage + run: | + chmod u+rx .testing/build/unit/test_MOM_EOS + chmod u+rx .testing/build/unit/test_MOM_file_parser + chmod u+rx .testing/build/unit/test_MOM_mixedlayer_restrat + chmod u+rx .testing/build/unit/test_MOM_remapping + chmod u+rx .testing/build/unit/test_MOM_string_functions + chmod u+rx .testing/build/unit/test_numerical_testing_type + make -C .testing -j run.cov.unit \ + -o build/unit/test_MOM_file_parser \ + -o build/unit/test_MOM_EOS \ + -o build/unit/test_MOM_mixedlayer_restrat \ + -o build/unit/test_MOM_remapping \ + -o build/unit/test_MOM_string_functions \ + -o build/unit/test_numerical_testing_type + + - name: Report coverage to CI + run: | + make -C .testing report.cov \ + -o build/cov/MOM6 + make -C .testing report.cov.unit \ + -o build/unit/test_MOM_file_parser \ + -o build/unit/test_MOM_EOS \ + -o build/unit/test_MOM_mixedlayer_restrat \ + -o build/unit/test_MOM_remapping \ + -o build/unit/test_MOM_string_functions \ + -o build/unit/test_numerical_testing_type + 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 + - build-opt-target + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download optimized MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-opt-artifact + path: .testing/build/opt/ + + - name: Download optimized target MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-opt-target-artifact + path: .testing/build/opt_target/ + + # TODO: Move f90nml and chmod setup to another step? + - name: Profile with FMS clocks + run: | + pip install f90nml + chmod u+rx .testing/build/opt/MOM6 + chmod u+rx .testing/build/opt_target/MOM6 + make -C .testing profile -j \ + -o build/opt/MOM6 \ + -o build/opt_target/MOM6 \ + DO_REGRESSION_TESTS=true + + - name: Profile with perf + run: | + sudo sysctl -w kernel.perf_event_paranoid=2 + make -C .testing perf -j \ + -o build/opt/MOM6 \ + -o build/opt_target/MOM6 \ + DO_REGRESSION_TESTS=true + + # Collapse run.timing run.timing_target and show.timing into one rule + # TODO: Should this be a separate thing? + + - name: Download unit tests + uses: actions/download-artifact@v4 + with: + name: mom6-unit-artifact + path: .testing/build/timing + + # XXX: This fails because the files do not yet build. + #- name: Download unit tests + # uses: actions/download-artifact@v4 + # with: + # name: mom6-unit-target-artifact + # path: .testing/build/timing + + - name: Run unit test timings + run: | + chmod u+rx .testing/build/timing/time_MOM_EOS + chmod u+rx .testing/build/timing/time_MOM_remapping + make -C .testing run.timing -j \ + -o build/timing/time_MOM_EOS \ + -o build/timing/time_MOM_remapping + + - name: Run unit test target timings + run: | + make -C .testing run.timing_target -j \ + -o build/target_codebase/.testing/build/timing/time_MOM_EOS \ + -o build/target_codebase/.testing/build/timing/time_MOM_remapping \ + DO_REGRESSION_TESTS=true + + - name: Show timing results + run: | + make -C .testing show.timing \ + DO_REGRESSION_TESTS=true + + - name: Compare unit test timings + run: | + make -C .testing compare.timing \ + DO_REGRESSION_TESTS=true + + 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: | + fms-artifact + 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-t + - test-dim-l + - test-dim-h + - test-dim-z + - test-dim-q + - test-dim-r + - test-grid + - test-openmp + - test-repro + - run-coverage + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-symmetric-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-t + - test-dim-l + - test-dim-h + - test-dim-z + - test-dim-q + - test-dim-r + - test-grid + - test-openmp + - test-repro + - run-coverage + - test-regression + - run-timings + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-symmetric-artifact + mom6-target-artifact + mom6-opt-artifact + mom6-opt-target-artifact + mom6-unit-artifact + mom6-unit-target-artifact diff --git a/.github/workflows/verify-macos.yml b/.github/workflows/verify-macos.yml new file mode 100644 index 0000000000..790cac3e52 --- /dev/null +++ b/.github/workflows/verify-macos.yml @@ -0,0 +1,542 @@ +name: MacOS verification + +on: [push, pull_request] + +env: + CC: gcc + FC: gfortran + +jobs: + # Dependencies + build-fms: + runs-on: macOS-latest + + steps: + - name: Checkout + uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup/ + + - name: Build libFMS.a + run: make -C .testing build/deps/lib/libFMS.a -j + + - name: Upload libFMS.a and dependencies + uses: actions/upload-artifact@v4 + with: + name: fms-artifact + path: | + .testing/build/deps/include/ + .testing/build/deps/lib/libFMS.a + retention-days: 1 + + build-symmetric: + runs-on: macOS-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile symmetric index layout + run: | + make -C .testing build/symmetric/MOM6 -j -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/MOM6 + retention-days: 1 + + build-asymmetric: + runs-on: macOS-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile asymmetric index layout + run: | + make -C .testing build/asymmetric/MOM6 -j -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-asymmetric-artifact + path: .testing/build/asymmetric/MOM6 + retention-days: 1 + + build-repro: + runs-on: macOS-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile repro + run: make -C .testing build/repro/MOM6 -j -o build/deps/lib/libFMS.a + + - uses: actions/upload-artifact@v4 + with: + name: mom6-repro-artifact + path: .testing/build/repro/MOM6 + retention-days: 1 + + build-openmp: + runs-on: macOS-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile MOM6 supporting OpenMP + run: make -C .testing build/openmp/MOM6 -j -o build/symmetric/Makefile + + - uses: actions/upload-artifact@v4 + with: + name: mom6-openmp-artifact + path: .testing/build/openmp/MOM6 + retention-days: 1 + + build-target: + if: github.event_name == 'pull_request' + runs-on: macos-latest + needs: build-fms + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup/ + + - uses: actions/download-artifact@v4 + with: + name: fms-artifact + path: .testing/build/deps/ + + - name: Compile target MOM6 + run: | + make -C .testing build/target/MOM6 -j \ + -o build/deps/lib/libFMS.a \ + MOM_TARGET_SLUG=$GITHUB_REPOSITORY \ + MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF \ + DO_REGRESSION_TESTS=True + + - uses: actions/upload-artifact@v4 + with: + name: mom6-target-artifact + path: .testing/build/target/MOM6 + retention-days: 1 + + #--- + + test-grid: + runs-on: macOS-latest + needs: + - build-symmetric + - build-asymmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Download asymmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-asymmetric-artifact + path: .testing/build/asymmetric/ + + - name: Verify symmetric-asymmetric grid invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + chmod u+rx .testing/build/asymmetric/MOM6 + make -C .testing -k test.grid \ + -o build/symmetric/MOM6 \ + -o build/asymmetric/MOM6 + + test-layout: + runs-on: macOS-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify processor domain layout + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing -k test.layout \ + -o build/symmetric/MOM6 + + test-rotate: + runs-on: macOS-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify rotational invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing -k test.rotate -o build/symmetric/MOM6 + + test-restart: + runs-on: macOS-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify restart invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing -k test.restart -o build/symmetric/MOM6 + + test-nan: + runs-on: macOS-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify aggressive initialization + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing -k test.nan -o build/symmetric/MOM6 + + test-dim-t: + runs-on: macos-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify time dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.t -o build/symmetric/MOM6 + + test-dim-l: + runs-on: macos-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify horizontal length dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.l -o build/symmetric/MOM6 + + test-dim-h: + runs-on: macos-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify vertical thickness dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.h -o build/symmetric/MOM6 + + test-dim-z: + runs-on: macos-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify vertical coordinate dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.z -o build/symmetric/MOM6 + + test-dim-q: + runs-on: macos-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify heat dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.z -o build/symmetric/MOM6 + + test-dim-r: + runs-on: macos-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Verify density dimensional invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + make -C .testing test.dim.r -o build/symmetric/MOM6 + + test-openmp: + runs-on: macOS-latest + needs: + - build-symmetric + - build-openmp + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Download OpenMP MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-openmp-artifact + path: .testing/build/openmp/ + + - name: Verify OpenMP invariance + run: | + chmod u+rx .testing/build/symmetric/MOM6 + chmod u+rx .testing/build/openmp/MOM6 + make -C .testing -k test.openmp -k -o build/symmetric/MOM6 -o build/openmp/MOM6 + + test-repro: + runs-on: macOS-latest + needs: + - build-symmetric + - build-repro + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download DEBUG MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Download REPRO MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-repro-artifact + path: .testing/build/repro/ + + - name: Verify optimized equivalence + run: | + chmod u+rx .testing/build/symmetric/MOM6 + chmod u+rx .testing/build/repro/MOM6 + make -C .testing -k test.repro -o build/symmetric/MOM6 -o build/repro/MOM6 + + test-regression: + if: github.event_name == 'pull_request' + runs-on: macOS-latest + needs: + - build-symmetric + - build-target + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + path: .testing/build/symmetric/ + + - name: Download target MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-target-artifact + path: .testing/build/target/ + + - name: Check for regressions + run: | + chmod u+rx .testing/build/symmetric/MOM6 + chmod u+rx .testing/build/target/MOM6 + make -C .testing test.regression \ + -o build/symmetric/MOM6 \ + -o build/target/MOM6 \ + DO_REGRESSION_TESTS=true + + cleanup: + runs-on: macos-latest + permissions: + id-token: write + needs: + - test-grid + - test-layout + - test-rotate + - test-restart + - test-nan + - test-dim-t + - test-dim-l + - test-dim-h + - test-dim-z + - test-dim-q + - test-dim-r + - test-openmp + - test-repro + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + fms-artifact + mom6-*-artifact diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 39512c0dd1..5aa48ae919 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -202,7 +202,7 @@ actions:intel: script: - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - - module unload darshan-runtime ; module unload intel cray-libsci cray-mpich PrgEnv-intel ; module load PrgEnv-intel intel/2023.2.0 cray-hdf5 cray-netcdf cray-mpich + - 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" diff --git a/.testing/Makefile b/.testing/Makefile index a8a5ea3e68..ec6e5d1075 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -65,7 +65,10 @@ SHELL = bash # No implicit rules, suffixes, or variables -MAKEFLAGS += -rR +MAKEFLAGS += --no-builtin-rules +MAKEFLAGS += --no-builtin-variables + +.SUFFIXES: # Determine the MOM6 autoconf srcdir AC_SRCDIR := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))../ac @@ -267,16 +270,16 @@ $(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests # Build executables .NOTPARALLEL:$(foreach e,$(UNIT_EXECS),$(BUILD)/unit/$(e)) $(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE - cd $(@D) && $(TIME) $(MAKE) $(@F) -j + cd $(@D) && $(TIME) $(MAKE) $(@F) $(BUILD)/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) .NOTPARALLEL:$(foreach e,$(TIMING_EXECS),$(BUILD)/timing/$(e)) $(BUILD)/timing/time_%: $(BUILD)/timing/Makefile FORCE - cd $(@D) && $(TIME) $(MAKE) $(@F) -j + cd $(@D) && $(TIME) $(MAKE) $(@F) $(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) $(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE - cd $(@D) && $(TIME) $(MAKE) $(@F) -j + cd $(@D) && $(TIME) $(MAKE) $(@F) # Target codebase should use its own build system $(BUILD)/target/MOM6: $(BUILD)/target FORCE | $(TARGET_CODEBASE) @@ -285,6 +288,12 @@ $(BUILD)/target/MOM6: $(BUILD)/target FORCE | $(TARGET_CODEBASE) $(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 + +$(BUILD)/opt_target: | $(TARGET_CODEBASE) + ln -s $(abspath $(TARGET_CODEBASE))/.testing/build/opt $@ + FORCE: @@ -494,14 +503,10 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) # Regression testing only checks for changes in existing diagnostics .PRECIOUS: $(WORK)/%/target/chksum_diag %.regression.diag: $(foreach b,symmetric target,$(WORK)/%/$(b)/chksum_diag) - @! diff $^ | grep "^[<>]" | grep "^>" > /dev/null \ - || ! (\ - mkdir -p $(WORK)/results/$*; \ - (diff $^ | tee $(WORK)/results/$*/chksum_diag.regression.diff | head -n 20) ; \ + @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." @@ -545,8 +550,8 @@ $(WORK)/%/$(1)/ocean.stats $(WORK)/%/$(1)/chksum_diag: $(BUILD)/$(2)/MOM6 | prep && $(TIME) $(5) $(MPIRUN) -n $(6) $$(abspath $$<) 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ - cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 40 ; \ - cat std.err | tee ../../../results/$$*/std.$(1).err | tail -n 40 ; \ + 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." \ ) @@ -629,8 +634,8 @@ $(WORK)/%/restart/ocean.stats: $(BUILD)/symmetric/MOM6 | preproc # Run the first half-period cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std1.err > std1.out \ || !( \ - cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 40 ; \ - cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 40 ; \ + 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 @@ -640,8 +645,8 @@ $(WORK)/%/restart/ocean.stats: $(BUILD)/symmetric/MOM6 | preproc # Run the second half-period cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std2.err > std2.out \ || !( \ - cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 40 ; \ - cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 40 ; \ + 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." \ ) diff --git a/.testing/tools/cmp_diag.sh b/.testing/tools/cmp_diag.sh new file mode 100755 index 0000000000..03f29a5fd2 --- /dev/null +++ b/.testing/tools/cmp_diag.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +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_perf.py b/.testing/tools/compare_perf.py index e4a651c709..7b1f3fda8d 100755 --- a/.testing/tools/compare_perf.py +++ b/.testing/tools/compare_perf.py @@ -33,7 +33,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 +95,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..de9745df6a --- /dev/null +++ b/.testing/tools/diff_diag.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +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/ac/deps/m4/ax_fc_real8.m4 b/ac/deps/m4/ax_fc_real8.m4 index e914b9f39a..565018a984 100644 --- a/ac/deps/m4/ax_fc_real8.m4 +++ b/ac/deps/m4/ax_fc_real8.m4 @@ -15,12 +15,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 +36,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 +65,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_real8.m4 b/ac/m4/ax_fc_real8.m4 index e914b9f39a..565018a984 100644 --- a/ac/m4/ax_fc_real8.m4 +++ b/ac/m4/ax_fc_real8.m4 @@ -15,12 +15,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 +36,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 +65,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/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index b686c59a1f..07bff26395 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -17,6 +17,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 @@ -67,7 +68,7 @@ module MOM_surface_forcing_gfdl 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] @@ -85,14 +86,14 @@ 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-2 ~> 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-2 ~> 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 [nondim] @@ -145,6 +146,7 @@ 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 @@ -201,6 +203,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. @@ -242,9 +245,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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 [S ~> 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] + 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 @@ -302,7 +305,7 @@ 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) @@ -311,7 +314,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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 @@ -334,9 +337,9 @@ 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 @@ -355,6 +358,14 @@ 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%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 @@ -375,11 +386,11 @@ 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 @@ -399,11 +410,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 @@ -464,6 +475,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) & @@ -603,10 +618,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. @@ -614,21 +628,22 @@ 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 @@ -693,7 +708,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ 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]. - tau_mag_tmp ! A temporary array of surface stress magnitudes [R Z L T-2 ~> Pa] + 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] @@ -934,10 +949,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, !! 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 Z L T-2 ~> Pa] + !! 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 Z L T-2 ~> Pa] + !! 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 @@ -948,11 +963,12 @@ 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 :: 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, do_tau_mag, do_gustless_tau_mag integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) @@ -964,7 +980,7 @@ 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 + 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) @@ -1068,6 +1084,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ! 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 + 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 @@ -1079,19 +1097,19 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, gustiness = CS%gust(i,j) endif if (do_tau_mag) & - mag_tau(i,j) = gustiness + US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0) + 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) = US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0) + 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*US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0)) + ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*Pa_to_RZ2_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif if (CS%answer_date < 20190101) then if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = sqrt(US%Pa_to_RLZ_T2*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 * US%Pa_to_RLZ_T2*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 @@ -1099,7 +1117,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, 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.0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*((taux_in_B(I,J)**2) + (tauy_in_B(I,J)**2)) + & + 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))) ) / & @@ -1110,21 +1128,21 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) + 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.0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) + 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 @@ -1138,7 +1156,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, 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) @@ -1147,7 +1165,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag if (CS%answer_date < 20190101) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) + 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 @@ -1304,11 +1322,15 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! Local variables 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 [R ~> kg m-3] + 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. @@ -1472,7 +1494,9 @@ 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.) @@ -1573,27 +1597,28 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) 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, & + 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) ! 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(TideAmp_file, 'tideamp', CS%TKE_tidal, G%Domain, & + 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 = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) + 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 utide = CS%utide - CS%TKE_tidal(i,j) = rho_TKE_tidal*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 @@ -1606,7 +1631,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "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%Pa_to_RLZ_T2) + 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 "//& @@ -1617,7 +1642,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! 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) ! units in file should be [Pa] + rescale=US%Pa_to_RLZ_T2*US%L_to_Z) ! units in file should be [Pa] endif call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & @@ -1790,6 +1815,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 diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 9c4359bf60..e3b7b0cec7 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -32,7 +32,6 @@ 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 diff --git a/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 index 720046d517..e5c5943d4f 100644 --- a/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 @@ -63,7 +63,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] @@ -224,10 +224,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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 @@ -295,7 +295,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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 @@ -304,7 +304,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 @@ -329,9 +329,9 @@ 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 @@ -372,10 +372,10 @@ 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 @@ -395,11 +395,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 @@ -549,24 +549,24 @@ 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)) + 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 @@ -774,7 +774,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ((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) = gustiness + tau_mag + forces%tau_mag(i,j) = US%L_to_Z*(gustiness + tau_mag) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) enddo ; enddo @@ -800,7 +800,7 @@ 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.0)) gustiness = CS%gust(i,j) - forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2)) + 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 @@ -822,10 +822,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) = CS%gust(i,j) + sqrt(taux2 + tauy2) + 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) = CS%gust_const + sqrt(taux2 + tauy2) + 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 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 e2b86b3aac..11f12a0038 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -66,7 +66,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] @@ -273,10 +273,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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-1] - net_FW2, & !< The area integrated net freshwater flux into the ocean [kg s-1] + 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-1] + !! 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 @@ -346,7 +346,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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 @@ -355,7 +355,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 @@ -379,9 +379,9 @@ 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 @@ -422,10 +422,10 @@ 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 @@ -445,11 +445,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 @@ -662,24 +662,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)) + & + 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))) * & - 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)) + 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 @@ -898,7 +897,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ((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) = gustiness + tau_mag + 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) @@ -924,7 +923,7 @@ 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.0)) gustiness = CS%gust(i,j) - forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2)) + 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))) forces%omega_w2x(i,j) = atan2(tauy_at_h(i,j), taux_at_h(i,j)) @@ -947,10 +946,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) = CS%gust(i,j) + sqrt(taux2 + tauy2) + 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) = CS%gust_const + sqrt(taux2 + tauy2) + 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 diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index a8c872b0d3..faa94c3bdd 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -30,13 +30,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 : read_netCDF_data -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_type_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 @@ -45,19 +44,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 MARBL_forcing_mod, only : marbl_forcing_CS, MARBL_forcing_init -use MARBL_forcing_mod, only : convert_driver_fields_to_forcings +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 @@ -96,7 +94,7 @@ module MOM_surface_forcing 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-2 ~> 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-2 ~> Pa] !! gust is used when read_gust_2d is true. @@ -105,8 +103,6 @@ module MOM_surface_forcing 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-2 ~> Pa]. @@ -185,6 +181,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 @@ -301,7 +329,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 @@ -398,14 +427,14 @@ 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-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq @@ -418,14 +447,14 @@ 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 @@ -541,13 +570,13 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) ! set the friction velocity 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 + 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%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(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) ) + 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 call stresses_to_ustar(forces, G, US, CS) @@ -689,11 +718,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) 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 L Z T-2 ~> Pa] - integer :: time_lev_daily ! The time levels to read for fields with - integer :: time_lev_monthly ! daily and monthly cycles. + ! 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 @@ -701,31 +727,7 @@ subroutine wind_forcing_from_file(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 - 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) @@ -751,19 +753,19 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (.not.read_Ustar) then 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) + sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + 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) + sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) - forces%ustar(i,j) = sqrt(tau_mag * US%L_to_Z / CS%Rho0) + 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 if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie - forces%tau_mag(i,j) = CS%gust_const + sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + 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(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) / CS%Rho0) ) + 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 @@ -805,25 +807,25 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) 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) + & - 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 * 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) + & - 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 * US%L_to_Z / 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)))) + forces%ustar(i,j) = sqrt( tau_mag / CS%Rho0 ) 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 + & - 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 * 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(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)) + 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 @@ -836,7 +838,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) 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) = US%Z_to_L * CS%Rho0 * ustar_loc(i,j)**2 + 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) @@ -867,7 +869,7 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) 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 L Z T-2 ~> Pa] + ! 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") @@ -891,24 +893,24 @@ 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=US%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) = sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust(i,j) + 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 - tau_mag = sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust(i,j) - ustar_loc(i,j) = sqrt( tau_mag * 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) = sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust_const - ! ustar_loc(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) + 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 - 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)) + 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 @@ -919,7 +921,7 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) ! 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) = US%Z_to_L * CS%Rho0 * ustar_loc(i,j)**2 + forces%tau_mag(i,j) = CS%Rho0 * ustar_loc(i,j)**2 endif ; enddo ; enddo endif @@ -940,38 +942,37 @@ subroutine stresses_to_ustar(forces, G, US, CS) 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 reference density times a ratio of scaling - ! factors [Z L-1 R-1 ~> m3 kg-1] + 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 L Z T-2 ~> Pa] + ! 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 = US%L_to_Z / CS%Rho0 + 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) + & - 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 * 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) + & - 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 * 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 + & - 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 * 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 + & - 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 * 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 @@ -1004,11 +1005,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) 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") @@ -1018,35 +1017,11 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) 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 + fluxes_changed = .false. - if (time_lev_daily /= CS%buoy_last_lev_read) then - - ! 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 @@ -1054,14 +1029,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) @@ -1073,13 +1047,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) @@ -1087,13 +1060,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) @@ -1101,13 +1073,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 @@ -1117,13 +1088,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, & @@ -1133,13 +1103,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) @@ -1157,30 +1126,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, 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, 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 @@ -1202,8 +1169,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 @@ -1550,8 +1516,55 @@ 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. -! Sets the necessary MARBL forcings via the data override facility. + ! 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 @@ -1644,7 +1657,6 @@ subroutine MARBL_forcing_from_data_override(fluxes, day, G, US, CS) 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) @@ -1787,12 +1799,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 "//& @@ -1800,18 +1822,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 "//& @@ -1819,12 +1856,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 "//& @@ -1836,6 +1883,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, & @@ -1851,9 +1903,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C 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. @@ -1882,8 +1944,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C 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 "//& @@ -1906,6 +1968,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "or blank to get ustar from the wind stresses plus the "//& "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, & @@ -2039,7 +2106,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) + 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", & @@ -2079,7 +2146,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! 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) ! units in file should be [Pa] + 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.) @@ -2094,9 +2161,13 @@ 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", & diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index 559291b225..55b1be1172 100644 --- a/config_src/drivers/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -38,7 +38,7 @@ module user_surface_forcing 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-2 ~> 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. @@ -91,10 +91,10 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) 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%tau_mag(i,j) = G%mask2dT(i,j) * (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*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) * (US%L_to_Z/CS%Rho0)) + 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 @@ -275,7 +275,7 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) 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%Pa_to_RLZ_T2) + 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 "//& diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 index e4bea9d94f..e752686040 100644 --- a/config_src/drivers/timing_tests/time_MOM_remapping.F90 +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -9,8 +9,30 @@ program time_MOM_remapping implicit none type(remapping_CS) :: CS -integer, parameter :: nk=75, nij=20*20, nits=10, nsamp=100, nschemes = 2 -character(len=10) :: scheme_labels(nschemes) +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] @@ -31,9 +53,6 @@ program time_MOM_remapping seed(:) = 102030405 call random_seed(put=seed) -scheme_labels(1) = 'PCM' -scheme_labels(2) = 'PLM' - ! Set up some test data (note: using k,i indexing rather than i,k) allocate( u0(nk,nij), h0(nk,nij), u1(nk,nij), h1(nk,nij) ) call random_number(u0) ! In range 0-1 @@ -61,8 +80,8 @@ program time_MOM_remapping do isamp = 1, nsamp ! Time reconstruction + remapping do ischeme = 1, nschemes - call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme)), & - h_neglect=h_neglect, h_neglect_edge=h_neglect) + 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() diff --git a/config_src/drivers/unit_tests/test_MOM_remapping.F90 b/config_src/drivers/unit_tests/test_MOM_remapping.F90 index e62b779bd6..4c6fe4f750 100644 --- a/config_src/drivers/unit_tests/test_MOM_remapping.F90 +++ b/config_src/drivers/unit_tests/test_MOM_remapping.F90 @@ -2,6 +2,18 @@ program test_MOM_remapping use MOM_remapping, only : remapping_unit_tests -if (remapping_unit_tests(.true.)) stop 1 +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_numerical_testing_type.F90 b/config_src/drivers/unit_tests/test_numerical_testing_type.F90 new file mode 100644 index 0000000000..374c83f0c7 --- /dev/null +++ b/config_src/drivers/unit_tests/test_numerical_testing_type.F90 @@ -0,0 +1,7 @@ +program test_numerical_testing_type + +use numerical_testing_type, only : testing_type_unit_test + +if (testing_type_unit_test(.true.)) stop 1 + +end program test_numerical_testing_type diff --git a/src/tracer/MOM_generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 similarity index 100% rename from src/tracer/MOM_generic_tracer.F90 rename to config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index 95470e6510..1c41170582 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -28,7 +28,7 @@ subroutine particles_init(parts, Grid, Time, dt, u, v, h) end subroutine particles_init !> The main driver the steps updates particles -subroutine particles_run(parts, time, uo, vo, ho, tv, use_uh, 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 @@ -40,8 +40,8 @@ subroutine particles_run(parts, time, uo, vo, ho, tv, use_uh, stagger) !! 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 - integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered end subroutine particles_run diff --git a/config_src/infra/FMS1/MOM_constants.F90 b/config_src/infra/FMS1/MOM_constants.F90 index 2db177e08c..a632267a7f 100644 --- a/config_src/infra/FMS1/MOM_constants.F90 +++ b/config_src/infra/FMS1/MOM_constants.F90 @@ -3,12 +3,16 @@ 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_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index da977aa492..13c05de9c4 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -1259,53 +1259,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 - 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 diff --git a/config_src/infra/FMS2/MOM_constants.F90 b/config_src/infra/FMS2/MOM_constants.F90 index 2db177e08c..a632267a7f 100644 --- a/config_src/infra/FMS2/MOM_constants.F90 +++ b/config_src/infra/FMS2/MOM_constants.F90 @@ -3,12 +3,16 @@ 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_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 2d5c722cbd..258b164e51 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -1258,53 +1258,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 - 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 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/zotero.bib b/docs/zotero.bib index bbd2e30478..01fe2c6185 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2946,3 +2946,17 @@ @article{Young1994 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/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index b527192855..252a8e9a60 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -262,7 +262,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) 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, & + call initialize_remapping( CS%remapCS, string, nk=GV%ke, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & @@ -270,7 +270,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) 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, & + call initialize_remapping( CS%vel_remapCS, vel_string, nk=GV%ke, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & @@ -776,7 +776,7 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) 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 Conc kg m-2 s-1] + ! 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. diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 6081f7ffc7..c29b88286e 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -2051,7 +2051,7 @@ subroutine setCoordinateResolution( dz, CS, scale ) type(regridding_CS), intent(inout) :: CS !< Regridding control structure 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 + !! 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, & diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 3c2c0af6df..7257319edb 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -6,11 +6,11 @@ module MOM_remapping 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 remapping_attic, only : remapping_attic_unit_tests use PCM_functions, only : PCM_reconstruction use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation @@ -18,6 +18,24 @@ module MOM_remapping use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 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 + implicit none ; private !> Container for remapping parameters @@ -34,6 +52,12 @@ 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, 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 @@ -47,37 +71,12 @@ module MOM_remapping !> A negligibly small width for the purpose of edge value calculations in the same units !! as the h0 argument to remapping_core_h [H] real :: h_neglect_edge -end type -!> Class to assist in unit tests -type :: testing - private - !> True if any fail has been encountered since instantiation of "testing" - logical :: state = .false. - !> Count of tests checked - integer :: num_tests_checked = 0 - !> Count of tests failed - integer :: num_tests_failed = 0 - !> If true, be verbose and write results to stdout. Default True. - logical :: verbose = .true. - !> Error channel - integer :: stderr = 0 - !> Standard output channel - integer :: stdout = 6 - !> If true, stop instantly - logical :: stop_instantly = .false. - !> Record instances that fail - integer :: ifailed(100) = 0. - !> Record label of first instance that failed - character(len=:), allocatable :: label_first_fail - - contains - procedure :: test => test !< Update the testing state - procedure :: set => set !< Set attributes - procedure :: outcome => outcome !< Return current outcome - procedure :: summarize => summarize !< Summarize testing state - procedure :: real_arr => real_arr !< Compare array of reals - procedure :: int_arr => int_arr !< Compare array of integers + !> 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 @@ -97,6 +96,7 @@ module MOM_remapping 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 @@ -121,7 +121,8 @@ module MOM_remapping !> Set parameters within remapping object subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & check_reconstruction, check_remapping, force_bounds_in_subcell, & - om4_remap_via_sub_cells, answers_2018, answer_date, & + 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 @@ -129,6 +130,9 @@ subroutine remapping_set_param(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) :: 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 @@ -138,9 +142,18 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & 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 @@ -154,6 +167,15 @@ 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 @@ -177,7 +199,8 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & 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 @@ -187,6 +210,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 @@ -194,10 +220,14 @@ 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 -!> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. +!> 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 @@ -212,7 +242,6 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, PCM_cell) real, optional, intent(out) :: net_err !< Error in total column [A H] logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for !! cells in the source grid where this is true. - ! Local variables real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] @@ -225,7 +254,6 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, PCM_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 ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues real :: u02_err ! Integrated reconstruction error estimates [H A] real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] @@ -233,62 +261,76 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, PCM_cell) 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 - 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 ) + ! 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) - if (CS%om4_remap_via_sub_cells) then + if (CS%remapping_scheme == REMAPPING_VIA_CLASS) then - if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) +! if (CS%debug) call CS%reconstruction%set_debug() ! Sets an internal flag - ! 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 ) + 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, h0_eff, isub_src + ! Uses: h_sub, isrc_start, isrc_end, isrc_max, 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) + 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, & - force_bounds_in_target, u1, uh_err) + 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 - if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & - n1, h1, u1, iMethod, uh_err, "remapping_core_h") + else ! Uses the OM4-era reconstruction functions - else ! i.e. if (CS%om4_remap_via_sub_cells == .false.) + 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) - ! 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 ) + 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 - 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%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) + + endif ! Loop over each target cell summing the integrals from sub-cells within the target cell. ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub ! Sets: u1, uh_err - call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - force_bounds_in_target, u1, uh_err) - + 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 + if (present(net_err)) net_err = uh_err end subroutine remapping_core_h @@ -315,7 +357,6 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1) integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues real :: u02_err ! Integrated reconstruction error estimates [H A] real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] @@ -354,8 +395,8 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1) ! Loop over each target cell summing the integrals from sub-cells within the target cell. ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub ! Sets: u1, uh_err - call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - force_bounds_in_target, u1, uh_err) + 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 @@ -368,7 +409,7 @@ 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, PCM_cell ) + 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 [H] @@ -386,12 +427,16 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & !! 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 :: 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 @@ -484,6 +529,9 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & 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' ) @@ -617,15 +665,9 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & real :: dh ! The width of the sub-cell [H] real :: dh0_eff ! Running sum of source cell thickness [H] ! For error checking/debugging - integer :: i0_last_thick_cell logical :: src_has_volume !< True if h0 has not been consumed logical :: tgt_has_volume !< True if h1 has not been consumed - i0_last_thick_cell = 0 - do i0 = 1, n0 - if (h0(i0)>0.) i0_last_thick_cell = i0 - enddo - ! Initialize algorithm h0_supply = h0(1) h1_supply = h1(1) @@ -752,8 +794,50 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & 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 @@ -854,9 +938,9 @@ subroutine remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_s 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 + ! Updates: uh_sub, u_sub do i0 = 1, i0_last_thick_cell i_max = isrc_max(i0) dh_max = h_sub(i_max) @@ -903,7 +987,7 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, 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] + 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 @@ -965,7 +1049,6 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, i_sub = n0+n1+1 ! Sub-cell thickness from loop above dh = h_sub(i_sub) - ! Source cell i0 = isub_src(i_sub) @@ -995,7 +1078,7 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_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). + ! 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 @@ -1016,7 +1099,8 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, end subroutine remap_src_to_sub_grid !> Remaps column of n0+n1+1 values usub on sub-grid h_sub to targets on grid h1 -subroutine remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, & +!! 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 @@ -1076,6 +1160,87 @@ subroutine remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, & endif enddo +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 + 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 + enddo + end subroutine remap_sub_to_tgt_grid !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest @@ -1488,7 +1653,8 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & check_reconstruction, check_remapping, force_bounds_in_subcell, & - om4_remap_via_sub_cells, answers_2018, answer_date, & + 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 @@ -1497,6 +1663,9 @@ 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) :: 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 @@ -1504,13 +1673,24 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & !! 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, & + call remapping_set_param(CS, & + remapping_scheme=remapping_scheme, & + boundary_extrapolation=boundary_extrapolation, & + check_reconstruction=check_reconstruction, & + check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, answers_2018=answers_2018, answer_date=answer_date, & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + 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 @@ -1524,6 +1704,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 @@ -1555,6 +1744,54 @@ subroutine setReconstructionType(string,CS) 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 default call MOM_error(FATAL, "setReconstructionType: "//& "Unrecognized choice for REMAPPING_SCHEME ("//trim(string)//").") @@ -1572,17 +1809,276 @@ subroutine end_remapping(CS) end subroutine end_remapping +!> Test if interpolate_column() produces the wrong answer +subroutine test_interp(test, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + ! Local variables + real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] + + ! Interpolate from src to dest + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + call test%real_arr(ndest, u_dest, u_true, msg) +end subroutine test_interp + +!> Test if reintegrate_column() produces the wrong answer +subroutine test_reintegrate(test, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] + ! Local variables + real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + + ! Interpolate from src to dest + call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + call test%real_arr(ndest, uh_dest, uh_true, msg) + +end subroutine test_reintegrate + +!> 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=8) :: 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 + + write(label(1:8),'(i8)') niter + call test%test( error, trim(adjustl(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=8) :: 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 + + write(label(1:8),'(i8)') niter + call test%test( error, trim(adjustl(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=8) :: 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 + + enddo + + write(label(1:8),'(i8)') niter + call test%test( error, trim(adjustl(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=8) :: 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(1:8),'(i8)') niter + call test%test( error, trim(adjustl(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) +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 !< Remapping control structure + 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] @@ -1593,11 +2089,31 @@ logical function remapping_unit_tests(verbose) 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 :: i, om4 - character(len=4) :: om4_tag + 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 + type(PLM_CW) :: PLM_CW + type(PLM_hybgen) :: PLM_hybgen + type(MPLM_WA) :: MPLM_WA + type(EMPLM_WA) :: EMPLM_WA + type(MPLM_WA_poly) :: MPLM_WA_poly + type(EMPLM_WA_poly) :: EMPLM_WA_poly + type(PLM_CWK) :: PLM_CWK + type(MPLM_CWK) :: MPLM_CWK + type(EMPLM_CWK) :: EMPLM_CWK + type(PPM_H4_2019) :: PPM_H4_2019 + type(PPM_H4_2018) :: PPM_H4_2018 + type(PPM_CW) :: PPM_CW + type(PPM_hybgen) :: PPM_hybgen + type(PPM_CWK) :: PPM_CWK + type(EPPM_CWK) :: EPPM_CWK 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 @@ -1605,9 +2121,6 @@ logical function remapping_unit_tests(verbose) if (verbose) write(test%stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' - ! This line carries out tests on some older remapping schemes. - call test%test( remapping_attic_unit_tests(verbose), 'attic remapping unit tests' ) - if (verbose) write(test%stdout,*) ' - - - - - 1st generation tests - - - - -' call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date, & @@ -1849,10 +2362,10 @@ logical function remapping_unit_tests(verbose) ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| ! u_tgt = | 2 | 4 | 6 | call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .false., u1, u02_err) + .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., u1, u02_err) + .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 ) @@ -1955,10 +2468,10 @@ logical function remapping_unit_tests(verbose) ! h_tgt = |<- 2 ->|<- 4 ->| ! u_tgt = | 2 | 4 7/8 | call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .false., u1, u02_err) + .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., u1, u02_err) + .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 ) @@ -2015,10 +2528,10 @@ logical function remapping_unit_tests(verbose) ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| ! u_tgt = | 1.5 |2| 2.5 |3| 4 | call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .false., u1, u02_err) + .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., u1, u02_err) + .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 ) @@ -2210,193 +2723,223 @@ logical function remapping_unit_tests(verbose) 3, (/0.,0.,0./), (/0.,0.,0./), & 3, (/0.,0.,0./), (/0.,0.,0./) ) - remapping_unit_tests = test%summarize('remapping_unit_tests') + if (verbose) write(test%stdout,*) '- - - - - - - - - - Recon1d PCM tests - - - - - - - - -' + call test%test( PCM%unit_tests(verbose, test%stdout, test%stderr), 'PCM unit test') + call test%test( MPLM_WA%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_WA unit test') + call test%test( EMPLM_WA%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_WA unit test') + call test%test( MPLM_WA_poly%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_WA_poly unit test') + call test%test( EMPLM_WA_poly%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_WA_poly unit test') + call test%test( PLM_hybgen%unit_tests(verbose, test%stdout, test%stderr), 'PLM_hybgen unit test') + call test%test( PLM_CW%unit_tests(verbose, test%stdout, test%stderr), 'PLM_CW unit test') + call test%test( PLM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'PLM_CWK unit test') + call test%test( MPLM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_CWK unit test') + call test%test( EMPLM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_CWK unit test') + call test%test( PPM_H4_2019%unit_tests(verbose, test%stdout, test%stderr), 'PPM_H4_2019 unit test') + call test%test( PPM_H4_2018%unit_tests(verbose, test%stdout, test%stderr), 'PPM_H4_2018 unit test') + call test%test( PPM_hybgen%unit_tests(verbose, test%stdout, test%stderr), 'PPM_hybgen unit test') + call test%test( PPM_CW%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CW unit test') + call test%test( PPM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CWK unit test') + call test%test( EPPM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'EPPM_CWK 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_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_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) + + ! 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') -end function remapping_unit_tests + call end_remapping(CS) + deallocate( h0, u0, u1 ) -!> 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] + ! Brute force test that we have bitwise identical answers with the new classes + n0 = 7 + n1 = 4 - ! 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 + ! 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') -!> Test if reintegrate_column() produces the wrong answer -subroutine test_reintegrate(test, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) - type(testing), intent(inout) :: test !< Unit testing convenience functions - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] - real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] - real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] - ! Local variables - real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + ! 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') - ! 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) + ! 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') -end subroutine test_reintegrate + ! 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') -! ========================================================================================= -! The following provide the function for the testing_type helper class - -!> Update the state with "test" -subroutine test(this, state, label) - class(testing), intent(inout) :: this !< This testing class - logical, intent(in) :: state !< True to indicate a fail, false otherwise - character(len=*), intent(in) :: label !< Message - - this%num_tests_checked = this%num_tests_checked + 1 - if (state) then - this%state = .true. - this%num_tests_failed = this%num_tests_failed + 1 - this%ifailed( this%num_tests_failed ) = this%num_tests_checked - if (this%num_tests_failed == 1) this%label_first_fail = label - endif - if (this%stop_instantly .and. this%state) stop 1 -end subroutine test - -!> Set attributes -subroutine set(this, verbose, stdout, stderr, stop_instantly) - class(testing), intent(inout) :: this !< This testing class - logical, optional, intent(in) :: verbose !< True or false setting to assign to verbosity - integer, optional, intent(in) :: stdout !< The stdout channel to use - integer, optional, intent(in) :: stderr !< The stderr channel to use - logical, optional, intent(in) :: stop_instantly !< If true, stop immediately on error detection - - if (present(verbose)) then - this%verbose = verbose - endif - if (present(stdout)) then - this%stdout = stdout - endif - if (present(stderr)) then - this%stderr = stderr - endif - if (present(stop_instantly)) then - this%stop_instantly = stop_instantly - endif -end subroutine set - -!> Returns state -logical function outcome(this) - class(testing), intent(inout) :: this !< This testing class - outcome = this%state -end function outcome - -!> Summarize results -logical function summarize(this, label) - class(testing), intent(inout) :: this !< This testing class - character(len=*), intent(in) :: label !< Message - integer :: i - - if (this%state) then - write(this%stdout,'(a," : ",a,", ",i4," failed of ",i4," tested")') & - 'FAIL', trim(label), this%num_tests_failed, this%num_tests_checked - write(this%stdout,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,this%num_tests_failed) - write(this%stdout,'(a,a)') 'First failed test: ',trim(this%label_first_fail) - write(this%stderr,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,this%num_tests_failed) - write(this%stderr,'(a,a)') 'First failed test: ',trim(this%label_first_fail) - write(this%stderr,'(a," : ",a)') trim(label),'FAILED' - else - write(this%stdout,'(a," : ",a,", all ",i4," tests passed")') & - 'Pass', trim(label), this%num_tests_checked - endif - summarize = this%state -end function summarize + ! 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') -!> Compare u_test to u_true, report, and return true if a difference larger than tol is measured -!! -!! If in verbose mode, display results to stdout -!! If a difference is measured, display results to stdout and stderr -subroutine real_arr(this, n, u_test, u_true, label, tol) - class(testing), intent(inout) :: this !< This testing class - integer, intent(in) :: n !< Number of cells in u - real, dimension(n), intent(in) :: u_test !< Values to test [A] - real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) [A] - character(len=*), intent(in) :: label !< Message - real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] - ! Local variables - integer :: k - logical :: this_test - real :: tolerance, err ! Tolerance for differences, and error [A] + ! 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') - tolerance = 0.0 - if (present(tol)) tolerance = tol - this_test = .false. + ! 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') - ! Scan for any mismatch between u_test and u_true - do k = 1, n - if (abs(u_test(k) - u_true(k)) > tolerance) this_test = .true. - enddo + ! 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') - ! 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 - err = u_test(k) - u_true(k) - if (abs(err) > tolerance) then - write(this%stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & - ' err=', err, ' <--- WRONG' - write(this%stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & - ' err=', err, ' <--- WRONG' - else - write(this%stdout,'(i4,1p2e24.16)') k, u_test(k), u_true(k) - endif - enddo - endif + ! 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') - call this%test( this_test, label ) ! Updates state and counters in this -end subroutine real_arr + ! 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') -!> Compare i_test to i_true and report and return true if a difference is found -!! -!! If in verbose mode, display results to stdout -!! If a difference is measured, display results to stdout and stderr -subroutine int_arr(this, n, i_test, i_true, label) - class(testing), intent(inout) :: this !< This testing class - integer, intent(in) :: n !< Number of cells in u - integer, dimension(n), intent(in) :: i_test !< Values to test [A] - integer, dimension(n), intent(in) :: i_true !< Values to test against (correct answer) [A] - character(len=*), intent(in) :: label !< Message - ! Local variables - integer :: k - logical :: this_test + ! 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') - this_test = .false. + ! 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') - ! Scan for any mismatch between u_test and u_true - do k = 1, n - if (i_test(k) .ne. i_true(k)) this_test = .true. - enddo + ! 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') - if (this%verbose) then - write(this%stdout,'(a12," : calculated =",30i3)') label, i_test - write(this%stdout,'(12x," correct =",30i3)') i_true - if (this_test) write(this%stdout,'(3x,a,8x,"error =",30i3)') 'FAIL --->', i_test(:) - i_true(:) - endif - if (this_test) then - write(this%stderr,'(a12," : calculated =",30i3)') label, i_test - write(this%stderr,'(12x," correct =",30i3)') i_true - write(this%stderr,'(" FAIL ---> error =",30i3)') i_test(:) - i_true(:) - endif - - call this%test( this_test, label ) ! Updates state and counters in this -end subroutine int_arr + ! 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/Recon1d_EMPLM_CWK.F90 b/src/ALE/Recon1d_EMPLM_CWK.F90 new file mode 100644 index 0000000000..01d97058a9 --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_CWK.F90 @@ -0,0 +1,148 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..fc46cf74f6 --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_WA.F90 @@ -0,0 +1,172 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..bcfc398cf9 --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_WA_poly.F90 @@ -0,0 +1,200 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..2b9ed9853d --- /dev/null +++ b/src/ALE/Recon1d_EPPM_CWK.F90 @@ -0,0 +1,175 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..dc401a8440 --- /dev/null +++ b/src/ALE/Recon1d_MPLM_CWK.F90 @@ -0,0 +1,292 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..b9fa635063 --- /dev/null +++ b/src/ALE/Recon1d_MPLM_WA.F90 @@ -0,0 +1,285 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..4a4bdc95bb --- /dev/null +++ b/src/ALE/Recon1d_MPLM_WA_poly.F90 @@ -0,0 +1,490 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..3b64844983 --- /dev/null +++ b/src/ALE/Recon1d_PCM.F90 @@ -0,0 +1,196 @@ +!> 1D reconstructions using the Piecewise Constant Method (PCM) +module Recon1d_PCM + +! This file is part of MOM6. See LICENSE.md for the license. + +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 +!! 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 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 + +!> 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') + + 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..0c53246286 --- /dev/null +++ b/src/ALE/Recon1d_PLM_CW.F90 @@ -0,0 +1,371 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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 +!! - 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 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 + +!> 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') + + 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..b30af80aa1 --- /dev/null +++ b/src/ALE/Recon1d_PLM_CWK.F90 @@ -0,0 +1,121 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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() +!! - 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_hybgen.F90 b/src/ALE/Recon1d_PLM_hybgen.F90 new file mode 100644 index 0000000000..0cf2e8e001 --- /dev/null +++ b/src/ALE/Recon1d_PLM_hybgen.F90 @@ -0,0 +1,395 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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 +!! - 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') + + 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..9523ad46ea --- /dev/null +++ b/src/ALE/Recon1d_PPM_CW.F90 @@ -0,0 +1,420 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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 +!! - 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 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 ! 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 + + 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') + + 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') + + ! 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..a0cbce5877 --- /dev/null +++ b/src/ALE/Recon1d_PPM_CWK.F90 @@ -0,0 +1,401 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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 +!! - 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 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 ! 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 + +!> 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') + + ! 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..d668b70ace --- /dev/null +++ b/src/ALE/Recon1d_PPM_H4_2018.F90 @@ -0,0 +1,303 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..d01ff3fb2b --- /dev/null +++ b/src/ALE/Recon1d_PPM_H4_2019.F90 @@ -0,0 +1,585 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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..2978dd9269 --- /dev/null +++ b/src/ALE/Recon1d_PPM_hybgen.F90 @@ -0,0 +1,403 @@ +!> 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 + +! This file is part of MOM6. See LICENSE.md for the license. + +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() -> 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 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 reconstructions based on h(:) and u(:) +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 + real :: h0, h1, h2, h3 ! Cell thickness h(k-2), h(k-1), h(k), h(k+1) in K loop [H] + real :: h01_h112, h23_h122 ! Approximately 2/3 [nondim] + real :: h112, h122 ! Approximately 3 h [H] + real :: ddh ! Approximately 0 [nondim] + real :: I_h12, I_h01, 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, duc ! Difference between edges across cell [A] + real :: slp(this%n) ! PLM slope [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: slope_x_h ! retained PLM slope times half grid step [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] + real :: u0_avg ! avg value at given edge [A] + integer :: k, n, km1, kp1 + + n = this%n + + ! First populate the PLM reconstructions + slp(1) = 0. + do k = 2, n-1 + h0 = max( this%h_neglect, h(k-1) ) + h1 = max( this%h_neglect, h(k) ) + h2 = max( this%h_neglect, h(k+1) ) + dul = u(k) - u(k-1) + dur = u(k+1) - u(k) + h112 = ( 2.0 * h0 + h1 ) + h122 = ( h1 + 2.0 * h2 ) + I_h01 = 1. / ( h0 + h1 ) + I_h12 = 1. / ( h1 + h2 ) + h01_h112 = ( 2.0 * h0 + h1 ) / ( h0 + h1 ) ! When uniform -> 3/2 + h23_h122 = ( 2.0 * h2 + h1 ) / ( h2 + h1 ) ! When uniform -> 3/2 + if ( dul * dur > 0.) then + du = ( h1 / ( h1 + ( h0 + h2 ) ) ) * ( h112 * dur * I_h12 + h122 * dul * I_h01 ) + slp(k) = sign( min( abs(2.0 * dul), abs(du), abs(2.0 * dur) ), du) + else + slp(k) = 0. + endif + enddo + slp(n) = 0. + + this%ul(1) = u(1) ! PCM + this%ur(1) = u(1) ! PCM + this%ul(2) = u(1) ! PCM + do K = 3, n-1 ! K=3 is interface between cells 2 and 3 + h0 = max( this%h_neglect, h(k-2) ) + h1 = max( this%h_neglect, h(k-1) ) + h2 = max( this%h_neglect, h(k) ) + h3 = max( this%h_neglect, h(k+1) ) + h01_h112 = ( h0 + h1 ) / ( 2. * h1 + h2 ) ! When uniform -> 2/3 + h23_h122 = ( h2 + h3 ) / ( h1 + 2. * h2 ) ! When uniform -> 2/3 + ddh = h01_h112 - h23_h122 ! When uniform -> 0 + I_h12 = 1.0 / ( h1 + h2 ) ! When uniform -> 1/(2h) + I_h0123 = 1.0 / ( ( h0 + h1 ) + ( h2 + h3 ) ) ! When uniform -> 1/(4h) + dul = slp(k-1) + dur = slp(k) + u1 = u(k-1) + u2 = u(k) + edge = I_h12 * ( h2 * u1 + h1 * u2 ) & ! 1/2 u1 + 1/2 u2 + + I_h0123 * ( 2.0 * h1 * h2 * I_h12 * ( u2 - u1 ) * ddh & ! 0 + + ( h2 * dul * h23_h122 - h1 * dur * h01_h112 ) ) ! 1/6 dul - 1/6 dur + this%ur(k-1) = edge + this%ul(k) = edge + enddo + this%ur(n-1) = u(n) ! PCM + this%ur(n) = u(n) ! PCM + this%ul(n) = u(n) ! PCM + + do K = 2, n ! 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) ) ) + a6 = 6.0 * u1 - 3.0 * ( this%ul(k) + 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) ! Subject to round off + ! 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) ! Subject to round off + ! u_min = min( u1, u2 ) + ! u_max = max( u1, u2 ) + ! edge = max( min( edge, u_max), u_min ) + this%ur(k) = edge + endif + enddo + + ! ### Note that the PPM_HYBGEM option calculated the CW PPM coefficients and then + ! invoked the OM4-era limiters afterwards, effectively doing the limiters twice. + ! This second pass does change answers! + + ! 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)-this%ul(k)) * (this%ul(k)-u(k)) < 0.0 ) then + this%ul(k) = u(k) - sign( min( abs(slope_x_h), abs(this%ul(k)-u(k)) ), slope_x_h ) + endif + + if ( (u(kp1)-this%ur(k)) * (this%ur(k)-u(k)) < 0.0 ) then + this%ur(k) = u(k) + sign( min( abs(slope_x_h), abs(this%ur(k)-u(k)) ), slope_x_h ) + endif + + ! Finally bound by neighboring cell means in case of roundoff + this%ul(k) = max( min( this%ul(k), max(u(km1), u(k)) ), min(u(km1), u(k)) ) + this%ur(k) = max( min( this%ur(k), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) + + enddo ! loop on interior edges + + do k = 1, n-1 + if ( (this%ul(k+1) - this%ur(k)) * (u(k+1) - u(k)) < 0.0 ) then + u0_avg = 0.5 * ( this%ur(k) + this%ul(k+1) ) + u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) + this%ur(k) = u0_avg + this%ul(k+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 + u0 = u(k-1) + u1 = u(k) + u2 = u(k+1) + + edge_l = this%ul(k) + edge_r = this%ur(k) + + if ( (u2 - u1)*(u1 - u0) <= 0.0) then + ! Flatten extremum + edge_l = u1 + edge_r = u1 + else + expr1 = 3.0 * (edge_r - edge_l) * ( (u1 - edge_l) + (u1 - 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 = u1 + 2.0 * ( u1 - edge_r ) + edge_l = max( min( edge_l, max(u0, u1) ), min(u0, u1) ) ! In case of round off + elseif ( expr1 < -expr2 ) then + ! Place extremum at left edge of cell by adjusting right edge value + edge_r = u1 + 2.0 * ( u1 - edge_l ) + edge_r = max( min( edge_r, max(u2, u1) ), min(u2, u1) ) ! 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 ) 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 +!! + +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..4411e1288e --- /dev/null +++ b/src/ALE/Recon1d_type.F90 @@ -0,0 +1,324 @@ +!> A generic type for vertical 1D reconstructions +module Recon1d_type + +! This file is part of MOM6. See LICENSE.md for the license. + +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 [same as h, H] + 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 + + !> 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 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 + + !> 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 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 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 + +!> 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/_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/remapping_attic.F90 b/src/ALE/remapping_attic.F90 deleted file mode 100644 index ab345dc53e..0000000000 --- a/src/ALE/remapping_attic.F90 +++ /dev/null @@ -1,653 +0,0 @@ -!> Retains older versions of column-wise vertical remapping functions that are -!! no longer used in MOM6, but may be useful later for documenting the development -!! of the schemes that are used in MOM6. -module remapping_attic - -! 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_io, only : stdout -use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation -use regrid_edge_values, only : edge_values_explicit_h4 - -implicit none ; private - -! The following routines are visible to the outside world -public remapping_attic_unit_tests, remapByProjection, remapByDeltaZ -public isPosSumErrSignificant - -! The following are private parameter constants -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 - -! 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__ - -contains - -!> 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 in arbitrary units [A] - real, intent(in) :: sum2 !< Sum of n2 values [A] - logical :: isPosSumErrSignificant !< True if difference in sums is large - ! Local variables - real :: sumErr ! The absolutde difference in the sums [A] - real :: allowedErr ! The tolerance for the integrated reconstruction [A] - real :: eps ! A tiny fractional error [nondim] - - 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 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) in thickness units [H] - real, intent(in) :: u0(:) !< Source cell averages (size n0) in arbitrary units [A] - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(:) !< Target grid widths (size n1) [H] - integer, intent(in) :: method !< Remapping scheme to use - real, intent(out) :: u1(:) !< Target cell averages (size n1) [A] - real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h [H]. - ! Local variables - integer :: iTarget - real :: xL, xR ! coordinates of target cell edges [H] - integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() [H] - - ! 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) in thickness units [H] - real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) in arbitrary units [A] - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial [A] - integer, intent(in) :: n1 !< Number of cells in target grid - real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) [H] - integer, intent(in) :: method !< Remapping scheme to use - real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) [A] - real, dimension(:), & - optional, intent(out) :: h1 !< Target grid widths (size n1) [H] - real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h [H]. - ! Local variables - integer :: iTarget - real :: xL, xR ! Coordinates of target cell edges [H] - real :: xOld, xNew ! Edge positions on the old and new grids [H] - real :: hOld, hNew ! Cell thicknesses on the old and new grids [H] - real :: uOld ! A source cell average of u [A] - real :: h_err ! An estimate of the error in the reconstructed thicknesses [H] - real :: uhNew ! Cell integrated u on the new grid [A H] - real :: hFlux ! Width of the remapped volume [H] - real :: uAve ! Target cell average of u [A] - real :: fluxL, fluxR ! Fluxes of u through the two cell faces [A H] - integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() [H] - - ! 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, h_neglect ) - ! 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) in thickness units [H] - real, dimension(:), intent(in) :: u0 !< Source cell averages in arbitrary units [A] - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial [A] - integer, intent(in) :: method !< Remapping scheme to use - real, intent(in) :: xL !< Left edges of target cell [H] - real, intent(in) :: xR !< Right edges of target cell [H] - real, intent(in) :: hC !< Cell width hC = xR - xL [H] - real, intent(out) :: uAve !< Average value on target cell [A] - 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 [H] - !< On first entry should be 0. - real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h [H] - ! Local variables - integer :: j, k - integer :: jL, jR ! indexes of source cells containing target cell edges - real :: q ! complete integration [A H] - real :: xi0, xi1 ! interval of integration (local -- normalized -- coordinates) [nondim] - real :: x0jLl, x0jLr ! Left/right position of cell jL [H] - real :: x0jRl, x0jRr ! Left/right position of cell jR [H] - real :: hAct ! The distance actually used in the integration - ! (notionally xR - xL) which differs due to roundoff [H]. - real :: x0_2, x1_2 ! Squares of normalized positions used to evaluate polynomials [nondim] - real :: x0px1, x02px12 ! Sums of normalized positions and their squares [nondim] - real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] - - 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) + h_neglect ) - x0jLl / ( h0(jL) + h_neglect ) - - 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) + h_neglect ) ) ) - xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + h_neglect ) ) ) -#else - xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) - xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) -#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) + h_neglect ) ) ) -#else - xi0 = (xL - x0jLl) / ( h0(jL) + h_neglect ) -#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) + h_neglect ) ) ) -#else - xi1 = (xR - x0jRl) / ( h0(jR) + h_neglect ) -#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) [H] - integer, intent(in) :: n2 !< Number of cells on target grid - 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 ! Interface positions [H] - - x1 = 0. - x2 = 0. - dx(1) = 0. - do K = 1, max(n1,n2) - if (k <= n1) x1 = x1 + h1(k) ! Interface k+1, right of source cell k - if (k <= n2) then - x2 = x2 + h2(k) ! Interface k+1, right of target cell k - dx(K+1) = x2 - x1 ! Change of interface k+1, target - source - endif - enddo - -end subroutine dzFromH1H2 - -!> Calculate edge coordinate x from cell width h -subroutine buildGridFromH(nz, h, x) - integer, intent(in) :: nz !< Number of cells - real, dimension(nz), intent(in) :: h !< Cell widths [H] - real, dimension(nz+1), intent(inout) :: x !< Edge coordinates starting at x(1)=0 [H] - ! Local variables - integer :: k - - x(1) = 0.0 - do k = 1,nz - x(k+1) = x(k) + h(k) - enddo - -end subroutine buildGridFromH - -!> Runs unit tests on archaic remapping functions. -!! Should only be called from a single/root thread -!! Returns True if a test fails, otherwise False -logical function remapping_attic_unit_tests(verbose) - logical, intent(in) :: verbose !< If true, write results to stdout - ! Local variables - integer, parameter :: n0 = 4, n1 = 3, n2 = 6 - real :: h0(n0), x0(n0+1) ! Test cell widths and edge coordinates [H] - real :: u0(n0) ! Test values for remapping in arbitrary units [A] - real :: h1(n1), x1(n1+1) ! Test cell widths and edge coordinates [H] - real :: u1(n1) ! Test values for remapping [A] - real :: h2(n2), x2(n2+1) ! Test cell widths and edge coordinates [H] - real :: u2(n2) ! Test values for remapping [A] - real :: hn1(n1), hn2(n2) ! Updated grid thicknesses [H] - real :: dx1(n1+1), dx2(n2+1) ! Differences in interface positions [H] - 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 - real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S ! Polynomial edge values [A] - real, allocatable, dimension(:,:) :: ppoly0_coefs ! Polynomial reconstruction coefficients [A] - integer :: answer_date ! The vintage of the expressions to test - integer :: i, degree - real :: err ! Difference between a remapped value and its expected value [A] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses used in remapping [H] - logical :: thisTest, v - - v = verbose - answer_date = 20190101 ! 20181231 - h_neglect = 1.0E-30 - h_neglect_edge = h_neglect ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 - - write(stdout,*) '==== remapping_attic: remapping_attic_unit_tests =================' - remapping_attic_unit_tests = .false. ! Normally return false - - call buildGridFromH(n0, h0, x0) - call buildGridFromH(n1, h1, x1) - - thisTest = .false. - degree = 2 - if (verbose) write(stdout,*) 'h0 (test data)' - if (verbose) call dumpGrid(n0,h0,x0,u0) - - call dzFromH1H2( n0, h0, n1, h1, dx1 ) - - thisTest = .false. - allocate(ppoly0_E(n0,2)) - allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefs(n0,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, answer_date=answer_date ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) - 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_attic_unit_tests: Failed remapByProjection()' - remapping_attic_unit_tests = remapping_attic_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_attic_unit_tests: Failed remapByDeltaZ() 1' - remapping_attic_unit_tests = remapping_attic_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_attic_unit_tests: Failed remapByDeltaZ() 2' - remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest - - if (.not. remapping_attic_unit_tests) write(stdout,*) 'Pass' - -end function remapping_attic_unit_tests - -!> Convenience function for printing grid to screen -subroutine dumpGrid(n,h,x,u) - integer, intent(in) :: n !< Number of cells - real, dimension(:), intent(in) :: h !< Cell thickness [H] - real, dimension(:), intent(in) :: x !< Interface delta [H] - real, dimension(:), intent(in) :: u !< Cell average values [A] - integer :: i - write(stdout,'("i=",20i10)') (i,i=1,n+1) - write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) - write(stdout,'("i=",5x,20i10)') (i,i=1,n) - write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) - write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) -end subroutine dumpGrid - -end module remapping_attic diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index aeb316b950..156a397ff6 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -5,7 +5,7 @@ module MOM ! Infrastructure modules use MOM_array_transform, only : rotate_array, rotate_vector -use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum +use MOM_debugging, only : 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 @@ -276,9 +276,11 @@ module MOM 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 @@ -301,6 +303,8 @@ module MOM !! 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. @@ -471,6 +475,7 @@ module MOM integer :: id_clock_ocean integer :: id_clock_dynamics integer :: id_clock_thermo +integer :: id_clock_remap integer :: id_clock_tracer integer :: id_clock_diabatic integer :: id_clock_adiabatic @@ -535,7 +540,8 @@ 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 @@ -545,8 +551,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] @@ -555,9 +562,12 @@ 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 :: do_advection ! If true, it is time to advect tracers. - 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. @@ -663,6 +673,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS 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) @@ -675,6 +687,18 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ntstep = MAX(1, MIN(n_max, floor(CS%dt_therm/dt + 0.001))) dt_therm = dt*ntstep endif + 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) + ! ntstep 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) @@ -861,6 +885,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! 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. @@ -891,9 +918,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. @@ -920,16 +953,17 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (associated(CS%HA_CSp)) call HA_accum_FtF(Time_Local, CS%HA_CSp) call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & - dt_therm_here, bbl_time_int, CS, & + 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) + do_advection = .false. + if (tradv_does_span_coupling .or. .not.do_thermo) then + do_advection = (CS%t_dyn_rel_adv + 0.5*dt > dt_tr_adv) + if (CS%t_dyn_rel_thermo + 0.5*dt > dt_therm) do_advection = .true. 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. @@ -942,7 +976,15 @@ 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 (do_thermo) then + do_diabatic = .false. + if (thermo_does_span_coupling .or. .not.do_dyn) then + do_diabatic = (CS%t_dyn_rel_thermo + 0.5*dt > dt_therm) + else + do_diabatic = ((MOD(n,ntstep) == 0) .or. (n==n_max)) + endif + endif + if ((CS%t_dyn_rel_adv==0.0) .and. do_thermo .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 @@ -964,6 +1006,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! 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 @@ -988,7 +1033,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 @@ -1110,7 +1159,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 @@ -1120,7 +1169,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], @@ -1172,12 +1221,12 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse_first .and. & (CS%thickness_diffuse .or. CS%interface_filter)) then - call enable_averages(dt_thermo, Time_local+real_to_time(US%T_to_s*(dt_thermo-dt)), CS%diag) + call enable_averages(dt_tr_adv, Time_local+real_to_time(US%T_to_s*(dt_tr_adv-dt)), 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_thermo, G, GV, US, & + 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) @@ -1189,7 +1238,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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_thermo, G, GV, US, & + 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=max(2,CS%cont_stencil)) @@ -1284,6 +1333,18 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif ! -------------------------------------------------- end SPLIT + 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 @@ -1331,8 +1392,13 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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_thermo, G, GV, US, & - CS%CDp, CS%interface_filter_CSp) + 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=max(2,CS%cont_stencil)) if (showCallTree) call callTree_waypoint("finished interface_filter (step_MOM)") @@ -1369,23 +1435,21 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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) then !Run particles using thickness-weighted velocity call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, & - CS%tv, CS%use_uh_particles) - elseif (CS%use_particles .and. CS%do_dynamics) then - !Run particles using unweighted velocity - call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, & - CS%tv, CS%use_uh_particles) + CS%tv, CS%t_dyn_rel_adv, CS%use_uh_particles) endif - - ! Advance the dynamics time by dt. - CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt 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 @@ -1517,7 +1581,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_regrid. +!! 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 @@ -1539,19 +1603,6 @@ 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. - 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, pass_T_S_h, pass_uv_T_S_h @@ -1565,9 +1616,6 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (showCallTree) call callTree_enter("step_MOM_thermo(), MOM.F90") if (CS%debug) call query_debugging_checks(do_redundant=debug_redundant) - use_ice_shelf = .false. - if (associated(CS%frac_shelf_h)) use_ice_shelf = .true. - call enable_averages(dtdia, Time_end_thermo, CS%diag) if (associated(CS%odaCS)) then @@ -1633,131 +1681,6 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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_regrid' 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%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)) then - call pass_var(h, G%Domain, complete=.false.) - call pass_var(h_new, G%Domain, complete=.true.) - call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) - endif - - 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 (step_MOM_thermo)") - call cpu_clock_end(id_clock_ALE) - endif ! endif for the block "if ( CS%use_ALE_algorithm )" - - - 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) - - ! 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 (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 - - ! 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 (CS%debug) then 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) @@ -1806,10 +1729,243 @@ 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, pass_T_S_h, pass_uv_T_S_h + integer :: dynamics_stencil ! The computational stencil for the calculations + ! in the dynamic core. + 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)) then + call pass_var(h, G%Domain, complete=.false.) + call pass_var(h_new, G%Domain, complete=.true.) + call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) + endif + + 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_T_S, pass_T_S_h, pass_uv_T_S_h + integer :: dynamics_stencil ! The computational stencil for the calculations + ! in the dynamic core. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + 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) + + ! 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 @@ -2326,16 +2482,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & "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, 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)) 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. ", & @@ -2362,19 +2508,55 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & "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 @@ -2740,20 +2922,20 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (CS%tv%T_is_conT) then vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & cmor_field_name="bigthetao", cmor_longname="Sea Water Conservative Temperature", & - conversion=US%Q_to_J_kg*CS%tv%C_p) + 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="absso", cmor_longname="Sea Water Absolute Salinity", & - conversion=0.001*US%S_to_ppt) + 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*US%S_to_ppt) + conversion=US%S_to_ppt) endif if (advect_TS) then @@ -3571,6 +3753,7 @@ subroutine MOM_timing_init(CS) 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_tracer = cpu_clock_id('(Ocean tracer advection)', grain=CLOCK_MODULE_DRIVER) if (.not.CS%adiabatic) then @@ -4060,7 +4243,7 @@ subroutine extract_surface_state(CS, sfc_state_in) 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 & + 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 & .or. sfc_state%sea_lev(i,j) + G%bathyT(i,j) + G%Z_ref < CS%bad_val_col_thick @@ -4087,7 +4270,7 @@ subroutine extract_surface_state(CS, sfc_state_in) write(msg(1:240),'(2(a,i4,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), & + '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) @@ -4193,7 +4376,7 @@ 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 * & + 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, unscale=CS%US%S_to_ppt) diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index ad76a9a9f5..191ee439c9 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -16,7 +16,7 @@ module MOM_PressureForce 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 @@ -38,7 +38,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 @@ -51,6 +51,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)), & @@ -63,10 +64,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 @@ -81,7 +82,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, SAL_CSp, 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 @@ -89,6 +90,7 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, ti 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(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" @@ -105,7 +107,7 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, ti if (CS%Analytic_FV_PGF) then call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_FV, SAL_CSp, 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, SAL_CSp, tides_CSp) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 42e6514ab9..aaabab3500 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -14,7 +14,7 @@ module MOM_PressureForce_FV 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_spec_vol, EOS_domain use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp @@ -39,10 +39,13 @@ 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 :: 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]. + 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. @@ -57,6 +60,9 @@ module MOM_PressureForce_FV 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] @@ -80,16 +86,22 @@ module MOM_PressureForce_FV !! equation of state is 0 to account for the displacement of the sea !! surface including adjustments for atmospheric or sea-ice pressure. logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF - integer :: tides_answer_date !< Recover old answers with tides in Boussinesq mode + 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_tide_eq = -1 !< Diagnostic identifier - integer :: id_e_tide_sal = -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 @@ -105,7 +117,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 @@ -115,6 +127,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 @@ -141,12 +154,16 @@ 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]. + 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_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. - e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + 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_tide, & ! The summation of self-attraction and loading and tidal forcing [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) :: & @@ -204,8 +221,12 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ 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)) :: & @@ -216,6 +237,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ 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]. @@ -238,7 +260,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ 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 :: 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 @@ -268,8 +290,9 @@ 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 @@ -346,7 +369,8 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k), & p(:,:,K), p(:,:,K+1), alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & - P_surf=p(:,:,1), MassWghtInterp=CS%MassWghtInterp) + 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.") @@ -360,11 +384,13 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ 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), P_surf=p(:,:,1), dP_tiny=dp_neglect, & - MassWghtInterp=CS%MassWghtInterp) + 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)) + 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 @@ -399,15 +425,24 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo enddo - ! Calculate and add the self-attraction and loading geopotential anomaly. + ! Calculate and add self-attraction and loading (SAL) geopotential height anomaly to interface height. if (CS%calculate_SAL) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j,1) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & - - max(-G%bathyT(i,j)-G%Z_ref, 0.0) - enddo ; enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + 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 & + - max(-G%bathyT(i,j)-G%Z_ref, 0.0) + enddo ; enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + 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 @@ -416,21 +451,21 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif endif - ! Calculate and add the tidal geopotential anomaly. + ! Calculate and add tidal geopotential height anomaly to interface height. if (CS%tides) then if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq)) then - call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + 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_tide_eq(i,j) + e_tide_sal(i,j)) + 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_tide, e_tide_eq, e_tide_sal, & + 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_tide(i,j) + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal_and_tide(i,j) enddo ; enddo endif endif @@ -557,6 +592,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ 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 @@ -595,15 +631,40 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo if (do_more_k) then - ! There are still points where a correction is needed, so use the top interface. - do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then - T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) - S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) - p_int_W(I,j) = p(i,j,1) ; p_int_E(I,j) = p(i+1,j,1) - intx_za_nonlin(I,j) = intx_za(I,j,1) - 0.5*(za(i,j,1) + za(i+1,j,1)) - dp_int_x(I,j) = p(i+1,j,1)-p(i,j,1) + 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 + 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 @@ -634,6 +695,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ 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 @@ -671,15 +733,40 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo if (do_more_k) then - ! There are still points where a correction is needed, so use the top interface. - do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then - T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) - S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) - p_int_S(i,J) = p(i,j,1) ; p_int_N(i,J) = p(i,j+1,1) - inty_za_nonlin(i,J) = inty_za(i,J,1) - 0.5*(za(i,j,1) + za(i,j+1,1)) - dp_int_y(i,J) = p(i,j+1,1) - p(i,j,1) - seek_y_cor(i,J) = .false. - endif ; enddo ; enddo + 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 @@ -806,15 +893,47 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif endif - ! 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) 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 @@ -825,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 @@ -835,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 @@ -846,14 +966,17 @@ 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_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [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_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + e_tidal_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources ! [Z ~> m]. - e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + 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, & ! The sea surface height anomaly, in depth units [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)) :: & @@ -914,6 +1037,10 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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 @@ -946,14 +1073,18 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! consistent with what is used in the density integral routines [R L2 T-2 ~> Pa] real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa]. real :: dz_geo_sfc ! The change in surface geopotential height between adjacent cells [L2 T-2 ~> m2 s-2] - real :: GxRho ! The gravitational acceleration times density [R L2 Z-1 T-2 ~> Pa m-1] + real :: 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] @@ -994,86 +1125,73 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm h_neglect = GV%H_subroundoff 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 - GxRho = 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%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) then MassWt_u(:,:,:) = 0.0 ; MassWt_v(:,:,:) = 0.0 endif - if (CS%tides_answer_date>20230630) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -G%bathyT(i,j) - enddo ; enddo + 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) = min(-G%bathyT(i,j) - G%Z_ref, 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 + ! 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) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) enddo - 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) = e(i,j,nz+1) - e_sal(i,j) + 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 - endif + enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) - ! 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) + 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_tide_eq(i,j) + e_tide_sal(i,j)) - enddo ; enddo - endif - else ! Old answers - ! 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) = min(-G%bathyT(i,j) - G%Z_ref, 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_SAL(SSH, 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 - e_sal(i,j) = 0.0 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) enddo ; enddo endif + endif - ! Calculate and add the tidal geopotential anomaly. - if (CS%tides) then - call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & - G, US, CS%tides_CSp) - !$OMP parallel do default(shared) + ! 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) = -(G%bathyT(i,j) + e_sal_tide(i,j)) + e(i,j,nz+1) = e(i,j,nz+1) - (e_tidal_eq(i,j) + e_tidal_sal(i,j)) enddo ; enddo - else + 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) = -(G%bathyT(i,j) + e_sal(i,j)) + e(i,j,nz+1) = e(i,j,nz+1) - e_sal_and_tide(i,j) enddo ; enddo endif endif @@ -1134,17 +1252,16 @@ 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,1) = GxRho*(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,1) = GxRho*(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 - I_g_rho = 1.0 / (CS%rho0*GV%g_Earth) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Z_0p(i,j) = e(i,j,1) + p_atm(i,j) * I_g_rho enddo ; enddo @@ -1170,23 +1287,26 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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, & + 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) + 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, & + 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) + 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(:,:,k), & + 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) + CS%MassWghtInterp, Z_0p=Z_0p, & + MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, h_nv=dz_nonvanished) endif if (GV%Z_to_H /= 1.0) then !$OMP parallel do default(shared) @@ -1196,7 +1316,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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)) + 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 @@ -1223,6 +1344,42 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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) - max(-G%bathyT(i,j) - G%Z_ref, 0.0) ! Remove topography above sea level + 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 @@ -1241,7 +1398,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm !$OMP parallel do default(shared) private(p_surf_EOS) do j=Jsq,Jeq+1 ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. - do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho*(e(i,j,1) - Z_0p(i,j)) ; enddo + 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 @@ -1269,8 +1426,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) pa5(1) = pa(i,j,1) ; pa5(5) = pa(i+1,j,1) ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. - p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) - p5(5) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) + 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 @@ -1304,8 +1461,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) pa5(1) = pa(i,j,1) ; pa5(5) = pa(i,j+1,1) ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. - p5(1) = -GxRho*(e(i,j,1) - Z_0p(i,j)) - p5(5) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + 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) @@ -1410,6 +1567,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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 @@ -1417,8 +1575,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! This is a typical case in the open ocean, so use the topmost interface. T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) - p_int_W(I,j) = -GxRho*(e(i,j,1) - Z_0p(i,j)) - p_int_E(I,j) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) + 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. @@ -1438,8 +1596,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) ! These pressures are only used for the equation of state, and are only a function of ! height, consistent with the expressions in the int_density_dz routines. - p_int_W(I,j) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) - p_int_E(I,j) = -GxRho*(e(i+1,j,K+1) - Z_0p(i,j)) + 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)) @@ -1452,16 +1610,43 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo if (do_more_k) then - ! There are still points where a correction is needed, so use the top interface for lack of a better idea? - do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then - T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) - S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) - p_int_W(I,j) = -GxRho*(e(i,j,1) - Z_0p(i,j)) - p_int_E(I,j) = -GxRho*(e(i+1,j,1) - Z_0p(i,j)) - intx_pa_nonlin(I,j) = intx_pa(I,j,1) - 0.5*(pa(i,j,1) + pa(i+1,j,1)) - dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) - seek_x_cor(I,j) = .false. - endif ; enddo ; enddo + 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 @@ -1492,6 +1677,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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 @@ -1499,8 +1685,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! This is a typical case in the open ocean, so use the topmost interface. T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) - p_int_S(i,J) = -GxRho*(e(i,j,1) - Z_0p(i,j)) - p_int_N(i,J) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) + 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. @@ -1520,8 +1706,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) ! These pressures are only used for the equation of state, and are only a function of ! height, consistent with the expressions in the int_density_dz routines. - p_int_S(i,J) = -GxRho*(e(i,j,K+1) - Z_0p(i,j)) - p_int_N(i,J) = -GxRho*(e(i,j+1,K+1) - Z_0p(i,j)) + 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. @@ -1533,16 +1719,43 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo if (do_more_k) then - ! There are still points where a correction is needed, so use the top interface for lack of a better idea? - do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then - T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) - S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) - p_int_S(i,J) = -GxRho*(e(i,j,1) - Z_0p(i,j)) - p_int_N(i,J) = -GxRho*(e(i,j+1,1) - Z_0p(i,j)) - inty_pa_nonlin(i,J) = inty_pa(i,J,1) - 0.5*(pa(i,j,1) + pa(i,j+1,1)) - dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) - seek_y_cor(i,J) = .false. - endif ; enddo ; enddo + 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 @@ -1599,6 +1812,34 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ((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 @@ -1634,42 +1875,35 @@ 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 ! 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. - 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) = 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) = eta(i,j) + (e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H - enddo ; enddo - endif - if (CS%calculate_SAL) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H - enddo ; enddo - endif - else ! Old answers - 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 + 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) = e(i,j,1)*GV%Z_to_H + (e_sal_tide(i,j))*GV%Z_to_H + 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) = (e(i,j,1) + e_sal(i,j))*GV%Z_to_H + 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) = eta(i,j) + e_sal(i,j)*GV%Z_to_H + enddo ; enddo + endif endif if (CS%use_stanley_pgf) then @@ -1709,12 +1943,6 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - ! 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_tide, 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) 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) @@ -1722,10 +1950,74 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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, SAL_CSp, 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 @@ -1733,6 +2025,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 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 @@ -1745,10 +2038,15 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 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 :: MassWghtInterpVanOnly ! If true, turn of mass weighting unless one side is vanished ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. 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 @@ -1762,26 +2060,41 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true., do_not_log=.true.) - call get_param(param_file, mdl, "RHO_PGF_REF", CS%Rho0, & + 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, "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=.true.) 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 in "//& - "Boussinesq mode. Values below 20230701 recover the old answers in which the SAL is "//& - "part of the tidal forcing calculation. The change is due to a reordered summation "//& - "and the difference is only at bit level.", default=20230630) - endif + call get_param(param_file, '', "DEFAULT_ANSWER_DATE", default_answer_date, default=99991231) + if (CS%tides) & + 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=20230630, do_not_log=(.not.CS%tides)) 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.) @@ -1796,6 +2109,9 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, "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). "//& @@ -1814,6 +2130,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, "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 @@ -1828,9 +2149,14 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 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 "//& @@ -1874,16 +2200,32 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, 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_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_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, & + 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_tide_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 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, & diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index af2beca1fb..dd34f722c3 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -26,13 +26,13 @@ module MOM_barotropic use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_self_attr_load, only : scalar_SAL_sensitivity use MOM_self_attr_load, only : SAL_CS -use MOM_streaming_filter, only : Filt_register, Filt_accum, Filter_CS -use MOM_tidal_forcing, only : tidal_frequency +use MOM_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 @@ -88,21 +88,25 @@ module MOM_barotropic !! 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]. - 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 + 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 @@ -111,20 +115,20 @@ module MOM_barotropic !< 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 total thickness at u grid points [H-1 ~> m-1 or m2 kg-1]. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u + 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 @@ -144,18 +148,21 @@ 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 recast as a thickness [H ~> m or kg m-2] 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 recast as a thickness [H ~> m or kg m-2] 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_) :: & + 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 [Z-1 T-1 ~> m-1 s-1]. 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. @@ -201,6 +208,8 @@ 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 :: 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 @@ -216,7 +225,7 @@ 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]. integer :: answer_date !< The vintage of the expressions in the barotropic solver. @@ -233,7 +242,7 @@ module MOM_barotropic real :: const_dyn_psurf !< The constant that scales the dynamic surface !! pressure [nondim]. Stable values are < ~1.0. !! The default is 0.9. - logical :: calculate_SAL !< If true, calculate self-attration and loading. + 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. @@ -250,10 +259,10 @@ module MOM_barotropic logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used !! in the barotropic Coriolis calculation is time !! invariant and linearized. - logical :: use_filter_m2 !< If true, apply streaming band-pass filter for detecting - !! instantaneous tidal signals. - logical :: use_filter_k1 !< If true, apply streaming band-pass filter for detecting - !! instantaneous tidal signals. + logical :: use_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. logical :: clip_velocity !< If true, limit any velocity components that are @@ -290,6 +299,8 @@ module MOM_barotropic !! 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. 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. @@ -297,10 +308,9 @@ module MOM_barotropic type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() !< Control structure for harmonic analysis - type(Filter_CS) :: Filt_CS_um2, & !< Control structures for the M2 streaming filter - Filt_CS_vm2, & !< Control structures for the M2 streaming filter - Filt_CS_uk1, & !< Control structures for the K1 streaming filter - Filt_CS_vk1 !< Control structures for the K1 streaming filter + 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. @@ -323,6 +333,7 @@ module MOM_barotropic !>@{ 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 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_ubt = -1, id_vbt = -1, id_eta_bt = -1, id_ubtav = -1, id_vbtav = -1 @@ -526,11 +537,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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] @@ -553,25 +572,17 @@ 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_prev, & ! 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]. + 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]. @@ -588,35 +599,44 @@ 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_prev, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]. + vbt_first, & ! The starting value of vbt in a series of barotropic steps [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]. + 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(:,:), pointer :: um2, uk1, vm2, vk1 - ! M2 and K1 velocities from the output of streaming filters [m s-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 ! 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]. @@ -636,59 +656,35 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! (See Hallberg, J Comp Phys 1997 for a discussion.) eta_src, & ! The source of eta per barotropic timestep [H ~> m or kg m-2]. 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 + 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 :: 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 :: dtbt_diag ! The nominal barotropic time step used in hifreq diagnostics [T ~> s]. - ! dtbt_diag = dt/(nstep+nfilter) - 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 [s] 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]. @@ -707,7 +703,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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, allocatable :: wt_vel(:) ! The raw or relative weights of each of the barotropic timesteps ! in determining the average velocities [nondim] @@ -727,20 +722,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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 [nondim] 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, & @@ -753,7 +745,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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 Idt = 1.0 / dt accel_underflow = CS%vel_underflow * Idt @@ -763,17 +754,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 if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. & (CS%Nonlin_cont_update_period > 0)) stencil = 2 - 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. & @@ -785,16 +771,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 + apply_OBC_flather .or. open_boundary_query(OBC, apply_open_OBC=.true.) endif num_cycles = 1 @@ -814,27 +796,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 - - !--- 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) @@ -859,15 +822,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) @@ -876,14 +837,6 @@ 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) @@ -982,7 +935,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 @@ -1052,7 +1004,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do k=1,nz ; do j=js,je ; do I=is-1,ie ! rem needs to be greater than visc_rem_u and 1-Instep/visc_rem_u. ! The 0.5 below is just for safety. - ! NOTE: subroundoff is a neglible value used to prevent division by zero. + ! 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. @@ -1128,28 +1080,21 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo enddo - if (apply_OBCs) 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)%direction == OBC_DIRECTION_N) then - gtot_S(i,j+1) = gtot_S(i,j) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - gtot_N(i,j) = gtot_N(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) - if (OBC%segment(n)%direction == OBC_DIRECTION_E) then - gtot_W(i+1,j) = gtot_W(i,j) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - gtot_E(i,j) = gtot_E(i+1,j) - endif - enddo - endif - enddo + 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 @@ -1183,18 +1128,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 if (nonblock_setup .and. apply_OBC_flather .and. .not.GV%Boussinesq) & call complete_group_pass(CS%pass_SpV_avg, CS%BT_domain) - if (CS%TIDAL_SAL_FLATHER) then - 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) - else - 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) - endif + 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 @@ -1275,58 +1217,25 @@ 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) + + uhbt(:,:) = 0.0 ; vhbt(:,:) = 0.0 + u_accel_bt(:,:) = 0.0 ; v_accel_bt(:,:) = 0.0 if (apply_OBCs) then ubt_first(:,:) = ubt(:,:) ; vbt_first(:,:) = vbt(:,:) @@ -1427,6 +1336,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. @@ -1456,43 +1415,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) @@ -1519,14 +1442,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. @@ -1598,41 +1521,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ; enddo ; enddo endif - ! Here is an example of how the filter equations are time stepped to determine the M2 and K1 velocities. - ! The filters are initialized and registered in subroutine barotropic_init. - if (CS%use_filter_m2) then - call Filt_accum(ubt, um2, CS%Time, US, CS%Filt_CS_um2) - call Filt_accum(vbt, vm2, CS%Time, US, CS%Filt_CS_vm2) - endif - if (CS%use_filter_k1) then - call Filt_accum(ubt, uk1, CS%Time, US, CS%Filt_CS_uk1) - call Filt_accum(vbt, vk1, CS%Time, US, CS%Filt_CS_vk1) - endif - - ! Zero out the arrays for various time-averaged quantities. - if (find_etaav) then + ! 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 @@ -1676,7 +1577,7 @@ 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. & @@ -1697,7 +1598,7 @@ 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) * & + 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))) + & @@ -1801,8 +1702,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 @@ -1813,7 +1712,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (nstep+nfilter==0 ) call MOM_error(FATAL, & "btstep: number of barotropic step (nstep+nfilter) is 0") - dtbt_diag = dt/(nstep+nfilter) ! 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 @@ -1859,1023 +1757,1740 @@ 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 - - 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 - + 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) + 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 - 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 + ! 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) - 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 (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 ((.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) + 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 (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) + 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 - !$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 (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 + ! 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 - ! Recall that just outside the do n loop, there is code like... - ! eta_PF_BT => eta_pred ; if (project_velocity) eta_PF_BT => eta + ! Accumulator is updated at the end of every baroclinic time step. + ! Harmonic analysis will not be performed of a field that is not registered. + if (associated(CS%HA_CSp) .and. find_etaav) then + call HA_accum_FtSSH('ubt', ubt, CS%Time, G, CS%HA_CSp) + call HA_accum_FtSSH('vbt', vbt, CS%Time, G, CS%HA_CSp) + endif - if (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 (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 (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 (apply_OBCs) then - if (MOD(n+G%first_direction,2)==1) then - ioff = 1; joff = 0 - else - ioff = 0; joff = 1 - 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%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 + ! 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 - 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 - endif - endif + 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 (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 - 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 (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 ((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 - !$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 + 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 (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 + ! 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 (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) - enddo ; enddo - !$OMP end do nowait + 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_first(I,j)) / dt + do k=1,nz ; accel_layer_u(I,j,k) = u_accel_bt(I,j) ; 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-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 + 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_first(i,J)) / dt + do k=1,nz ; accel_layer_v(i,J,k) = v_accel_bt(i,J) ; enddo 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 + enddo ; enddo ; endif + endif - 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) - enddo ; enddo - !$OMP end do nowait - endif + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) - 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 - endif + ! Calculate diagnostic quantities. + if (query_averaging_enabled(CS%diag)) then - !$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 - enddo ; enddo - !$OMP end do nowait + 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 (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)) + ! 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 (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) + 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 - 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 (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) + 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 + 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-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 + ! 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 + 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-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 + ! 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-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 (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 - ! 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 (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%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) - enddo ; enddo - !$OMP end do nowait - 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%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 - endif + 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) - !$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%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%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)) - enddo ; enddo - !$OMP end do nowait - 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) - 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 (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 + call post_data(CS%id_BTC_FA_u_rat0, tmp_u, 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,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 - 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, & - unscale=US%L_T_to_m_s*US%s_to_T) - call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & - unscale=US%L_T_to_m_s*US%s_to_T) - call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & - unscale=US%L_T_to_m_s*US%s_to_T) - call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, & - haloshift=iev-ie, scalar_pair=.true.) - call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & - unscale=US%L_T_to_m_s) - call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & - unscale=US%L_T_to_m_s) - call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & - unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) - if (integral_BT_cont) & - call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & - unscale=US%L_to_m**2*GV%H_to_m) - 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 - - !$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 (apply_OBCs) then - - !$OMP single - call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & - ubt_trans, vbt_trans, eta, SpV_col_avg, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, GV, US, CS, 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 - - 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 + 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 + call post_data(CS%id_BTC_FA_v_rat0, tmp_v, CS%diag) 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) + 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 + call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) endif endif + else + if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) + if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) + endif - if (CS%debug_bt) then - call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & - unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) - if (integral_BT_cont) & - call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & - haloshift=iev-ie, unscale=US%L_to_m**2*GV%H_to_m) - 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 - 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 + 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 (do_hifreq_output) then - time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt_diag) - 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_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 + 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 - 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, & - unscale=US%L_T_to_m_s) - call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, unscale=GV%H_to_MKS) - endif + deallocate(wt_vel, wt_eta, wt_trans, wt_accel, wt_accel2) - 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 (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 - 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 - endif - enddo ; enddo - endif +end subroutine btstep - 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) +!> 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 - ! Reset the time information in the diag type. - if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, CS%diag) + ! 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] + 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 [L2 H ~> m3] + 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] + 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 [L2 H ~> m3] + 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] + 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. + 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 :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - if (CS%answer_date < 20190101) 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 + 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 + + ! Figure out the fullest arrays that could be updated. + stencil = 1 + if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. (CS%Nonlin_cont_update_period > 0)) & + stencil = 2 + 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 - I_sum_wt_vel = 1.0 ; I_sum_wt_eta = 1.0 ; I_sum_wt_accel = 1.0 ; I_sum_wt_trans = 1.0 + trans_wt1 = CS%bebt ; trans_wt2 = (1.0-CS%bebt) 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))) + ! 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_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(US%T_to_s*dt) + 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 - 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)) + !$OMP do + do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 + eta_wtd(i,j) = 0.0 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 + !$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 - 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 + p_surf_dyn(:,:) = 0.0 + + ! 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 + + ! 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) + + ! 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 (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 + ! 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 - 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 + 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 (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 - 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 + v_first = (MOD(n+G%first_direction,2)==1) - ! Accumulator is updated at the end of every baroclinic time step. - ! Harmonic analysis will not be performed of a field that is not registered. - if (associated(CS%HA_CSp) .and. find_etaav) then - call HA_accum_FtSSH('ubt', ubt, CS%Time, G, CS%HA_CSp) - call HA_accum_FtSSH('vbt', vbt, CS%Time, G, CS%HA_CSp) - endif + ! 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 - 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) + ! 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 (CS%answer_date < 20190101) 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 + 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, vbt_prev, Cor_ref_v, Rayleigh_v, & + wt_accel(n), G, US, CS) - 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 + ! 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, ubt_prev, Cor_ref_u, Rayleigh_u, & + wt_accel(n), G, US, CS) - 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 + 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, ubt_prev, 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, vbt_prev, Cor_ref_v, Rayleigh_v, & + wt_accel(n), G, US, CS, Cor_bracket_bug=CS%use_old_coriolis_bracket_bug) + endif + + ! Determine the transports based on the updated velocities when no OBCs are applied + if (integral_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) + 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) + ! 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) + ! 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 + + ! 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, & + unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & + unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & + unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, & + haloshift=iev-ie, scalar_pair=.true.) + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & + unscale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & + unscale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & + unscale=US%L_to_m**2*GV%H_to_m) + endif + ! 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 (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 (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 - ! Now calculate each layer's accelerations. - !$OMP parallel do default(shared) - do k=1,nz + ! Contribute to the running sums of the transports and velocities. + !$OMP do 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 + 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 - 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 + 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 - 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%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 - endif - enddo ; enddo ; endif - endif - - if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) - - ! Calculate diagnostic quantities. - if (query_averaging_enabled(CS%diag)) then + !$OMP end do nowait - 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%debug_bt) then + call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & + haloshift=iev-ie, unscale=US%L_to_m**2*GV%H_to_m) 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) - 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 + !$OMP do + do j=jsv,jev ; do i=isv,iev + eta(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))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) 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 ",I4)') n + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & + unscale=US%L_T_to_m_s) + call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, unscale=GV%H_to_MKS) endif - if (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 (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) 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 (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 + + 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*US%T_to_s*dtbt_diag) + 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_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 + +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 - endif - else - if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) - if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) + 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 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]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + vhbt_int !< The running time integral of vhbt over the time steps [H L2 ~> m3]. + 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 - 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 + !$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, vbt_prev, 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(inout) :: & + vbt_prev !< The previous velocity, stored for time-filtered transports and OBCs [L T-1 ~> m s-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(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_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 + + !$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_prev(i,J) = 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 + 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, ubt_prev, 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(inout) :: & + ubt_prev !< The previous velocity, stored for time-filtered transports and OBCs [L T-1 ~> m s-1] + 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 + real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. + 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_prev(I,j) = 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 + 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 + + 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 -!> 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) +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 H-1 T-2 ~> m s-2 or m4 kg-1 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)) :: & @@ -2978,29 +3593,201 @@ 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 + 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 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_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]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< the zonal barotropic transport + !! [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 (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 (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 set_dtbt +end subroutine apply_u_velocity_OBCs -!> The following 4 subroutines apply the open boundary conditions. -!! This subroutine applies the open boundary conditions on barotropic +!> This subroutine applies the open boundary conditions on barotropic meridional !! velocities and mass transports, as developed by Mehmet Ilicak. -subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, SpV_avg, & - ubt_old, vbt_old, BT_OBC, G, MS, GV, US, CS, 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. +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(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity [L T-1 ~> m s-1]. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< the zonal barotropic transport - !! [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),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 @@ -3010,8 +3797,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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]. 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 @@ -3031,203 +3816,284 @@ 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 + 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(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 - !! 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 :: vel_trans ! The combination of the previous and current velocity - ! that does the mass transport [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 :: 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 :: 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, je - is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + integer :: i, j, is, ie, Js_v, Je_v - if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return + if (.not.BT_OBC%v_OBCs_on_PE) return Idtbt = 1.0 / dtbt - 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 - if (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))) - vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - else ! This point is now dry. - ubt(I,j) = 0.0 - vel_trans = 0.0 - endif - 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 - if (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 + ! 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. - 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)) - vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - else ! This point is now dry. - ubt(I,j) = 0.0 - vel_trans = 0.0 - endif - elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then - ubt(I,j) = ubt(I+1,j) - vel_trans = ubt(I,j) - endif + + ! 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 (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 (.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 + 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 - ubt_trans(I,j) = vel_trans - endif ; enddo ; enddo - 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 - 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 - if (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 + endif ; enddo ; enddo - 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))) - vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - else ! This point is now dry - vbt(i,J) = 0.0 - vel_trans = 0.0 - endif - 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 - if (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 + ! 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 (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)) - vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - else ! This point is now dry - vbt(i,J) = 0.0 - vel_trans = 0.0 - endif - elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then - vbt(i,J) = vbt(i,J+1) - vel_trans = vbt(i,J) - 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 - 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 + ! 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 - vbt_trans(i,J) = vel_trans - endif ; enddo ; enddo + 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, 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] + real :: OBC_sign ! A sign encoding the direction of the OBC being used at a point [nondim] + real :: OBC_type ! A real copy of the integer encoding the type of OBC being used at a point [nondim] + integer :: i, j, isdw, iedw, jsdw, jedw + integer :: l_seg + + isdw = CS%isdw ; iedw = CS%iedw ; jsdw = CS%jsdw ; jedw = CS%jedw + + u_OBC(:,:) = 0.0 + v_OBC(:,:) = 0.0 + + do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + l_seg = OBC%segnum_u(I,j) + + OBC_sign = 0.0 ; OBC_type = 0.0 + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) OBC_sign = 1.0 + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) OBC_sign = -1.0 + 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 + endif + u_OBC(I,j) = OBC_sign * OBC_type + enddo ; enddo + + do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + l_seg = OBC%segnum_v(i,J) + OBC_sign = 0.0 ; OBC_type = 0.0 + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) OBC_sign = 1.0 + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) OBC_sign = -1.0 + 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 + endif + v_OBC(i,J) = OBC_sign * OBC_type + enddo ; enddo + + 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 + + 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. + 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 + if (BT_OBC%u_OBC_type(I,j) > 0) then ! This point has OBC_DIRECTION_E. + 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 + enddo ; enddo + + 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. + 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 + if (BT_OBC%v_OBC_type(i,J) > 0) then ! This point has OBC_DIRECTION_N. + 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 + 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)) + + ! 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, 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) @@ -3244,7 +4110,7 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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(in) :: CS !< Barotropic control structure + 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. @@ -3263,11 +4129,10 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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, optional, intent(in) :: dgeo_de !< The constant of proportionality between + 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]. - real :: dgeo_de_in !< The constant of proportionality between geopotential and sea surface height [nondim]. integer :: i, j, k, is, ie, js, je, n, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw @@ -3280,35 +4145,7 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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 - - dgeo_de_in = 1.0 - if (PRESENT(dgeo_de)) dgeo_de_in = dgeo_de - - if (.not. BT_OBC%is_alloced) then - 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%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%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%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%SSH_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%SSH_outer_u, BT_OBC%SSH_outer_v, BT_Domain,To_All+Scalar_Pair) - call create_group_pass(BT_OBC%pass_h, BT_OBC%dZ_u, BT_OBC%dZ_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) @@ -3322,9 +4159,8 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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 @@ -3332,23 +4168,23 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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%dZ_u(I,j) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%dZ_u(I,j) = CS%bathyT(i+1,j) + GV%H_to_Z*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%dZ_u(I,j) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i+1,j) * SpV_avg(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(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_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) @@ -3362,7 +4198,7 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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) @@ -3376,9 +4212,8 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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 @@ -3386,21 +4221,20 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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%dZ_v(i,J) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%dZ_v(i,J) = CS%bathyT(i,j+1) + GV%H_to_Z*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%dZ_v(i,J) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j+1) * SpV_avg(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_in * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) + 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(dgeo_de * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) endif endif ; enddo ; enddo if (OBC%Flather_v_BCs_exist_globally) then @@ -3417,10 +4251,8 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS 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 @@ -3430,27 +4262,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%dZ_u) - deallocate(BT_OBC%uhbt) - deallocate(BT_OBC%ubt_outer) - deallocate(BT_OBC%SSH_outer_u) - - deallocate(BT_OBC%Cg_v) - deallocate(BT_OBC%dZ_v) - deallocate(BT_OBC%vhbt) - deallocate(BT_OBC%vbt_outer) - deallocate(BT_OBC%SSH_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. @@ -3480,6 +4310,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]. @@ -3497,15 +4329,11 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) 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 :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] - 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]. - 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 + integer :: is_v, ie_v, Js_v, Je_v -! 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.") @@ -3525,204 +4353,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,Z_to_H) + !$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 - 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)) - 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,Z_to_H) + !$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 - 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)) - 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, & @@ -3732,7 +4523,7 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., unscale=GV%H_to_MKS, & scalar_pair=.true.) - call hchksum(h, "btcalc h",G%HI, haloshift=1, unscale=GV%H_to_MKS) + call hchksum(h, "btcalc h", G%HI, haloshift=1, unscale=GV%H_to_MKS) endif end subroutine btcalc @@ -4040,34 +4831,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) @@ -4433,8 +5222,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, SAL_CSp, HA_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 @@ -4444,9 +5233,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 @@ -4458,7 +5244,8 @@ 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(SAL_CS), target, optional :: SAL_CSp !< A pointer to the control structure of the + 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 @@ -4474,7 +5261,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 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 [nondim]. character(len=200) :: inputdir ! The directory in which to find input files. @@ -4588,7 +5375,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "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 get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & "If true, use nonlinear transports in the barotropic "//& @@ -4656,6 +5443,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "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=.true., do_not_log=.true.) 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 @@ -4722,9 +5513,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "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. "//& @@ -4868,22 +5663,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 @@ -4894,9 +5689,13 @@ 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(:,:) = 1.0 + ALLOC_(CS%OBCmask_v(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%OBCmask_v(:,:) = 1.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 @@ -4907,17 +5706,58 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 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) enddo ; enddo + + 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) 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 @@ -4949,8 +5789,8 @@ 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) @@ -4959,15 +5799,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0) then call MOM_read_data(wave_drag_file, wave_drag_u, CS%lin_drag_u, G%Domain, & - position=EAST_FACE, scale=GV%m_to_H*US%T_to_s) - call pass_var(CS%lin_drag_u, G%Domain) - CS%lin_drag_u(:,:) = wave_drag_scale * CS%lin_drag_u(:,:) - + 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=GV%m_to_H*US%T_to_s) - call pass_var(CS%lin_drag_v, G%Domain) - CS%lin_drag_v(:,:) = wave_drag_scale * CS%lin_drag_v(:,:) - + 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) @@ -4984,11 +5819,26 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 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 + dtbt_restart = CS%dtbt endif ! Estimate the maximum stable barotropic time step. @@ -4999,14 +5849,17 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 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. + + 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) @@ -5024,6 +5877,12 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, '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) + 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, & @@ -5077,6 +5936,7 @@ 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_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & @@ -5161,7 +6021,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(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 @@ -5197,7 +6057,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) @@ -5245,10 +6105,25 @@ subroutine barotropic_end(CS) DEALLOC_(CS%eta_cor_bound) endif 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 @@ -5268,9 +6143,8 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) ! 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 - real :: am2, ak1 !< Bandwidth parameters of the M2 and K1 streaming filters [nondim] - real :: om2, ok1 !< Target frequencies of the M2 and K1 streaming filters [T-1 ~> s-1] isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB @@ -5283,38 +6157,11 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) "sum(u dh_dt) while also correcting for truncation errors.", & default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "STREAMING_FILTER_M2", CS%use_filter_m2, & - "If true, turn on streaming band-pass filter for detecting "//& - "instantaneous tidal signals.", default=.false.) - call get_param(param_file, mdl, "STREAMING_FILTER_K1", CS%use_filter_k1, & - "If true, turn on streaming band-pass filter for detecting "//& - "instantaneous tidal signals.", default=.false.) - call get_param(param_file, mdl, "FILTER_ALPHA_M2", am2, & - "Bandwidth parameter of the streaming filter targeting the M2 frequency. "//& - "Must be positive. To turn off filtering, set FILTER_ALPHA_M2 <= 0.0.", & - default=0.0, units="nondim", do_not_log=.not.CS%use_filter_m2) - call get_param(param_file, mdl, "FILTER_ALPHA_K1", ak1, & - "Bandwidth parameter of the streaming filter targeting the K1 frequency. "//& - "Must be positive. To turn off filtering, set FILTER_ALPHA_K1 <= 0.0.", & - default=0.0, units="nondim", do_not_log=.not.CS%use_filter_k1) - call get_param(param_file, mdl, "TIDE_M2_FREQ", om2, & - "Frequency of the M2 tidal constituent. "//& - "This is only used if TIDES and TIDE_M2"// & - " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and M2"// & - " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=tidal_frequency("M2"), & - scale=US%T_to_s, do_not_log=.true.) - call get_param(param_file, mdl, "TIDE_K1_FREQ", ok1, & - "Frequency of the K1 tidal constituent. "//& - "This is only used if TIDES and TIDE_K1"// & - " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and K1"// & - " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=tidal_frequency("K1"), & - scale=US%T_to_s, do_not_log=.true.) - ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 if (CS%gradual_BT_ICs) then - 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", & @@ -5338,22 +6185,17 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & longname="Barotropic timestep", units="seconds", conversion=US%T_to_s) - ! Initialize and register streaming filters - if (CS%use_filter_m2) then - if (am2 > 0.0 .and. om2 > 0.0) then - call Filt_register(am2, om2, 'u', HI, CS%Filt_CS_um2) - call Filt_register(am2, om2, 'v', HI, CS%Filt_CS_vm2) - else - CS%use_filter_m2 = .false. - endif - endif - if (CS%use_filter_k1) then - if (ak1 > 0.0 .and. ok1 > 0.0) then - call Filt_register(ak1, ok1, 'u', HI, CS%Filt_CS_uk1) - call Filt_register(ak1, ok1, 'v', HI, CS%Filt_CS_vk1) - else - CS%use_filter_k1 = .false. - endif + ! 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 @@ -5373,7 +6215,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 75f69dc779..31863d10c2 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -145,9 +145,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) & diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 6b89323475..13f71a3f16 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -61,9 +61,9 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy 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 - real, optional, intent(in) :: vel_scale !< The scaling factor to convert velocities to [m s-1] + 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 @@ -275,13 +275,13 @@ 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] or mass [kg] (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 [degC m3] or [degC kg] (unscaled to permit reproducing sum) - tmp_S ! The column-integrated salinity [ppt m3] or [ppt kg] (unscaled to permit reproducing sum) - real :: Vol, dV ! The total ocean volume or mass and its change [m3] or [kg] (unscaled to permit reproducing sum). - real :: Area ! The total ocean surface area [m2] (unscaled to permit reproducing sum). + 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] @@ -293,7 +293,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe ! 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] or mass [kg] + 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 @@ -310,32 +310,31 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe ! 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_MKS*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, T_scale*Temp(i,j,k) ) ; T%maximum = max( T%maximum, T_scale*Temp(i,j,k) ) - T%average = T%average + dV*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) ) - S%average = S%average + dV*S_scale*Salt(i,j,k) - tmp_T(i,j) = tmp_T(i,j) + dV*T_scale*Temp(i,j,k) - tmp_S(i,j) = tmp_S(i,j) + dV*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 @@ -344,7 +343,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 @@ -357,7 +356,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 diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 90994dd073..2638718594 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -40,7 +40,8 @@ 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, SSH, dz_neglect, MassWghtInterp, 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 [C ~> degC] @@ -82,12 +83,18 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, real, optional, intent(in) :: dz_neglect !< A minuscule 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 + 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, SSH, dz_neglect, MassWghtInterp, 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, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) @@ -100,7 +107,8 @@ end subroutine int_density_dz !! 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, SSH, & - dz_neglect, MassWghtInterp, use_inaccurate_form, Z_0p) + 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 [C ~> degC] @@ -142,6 +150,9 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real, optional, intent(in) :: dz_neglect !< A minuscule 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 + 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, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -159,7 +170,6 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & 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 :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] real :: dz ! The layer thickness [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] @@ -175,6 +185,9 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] 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, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state @@ -190,7 +203,6 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & js = HI%jsc ; je = HI%jec GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 if (present(Z_0p)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 z0pres(i,j) = Z_0p(i,j) @@ -214,6 +226,14 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & 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) @@ -258,6 +278,10 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & 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 @@ -326,6 +350,10 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & 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 @@ -390,7 +418,7 @@ end subroutine int_density_dz_generic_pcm subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, dpa, & intz_dpa, intx_dpa, inty_dpa, MassWghtInterp, & - use_inaccurate_form, Z_0p) + 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 @@ -434,6 +462,9 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & !! 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. + 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] @@ -478,12 +509,13 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! 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 product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-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 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] @@ -491,6 +523,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & 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] + 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 @@ -502,7 +535,6 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 if (present(Z_0p)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 z0pres(i,j) = Z_0p(i,j) @@ -515,6 +547,14 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & 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)) use_rho_ref = .not. use_inaccurate_form @@ -620,6 +660,10 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & !endif ! Set it to be max of the bottom and top hWghts: 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 @@ -727,6 +771,11 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & !endif ! Set it to be max of the bottom and top hWghts: 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 @@ -824,7 +873,8 @@ end subroutine int_density_dz_generic_plm !! are parabolic profiles subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, & - dpa, intz_dpa, intx_dpa, inty_dpa, MassWghtInterp, Z_0p) + 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 @@ -866,6 +916,10 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & !! divided by the y grid spacing [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) :: 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] @@ -908,12 +962,13 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! 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 :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] real :: dz ! Layer thicknesses at tracer points [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] real :: massWeightToggle ! A non-dimensional toggle factor 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] @@ -925,6 +980,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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] + 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 @@ -935,7 +991,6 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 if (present(Z_0p)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 z0pres(i,j) = Z_0p(i,j) @@ -948,6 +1003,14 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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 s6 = 0. @@ -1037,6 +1100,10 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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 @@ -1145,6 +1212,10 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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 @@ -1246,7 +1317,8 @@ end subroutine int_density_dz_generic_ppm !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, P_surf, dP_tiny, MassWghtInterp) + 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 [C ~> degC] @@ -1286,11 +1358,16 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & !! 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, P_surf, dP_tiny, MassWghtInterp) + 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, & @@ -1306,7 +1383,8 @@ 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, P_surf, dP_neglect, MassWghtInterp) + 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 [C ~> degC] @@ -1347,6 +1425,9 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d !! 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 @@ -1360,7 +1441,7 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d 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-3] + ! 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] @@ -1381,6 +1462,9 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d 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] 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 @@ -1405,6 +1489,15 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d 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 + ! Set the loop ranges for equation of state calculations at various points. EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(ieh-ish+1) @@ -1450,6 +1543,11 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d 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 @@ -1510,6 +1608,10 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d 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 @@ -1565,7 +1667,8 @@ 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, P_surf, MassWghtInterp) + 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 [C ~> degC] @@ -1609,6 +1712,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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 @@ -1621,7 +1727,7 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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-3] + ! 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] @@ -1647,6 +1753,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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 @@ -1662,6 +1771,14 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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) @@ -1711,6 +1828,10 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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 @@ -1777,6 +1898,10 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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 @@ -1835,7 +1960,7 @@ 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) + 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] @@ -1852,6 +1977,9 @@ subroutine diagnose_mass_weight_Z(z_t, z_b, bathyT, SSH, dz_neglect, MassWghtInt 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] @@ -1859,6 +1987,8 @@ subroutine diagnose_mass_weight_Z(z_t, z_b, bathyT, SSH, dz_neglect, MassWghtInt 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 @@ -1866,6 +1996,14 @@ subroutine diagnose_mass_weight_Z(z_t, z_b, bathyT, SSH, dz_neglect, MassWghtInt 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 @@ -1877,6 +2015,10 @@ subroutine diagnose_mass_weight_Z(z_t, z_b, bathyT, SSH, dz_neglect, MassWghtInt 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 @@ -1898,6 +2040,10 @@ subroutine diagnose_mass_weight_Z(z_t, z_b, bathyT, SSH, dz_neglect, MassWghtInt 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 @@ -1914,7 +2060,7 @@ end subroutine diagnose_mass_weight_Z !> Diagnose the fractional mass weighting in a layer that might be used with a non-Boussinesq calculation. subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWghtInterp, HI, & - MassWt_u, MassWt_v) + 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] @@ -1932,6 +2078,9 @@ subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWght 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] ! Local variables real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] @@ -1940,6 +2089,10 @@ subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWght 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 @@ -1948,6 +2101,14 @@ subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWght 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 @@ -1962,6 +2123,10 @@ subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWght 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 @@ -1986,6 +2151,10 @@ subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWght 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 @@ -2001,7 +2170,7 @@ 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) + 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] @@ -2020,6 +2189,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t 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, 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] @@ -2032,7 +2202,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t 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 @@ -2063,7 +2233,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t 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 Returns change in anomalous pressure change from top to non-dimensional !! 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) +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] @@ -2131,6 +2301,7 @@ 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 + 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] @@ -2150,7 +2321,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 b223bed161..40d1888595 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -160,8 +160,7 @@ module MOM_dynamics_split_RK2 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 @@ -501,7 +500,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f 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) @@ -658,7 +657,15 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f 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. ! The CS%ADp argument here stores the weights for certain integrated diagnostics. @@ -826,7 +833,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! 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 @@ -1435,7 +1442,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p "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.) @@ -1536,14 +1544,14 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%calculate_SAL) call SAL_init(G, GV, US, param_file, CS%SAL_CSp) if (CS%use_tides) then call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp) HA_CSp => CS%HA_CSp else HA_CSp => NULL() endif - call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & + 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, & @@ -1576,8 +1584,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p ! 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, & - CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp, HA_CSp) + 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) if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 87e46795b5..7896000a28 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -157,8 +157,7 @@ module MOM_dynamics_split_RK2b 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 :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: use_tides !< If true, tidal forcing is enabled. logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D @@ -505,7 +504,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc 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) @@ -672,7 +671,15 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc 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) 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. ! The CS%ADp argument here stores the weights for certain integrated diagnostics. @@ -820,7 +827,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! 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 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) @@ -1335,7 +1342,8 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, "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.) @@ -1419,14 +1427,14 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%calculate_SAL) call SAL_init(G, GV, US, param_file, CS%SAL_CSp) if (CS%use_tides) then call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp) HA_CSp => CS%HA_CSp else HA_CSp => NULL() endif - call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & + 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, & @@ -1461,9 +1469,9 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, ! 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%SAL_CSp, HA_CSp) + CS%OBC, CS%SAL_CSp, HA_CSp) flux_units = get_flux_units(GV) thickness_units = get_thickness_units(GV) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index fa84f6dac9..bce0c4026a 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -319,7 +319,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 @@ -386,7 +386,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 @@ -479,7 +479,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 @@ -710,9 +710,9 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%calculate_SAL) call SAL_init(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, & + 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, & diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 00c77bcf53..dd3df7bb3a 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -313,7 +313,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) @@ -673,9 +673,9 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%calculate_SAL) call SAL_init(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, & + 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, & diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 862f5c5858..f91d958fe8 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -85,12 +85,14 @@ module MOM_forcing_type ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. 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] + !! 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 [R L Z T-2 ~> Pa] + !! 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(:,:) :: & @@ -179,7 +181,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 @@ -201,9 +204,10 @@ module MOM_forcing_type !! 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] @@ -320,7 +324,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 @@ -1177,9 +1181,9 @@ subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_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 times a ratio of scaling - ! factors [Z L-1 R-1 ~> m3 kg-1] or in some semi-Boussinesq cases - ! the rescaled reference density [H2 Z-1 L-1 R-1 ~> m3 kg-1 or kg m-3] + real :: I_rho ! The inverse of the reference density [R-1 ~> m3 kg-1] + ! or in some semi-Boussinesq cases the reference + ! density [H2 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, k, is, ie, js, je, hs @@ -1209,16 +1213,16 @@ subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_units) "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(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + 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(US%L_to_Z*fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + 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 = US%L_to_Z * GV%Z_to_H * GV%RZ_to_H - if (Z_T_units) I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 + 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 @@ -1243,9 +1247,8 @@ subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_unit !! of [H T-1 ~> m s-1 or kg m-2 s-1] ! Local variables - real :: I_rho ! The inverse of the reference density times a ratio of scaling - ! factors [Z L-1 R-1 ~> m3 kg-1] or in some semi-Boussinesq cases - ! the rescaled reference density [H2 Z-1 L-1 R-1 ~> m3 kg-1 or kg m-3] + 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 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, k, is, ie, js, je, hs @@ -1275,16 +1278,16 @@ subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_unit "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(US%L_to_Z*forces%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + 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(US%L_to_Z*forces%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + 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 = US%L_to_Z * GV%Z_to_H * GV%RZ_to_H - if (Z_T_units) I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 + 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 @@ -1311,7 +1314,7 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%ustar)) & 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) + 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, unscale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%sw)) & @@ -1363,8 +1366,9 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) call hchksum(fluxes%ice_fraction, mesg//" fluxes%ice_fraction", G%HI, haloshift=hshift) if (associated(fluxes%salt_flux)) & call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) - if (associated(fluxes%TKE_tidal)) & - call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, unscale=US%RZ3_T3_to_W_m2) + 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, unscale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & @@ -1430,7 +1434,7 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) if (associated(forces%ustar)) & 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) + 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., & @@ -1499,7 +1503,7 @@ 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') @@ -1552,22 +1556,22 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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%RLZ_T2_to_Pa, & + '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%RLZ_T2_to_Pa, & + '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) + '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)', & @@ -1613,7 +1617,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, & @@ -1626,8 +1630,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') @@ -1641,7 +1645,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',& @@ -1651,33 +1655,33 @@ 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') @@ -1714,55 +1718,64 @@ 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') @@ -1776,10 +1789,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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 @@ -1806,8 +1821,8 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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', conversion=US%RZ_T_to_kg_m2s, & + 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_long_name='Snowfall Flux where Ice Free Ocean over Sea Area Averaged') @@ -1845,7 +1860,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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', & @@ -1903,7 +1918,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', & @@ -1916,7 +1931,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, & @@ -1935,8 +1951,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') @@ -1975,7 +1991,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= & @@ -1984,7 +2000,7 @@ 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= & @@ -2005,7 +2021,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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= & @@ -2014,32 +2030,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') + 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') + 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',& @@ -2048,17 +2064,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= & @@ -2067,7 +2083,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= & @@ -2076,12 +2092,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= & @@ -2090,7 +2106,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= & @@ -2099,12 +2115,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= & @@ -2113,7 +2129,7 @@ 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= & @@ -2129,7 +2145,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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= & @@ -2138,12 +2154,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 @@ -2154,7 +2170,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hfds', & @@ -2209,7 +2225,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') @@ -2228,17 +2244,17 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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, & @@ -2258,18 +2274,20 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, !=============================================================== ! 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 @@ -2578,7 +2596,7 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) endif endif if (associated(fluxes%tau_mag_gustless)) then - fluxes%tau_mag_gustless(i,j) = sqrt(taux2 + tauy2) + fluxes%tau_mag_gustless(i,j) = US%L_to_Z*sqrt(taux2 + tauy2) endif enddo ; enddo endif @@ -2748,11 +2766,13 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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 [R Z T-1 ~> kg m-2 s-1] or [Q R Z T-1 ~> 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 @@ -2776,7 +2796,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) @@ -2800,12 +2819,12 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) if (handles%id_total_prcme > 0) then - total_transport = global_area_integral(res, G, unscale=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, tmp_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 @@ -2827,8 +2846,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, unscale=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 @@ -2838,7 +2857,6 @@ 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) @@ -2861,8 +2879,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, unscale=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 @@ -2872,12 +2890,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, unscale=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, tmp_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 @@ -2886,88 +2904,88 @@ 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, unscale=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, tmp_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, unscale=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, tmp_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, unscale=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, tmp_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, unscale=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, tmp_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, unscale=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_transport = global_area_integral(fluxes%lrunoff_glc, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_lrunoff_glc, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%lrunoff_glc, G, 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, unscale=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_transport = global_area_integral(fluxes%frunoff_glc, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_frunoff_glc, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%frunoff_glc, G, 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, unscale=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 @@ -2976,78 +2994,78 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) & call post_data(handles%id_heat_content_lrunoff, fluxes%heat_content_lrunoff, diag) if ((handles%id_total_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) then - total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, unscale=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_transport = global_area_integral(fluxes%heat_content_lrunoff_glc, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_lrunoff_glc, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%heat_content_lrunoff_glc, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_lrunoff_glc, total_mass_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, unscale=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_transport = global_area_integral(fluxes%heat_content_frunoff_glc, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_frunoff_glc, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%heat_content_frunoff_glc, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_frunoff_glc, total_mass_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, unscale=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, unscale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_fprec, 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, unscale=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, unscale=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_transport = global_area_integral(fluxes%heat_content_evap, G, unscale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_evap, total_transport, diag) + 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, unscale=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, unscale=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. & @@ -3062,12 +3080,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, unscale=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, tmp_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 @@ -3109,12 +3127,12 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) if (handles%id_total_net_heat_surface > 0) then - total_transport = global_area_integral(res, G, unscale=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, tmp_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 @@ -3137,8 +3155,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) if (handles%id_total_heat_content_surfwater > 0) then - total_transport = global_area_integral(res, G, unscale=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 @@ -3178,8 +3196,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, unscale=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. & @@ -3187,8 +3205,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, tmp_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 @@ -3203,68 +3221,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, unscale=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, tmp_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, unscale=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, tmp_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, unscale=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, tmp_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, unscale=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, unscale=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, unscale=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_transport = global_area_integral(fluxes%latent_frunoff_glc_diag, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_lat_frunoff_glc, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%latent_frunoff_glc_diag, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_frunoff_glc, total_mass_flux, diag) endif if ((handles%id_sens > 0) .and. associated(fluxes%sens)) then @@ -3276,17 +3294,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, unscale=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, unscale=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, tmp_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 @@ -3294,8 +3312,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, unscale=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 @@ -3304,22 +3322,22 @@ 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, unscale=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, unscale=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, unscale=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)) & @@ -3351,8 +3369,8 @@ 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) @@ -3565,8 +3583,8 @@ subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes, turns) 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)) @@ -3803,7 +3821,7 @@ subroutine deallocate_forcing_type(fluxes) 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) @@ -3963,8 +3981,8 @@ 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) @@ -4063,14 +4081,14 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) !! 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 L Z T-2 ~> Pa] - real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] + 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 = US%L_to_Z / Rho0 + Irho0 = 1.0 / Rho0 tau2ustar = .false. if (present(UpdateUstar)) tau2ustar = UpdateUstar @@ -4088,7 +4106,7 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean enddo ; enddo if (tau2ustar) then - tau_mag = sqrt((tx_mean**2) + (ty_mean**2)) + 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 @@ -4099,13 +4117,13 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) 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) + 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) + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa*US%Z_to_L) endif if (do_shelf) then @@ -4148,9 +4166,9 @@ subroutine homogenize_forcing(fluxes, G, GV, US) 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) + 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) + 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) @@ -4240,8 +4258,8 @@ subroutine homogenize_forcing(fluxes, G, GV, US) 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%TKE_tidal)) & - call homogenize_field_t(fluxes%TKE_tidal, G, tmp_scale=US%RZ3_T3_to_W_m2) + 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) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 6fb8426395..e0d456f9a3 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -177,9 +177,9 @@ module MOM_grid 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 @@ -190,11 +190,14 @@ module MOM_grid ! These parameters are run-time parameters that are used during some ! initialization routines (but not all) + 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 !< The radius of the planet [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 diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index c594aed206..5aa822a000 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -339,7 +339,7 @@ subroutine find_col_avg_SpV(h, SpV_avg, tv, G, GV, US, halo_size) 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-3] + 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] diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f89c8953ab..19d3361514 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -19,7 +19,7 @@ module MOM_open_boundary 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, SINGLE_FILE +use MOM_io, only : slasher, field_size, file_exists, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_regridding, only : regridding_CS @@ -320,7 +320,8 @@ module MOM_open_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]. @@ -392,12 +393,13 @@ module MOM_open_boundary 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. 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..., perhaps in [m3 s-1]? + 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. @@ -560,6 +562,10 @@ subroutine open_boundary_config(G, US, param_file, OBC) "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.OBC%debug, debuggingParam=.true.) + 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=.true.) reentrant_x = .false. call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) reentrant_y = .false. @@ -705,10 +711,13 @@ subroutine open_boundary_config(G, US, param_file, OBC) "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) + call get_param(param_file, mdl, "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=.true.) + "We recommend setting this option to false.", default=OBC%om4_remap_via_sub_cells) endif ! OBC%number_of_segments > 0 @@ -904,6 +913,8 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) fieldname = trim(fieldname)//trim(suffix) call field_size(filename,fieldname,siz,no_domain=.true.) ! if (siz(4) == 1) segment%values_needed = .false. + if (.not.file_exists(filename)) & + call MOM_error(FATAL," Unable to open OBC file " // trim(filename)) if (segment%on_pe) then if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then write(mesg,'("Brushcutter mode sizes ", I6, I6)') siz(1), siz(2) @@ -1119,7 +1130,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) end subroutine initialize_segment_data !> Return an appropriate dimensional scaling factor for input data based on an OBC segment data -!! name, or 1 for tracers or other fields that do not match one of the specified names. +!! 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, GV, US, Tr_Reg) @@ -1165,26 +1176,30 @@ 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) + old_name="OBC_TIDE_NODAL_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides) if (.not. OBC%add_eq_phase) then ! If equilibrium phase argument is not added, the input phases @@ -1196,7 +1211,7 @@ subroutine initialize_obc_tides(OBC, US, param_file) 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)) + OBC%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0) ! 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) @@ -1206,7 +1221,7 @@ subroutine initialize_obc_tides(OBC, US, param_file) if (OBC%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)) + 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, @@ -1231,7 +1246,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 @@ -1476,7 +1491,7 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) "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) @@ -1617,7 +1632,7 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) "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) @@ -5053,7 +5068,9 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) 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. real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside, @@ -5063,6 +5080,12 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) 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) @@ -5153,7 +5176,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) &"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.") @@ -5455,8 +5478,8 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) if (G%mask2dT(I+ishift,j) == 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 + 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 @@ -5466,7 +5489,7 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) 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 nodim. Adding them together has no meaning. + ! 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 @@ -5499,8 +5522,8 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) 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 + 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 diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90 index f8ae58d9e1..d9ca19985f 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -135,10 +135,11 @@ 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. @@ -296,10 +297,11 @@ 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. diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 17e175ddeb..cc5059bd48 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -181,10 +181,16 @@ module MOM_variables !! 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]. @@ -192,6 +198,24 @@ 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] @@ -229,8 +253,6 @@ 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, 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]. @@ -238,8 +260,11 @@ module MOM_variables 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]. - TKE_BBL, & !< A term related to the bottom boundary layer source of turbulent kinetic - !! energy, currently in [H Z2 T-3 ~> m3 s-3 or W m-2]. + 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 diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index b6cc97d943..4713fb6797 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -26,8 +26,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]. @@ -173,7 +174,8 @@ 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, & diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index f454ac8d4a..85af39e377 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -8,16 +8,18 @@ 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 @@ -837,14 +839,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 [m] - 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 in arbitrary units [a] - real :: totalStuff !< the globally integrated amount of stuff [a m3] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights + !! [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 ! The column integrated amount of stuff in a cell [a m3] + 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) @@ -852,52 +861,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 [m] - 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 [degC] - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: salinity !< The salinity field to sum [ppt] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights + !! [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. ! The total ocean volume, saved for the next call [m3] - real, save :: totalT = 0. ! The total volume integrated ocean temperature, saved for the next call [degC m3] - real, save :: totalS = 0. ! The total volume integrated ocean salinity, saved for the next call [ppt m3] + 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 ! The volume of each column [m3] - real :: thisH, delH ! The total ocean volume and the change from the last call [m3] - real :: thisT, delT ! The current total volume integrated temperature and the change from the last call [degC m3] - real :: thisS, delS ! The current total volume integrated salinity and the change from the last call [ppt m3] + 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 diff --git a/src/diagnostics/MOM_diagnose_KdWork.F90 b/src/diagnostics/MOM_diagnose_KdWork.F90 new file mode 100644 index 0000000000..12f8191619 --- /dev/null +++ b/src/diagnostics/MOM_diagnose_KdWork.F90 @@ -0,0 +1,1175 @@ +!> Provides diagnostics of work due to a given diffusivity +module MOM_diagnose_kdwork + +! This file is part of MOM6. See LICENSE.md for the license. + +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 kg m-1 s-3 = W m-3] + Bflx_temp => NULL(), & !< Temperature contribution to buoyancy flux at interfaces + !! [H Z T-3 ~> m2 s-3 or kg m-1 s-3 = W m-3] + Bflx_salt_dz => NULL(), & !< Salinity contribution to integral of buoyancy flux over layer + !! [H Z2 T-3 ~> m3 s-3 or kg m-1 s-3 = W m-2] + Bflx_temp_dz => NULL(), & !< Temperature contribution to integral of buoyancy flux over layer + !! [H Z2 T-3 ~> m3 s-3 or kg m-1 s-3 = 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_ePBL>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 kg m-1 s-3 = 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 kg s-3 = 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%do_bflx_salt .or. VBF%do_bflx_salt_dz ) & + allocate(VBF%Kd_salt(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%do_bflx_temp .or. VBF%do_bflx_temp_dz ) & + 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_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_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_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_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_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) & + 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_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_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_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_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_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_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_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_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 index 29b66ef6ac..d8cadb5bdd 100644 --- a/src/diagnostics/MOM_diagnose_MLD.F90 +++ b/src/diagnostics/MOM_diagnose_MLD.F90 @@ -30,7 +30,8 @@ module MOM_diagnose_mld !> 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) + 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 @@ -48,6 +49,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, 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]. @@ -93,7 +96,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, endif endif - gE_rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ + 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 @@ -234,11 +237,16 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, 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, diagPtr) +subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr, MLD_out) ! Author: Brandon Reichl ! Date: October 2, 2020 ! // @@ -270,6 +278,8 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any !! available thermodynamic fields. type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + 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]. @@ -322,11 +332,9 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. do iM=1,3 - PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) + PE_threshold(iM) = Mixing_Energy(iM) / GV%g_Earth_Z_T2 enddo - MLD(:,:,:) = 0.0 - EOSdom(:) = EOS_domain(G%HI) do j=js,je @@ -467,6 +475,11 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, 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 diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 677fdfe6dc..d164363ec4 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -81,6 +81,10 @@ 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 @@ -100,8 +104,11 @@ module MOM_diagnostics 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 @@ -204,7 +211,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! including [nondim] and [H ~> m or kg m-2]. 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 :: mass_cell(SZI_(G),SZJ_(G)) ! The vertically integrated mass in a grid cell [kg] + 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] @@ -226,7 +233,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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 [kg] + 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] @@ -332,9 +339,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_masso > 0) then mass_cell(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - mass_cell(i,j) = mass_cell(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(mass_cell) + masso = reproducing_sum(mass_cell, unscale=US%RZL2_to_kg) call post_data(CS%id_masso, masso, CS%diag) endif @@ -404,6 +411,36 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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) + ! 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) @@ -420,8 +457,24 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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, @@ -434,6 +487,36 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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) + ! 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) @@ -450,42 +533,21 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo ; enddo ; enddo call post_data(CS%id_sosq, work_3d, CS%diag) endif - 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 - - ! 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 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 - - ! 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) + ! 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) @@ -1020,7 +1082,45 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS * ((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_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 + 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 @@ -1042,6 +1142,107 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS 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 or W m-2]. ! The Coriolis source should be zero, but is not due to truncation errors. There should be @@ -1341,7 +1542,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv 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 [Z ~> m] - real :: volo ! Total volume of the ocean [m3] + 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 @@ -1375,7 +1576,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, unscale=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 @@ -1574,10 +1775,12 @@ 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" @@ -1616,10 +1819,13 @@ 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, "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=.true.) + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) 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) @@ -1632,6 +1838,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 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.) thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) @@ -1641,8 +1849,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 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', & @@ -1659,11 +1868,11 @@ 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', conversion=US%C_to_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', conversion=US%S_to_ppt) + 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, & @@ -1684,26 +1893,44 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_temp_layer_ave = register_diag_field('ocean_model', 'temp_layer_ave', & 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', 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', 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', units='psu', conversion=US%S_to_ppt, & standard_name='sea_water_salinity') + 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_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') + 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') endif CS%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & @@ -1809,10 +2036,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', & @@ -1910,7 +2160,7 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) ! 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', & + 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', & @@ -2271,10 +2521,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_visc_gl90 > 0) .or. (CS%id_KE_stress > 0) .or. (CS%id_KE_horvisc > 0) .or. & - (CS%id_KE_dia > 0)) + (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) @@ -2314,6 +2591,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 index 1e3b9895cb..f2585d510a 100644 --- a/src/diagnostics/MOM_harmonic_analysis.F90 +++ b/src/diagnostics/MOM_harmonic_analysis.F90 @@ -46,7 +46,9 @@ module MOM_harmonic_analysis time_ref !< Reference time (t = 0) used to calculate tidal forcing real, dimension(MAX_CONSTITUENTS) :: & freq, & !< The frequency of a tidal constituent [T-1 ~> s-1] - phase0 !< The phase of a tidal constituent at time 0 [rad] + 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]. real, allocatable :: FtF(:,:) !< Accumulator of (F' * F) for all fields [nondim] integer :: nc !< The number of tidal constituents in use integer :: length !< Number of fields of which harmonic analysis is to be performed @@ -60,13 +62,15 @@ module MOM_harmonic_analysis !> This subroutine sets static variables used by this module and initializes CS%list. !! THIS MUST BE CALLED AT THE END OF tidal_forcing_init. -subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, CS) +subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, tide_fn, tide_un, CS) type(time_type), intent(in) :: Time !< The current model time type(time_type), intent(in) :: time_ref !< Reference time (t = 0) used to calculate tidal forcing type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real, dimension(MAX_CONSTITUENTS), intent(in) :: freq !< The frequency of a tidal constituent [T-1 ~> s-1] - real, dimension(MAX_CONSTITUENTS), intent(in) :: phase0 !< The phase of a tidal constituent at time 0 [rad] + real, intent(in) :: freq(MAX_CONSTITUENTS) !< The frequency of a tidal constituent [T-1 ~> s-1] + real, intent(in) :: phase0(MAX_CONSTITUENTS) !< The phase of a tidal constituent at time 0 [rad] + real, intent(in) :: tide_fn(MAX_CONSTITUENTS) !< Amplitude modulation of tides by nodal cycle [nondim]. + real, intent(in) :: tide_un(MAX_CONSTITUENTS) !< Phase modulation of tides by nodal cycle [rad]. integer, intent(in) :: nc !< The number of tidal constituents in use character(len=16), intent(in) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent type(harmonic_analysis_CS), intent(out) :: CS !< Control structure of the MOM_harmonic_analysis module @@ -135,6 +139,8 @@ subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, CS%time_ref = time_ref CS%freq = freq CS%phase0 = phase0 + CS%tide_fn = tide_fn + CS%tide_un = tide_un CS%nc = nc CS%const_name = const_name CS%length = 0 @@ -173,6 +179,7 @@ end subroutine HA_register !> This subroutine accumulates the temporal basis functions in FtF. !! The tidal constituents are those used in MOM_tidal_forcing, plus the mean (of zero frequency). +!! Only the main diagonal and entries below it are calculated, which are needed for Cholesky decomposition. subroutine HA_accum_FtF(Time, CS) type(time_type), intent(in) :: Time !< The current model time type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module @@ -191,27 +198,31 @@ subroutine HA_accum_FtF(Time, CS) nc = CS%nc now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref) - ! Accumulate FtF - CS%FtF(1,1) = CS%FtF(1,1) + 1.0 !< For the zero frequency + !< First entry, corresponding to the zero frequency constituent (mean) + CS%FtF(1,1) = CS%FtF(1,1) + 1.0 + do c=1,nc icos = 2*c isin = 2*c+1 - cosomegat = cos(CS%freq(c) * now + CS%phase0(c)) - sinomegat = sin(CS%freq(c) * now + CS%phase0(c)) + 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) CS%FtF(icos,1) = CS%FtF(icos,1) + cosomegat CS%FtF(isin,1) = CS%FtF(isin,1) + sinomegat - CS%FtF(1,icos) = CS%FtF(icos,1) - CS%FtF(1,isin) = CS%FtF(isin,1) - do cc=c,nc + + do cc=1,c iccos = 2*cc issin = 2*cc+1 - ccosomegat = cos(CS%freq(cc) * now + CS%phase0(cc)) - ssinomegat = sin(CS%freq(cc) * now + CS%phase0(cc)) + 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 CS%FtF(icos,iccos) = CS%FtF(icos,iccos) + cosomegat * ccosomegat CS%FtF(icos,issin) = CS%FtF(icos,issin) + cosomegat * ssinomegat CS%FtF(isin,iccos) = CS%FtF(isin,iccos) + sinomegat * ccosomegat CS%FtF(isin,issin) = CS%FtF(isin,issin) + sinomegat * ssinomegat - enddo ! cc=c,nc + enddo ! cc=1,c enddo ! c=1,nc end subroutine HA_accum_FtF @@ -276,14 +287,18 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS) is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je - ! Accumulate FtF and 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 = cos(CS%freq(c) * now + CS%phase0(c)) - sinomegat = sin(CS%freq(c) * now + CS%phase0(c)) + 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,1) = ha1%FtSSH(i,j,1) + (data(i,j) - ha1%ref(i,j)) ha1%FtSSH(i,j,icos) = ha1%FtSSH(i,j,icos) + (data(i,j) - ha1%ref(i,j)) * cosomegat ha1%FtSSH(i,j,isin) = ha1%FtSSH(i,j,isin) + (data(i,j) - ha1%ref(i,j)) * sinomegat enddo ; enddo @@ -315,7 +330,7 @@ subroutine HA_write(ha1, Time, G, CS) ! Local variables real, dimension(:,:,:), allocatable :: FtSSHw !< An array containing the harmonic constants [A] integer :: year, month, day, hour, minute, second - integer :: nc, k, is, ie, js, je + 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 @@ -348,6 +363,11 @@ subroutine HA_write(ha1, Time, G, CS) 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 @@ -362,75 +382,68 @@ subroutine HA_write(ha1, Time, G, CS) end subroutine HA_write -!> This subroutine computes the harmonic constants (stored in FtSSHw) using the dot products of the temporal +!> 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 * FtSSHw = FtSSH, => FtFw * (FtFw' * FtSSHw) = FtSSH, +!! FtF * x = FtSSH, => L * (L' * x) = FtSSH, => L * y = FtSSH, !! -!! where FtFw is a lower triangular matrix, and the prime denotes matrix transpose. +!! where L is the lower triangular matrix, y = L' * x, and x is the solution vector. !! -subroutine HA_solver(ha1, nc, FtF, FtSSHw) +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(:,:,:), allocatable, intent(out) :: FtSSHw !< Work array for Cholesky decomposition [A] + 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(:), allocatable :: tmp1 !< Temporary variable for Cholesky decomposition [nondim] - real, dimension(:,:), allocatable :: tmp2 !< Temporary variable for Cholesky decomposition [A] - real, dimension(:,:), allocatable :: FtFw !< Lower triangular matrix for Cholesky decomposition [nondim] - integer :: k, m, n, is, ie, js, je - - is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je - - allocate(tmp1(1:2*nc+1), source=0.0) - allocate(tmp2(is:ie,js:je), source=0.0) - allocate(FtFw(1:2*nc+1,1:2*nc+1), source=0.0) - allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0) - - ! Construct FtFw - FtFw(:,:) = 0.0 + 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 - tmp0 = tmp0 + FtFw(m,k) * FtFw(m,k) + do k=1,m-1 ! This loop operates along the m-th row + tmp0 = tmp0 + L(m,k) * L(m,k) enddo - FtFw(m,m) = sqrt(FtF(m,m) - tmp0) - tmp1(m) = 1 / FtFw(m,m) - do k=m+1,2*nc+1 + 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 + FtFw(k,n) * FtFw(m,n) + tmp0 = tmp0 + L(k,n) * L(m,n) enddo - FtFw(k,m) = (FtF(k,m) - tmp0) * tmp1(m) + 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 (FtFw' * FtSSHw) - FtSSHw(:,:,:) = ha1%FtSSH(:,:,:) + ! Solve for y from L * y = FtSSH do k=1,2*nc+1 tmp2(:,:) = 0.0 do m=1,k-1 - tmp2(:,:) = tmp2(:,:) + FtFw(k,m) * FtSSHw(:,:,m) + tmp2(:,:) = tmp2(:,:) + L(k,m) * y(:,:,m) enddo - FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp2(:,:)) * tmp1(k) + y(:,:,k) = (ha1%FtSSH(:,:,k) - tmp2(:,:)) * tmp1(k) enddo - ! Solve for FtSSHw + ! 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(:,:) + FtSSHw(:,:,m) * FtFw(m,k) + tmp2(:,:) = tmp2(:,:) + L(m,k) * x(:,:,m) enddo - FtSSHw(:,:,k) = (FtSSHw(:,:,k) - tmp2(:,:)) * tmp1(k) + x(:,:,k) = (y(:,:,k) - tmp2(:,:)) * tmp1(k) enddo - deallocate(tmp1) - deallocate(tmp2) - deallocate(FtFw) - end subroutine HA_solver !> \namespace harmonic_analysis @@ -441,7 +454,7 @@ end subroutine HA_solver !! 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, +!! (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 diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index a590ae3893..f81f2a7574 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -114,6 +114,7 @@ subroutine find_obsolete_params(param_file) 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.") @@ -168,29 +169,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. "// & @@ -211,12 +198,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 @@ -246,15 +234,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) + 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)) @@ -273,14 +262,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) + 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 fe33e38a80..bc0b05b477 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -34,54 +34,61 @@ module MOM_spatial_means contains -!> Return the global area mean of a variable. This uses reproducing sums. +!> 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 in + 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] + !! 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. + !! 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. + !! 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 ! 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(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] - real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] - real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + ! 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 temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = G%US%L_to_m**2*temp_scale - if (present(unscale)) then ; scalefac = scalefac * unscale - elseif (present(scale)) then ; scalefac = scalefac * scale ; endif + + 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 - - if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & - global_area_mean = global_area_mean / temp_scale + 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 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, possibly rescaled units [A ~> a] + 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 @@ -92,10 +99,10 @@ function global_area_mean_v(var, G, tmp_scale) 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] is used to indicate the arbitrary, possibly rescaled units of the + ! 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 m2] - real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] + ! [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 @@ -103,25 +110,23 @@ function global_area_mean_v(var, G, tmp_scale) isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = G%US%L_to_m**2*temp_scale tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie - tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & + 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) * G%IareaT_global - if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & - global_area_mean_v = global_area_mean_v / temp_scale + 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, possibly rescaled units [A ~> a] + 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 @@ -131,10 +136,9 @@ function global_area_mean_u(var, G, tmp_scale) 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] is used to indicate the arbitrary, possibly rescaled units of the + ! 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 m2] - real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] + 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 @@ -142,52 +146,75 @@ function global_area_mean_u(var, G, tmp_scale) isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = G%US%L_to_m**2*temp_scale tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie - tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & + 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) * G%IareaT_global - if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & - global_area_mean_u = global_area_mean_u / temp_scale + 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, by default using the masked area from the -!! grid, but an alternate could be used instead. This uses reproducing sums. +!> 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 in - !! arbitrary, possibly rescaled units [A ~> a] + 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, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value [a A-1 ~> 1] + real, optional, intent(in) :: 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. + !! 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 m2 ~> a m2] depending on which optional arguments are provided + !! [a m2] or [A L2 ~> a m2] or [B L2 ~> b m2], depending on which optional + !! arguments are provided ! 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(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] - real :: scalefac ! An overall scaling factor for the areas and variable, perhaps in [m2 a A-1 L-2 ~> 1] - real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + ! 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 - temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = G%US%L_to_m**2*temp_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 @@ -202,10 +229,7 @@ function global_area_integral(var, G, scale, area, tmp_scale, unscale) enddo ; enddo endif - global_area_integral = reproducing_sum(tmpForSumming) - - if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & - global_area_integral = global_area_integral / temp_scale + global_area_integral = reproducing_sum(tmpForSumming, unscale=temp_scale) end function global_area_integral @@ -213,55 +237,87 @@ end function global_area_integral function global_layer_mean(var, h, G, GV, scale, tmp_scale, unscale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average in - !! arbitrary, possibly rescaled units [A ~> a] + 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 [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] + !! 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. + !! 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] - !! or unscaled [a] units of var, depending on which optional - !! arguments are provided + 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 ! Local variables - ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! 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(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: tmpForSumming ! An unscaled cell integral [a m3] or [a kg] - real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: weight ! The volume or mass of each cell, depending on - ! whether the model is Boussinesq, used as a weight [m3] or [kg] - type(EFP_type), dimension(2*SZK_(GV)) :: laysums - real, dimension(SZK_(GV)) :: global_temp_scalar ! The global integral of the tracer in each layer [a m3] or [a kg] - real, dimension(SZK_(GV)) :: global_weight_scalar ! The global integral of the volume or mass of each - ! layer [m3] or [kg] - real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] - real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + 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 temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = temp_scale - if (present(unscale)) then ; scalefac = unscale * temp_scale - elseif (present(scale)) then ; scalefac = scale * temp_scale ; endif + + 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_MKS * 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)) / (temp_scale * 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 @@ -271,105 +327,147 @@ 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 in - !! arbitrary, possibly rescaled units [A ~> a] + 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 [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] + !! 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. + !! 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] or + 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 ! Local variables - ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! 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 :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] - real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] - real :: weight_here ! The volume or mass of a grid cell [m3] or [kg] - real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! The volume integral of the variable in a column [a m3] or [a kg] - real, dimension(SZI_(G),SZJ_(G)) :: sum_weight ! The volume or mass of each column of water [m3] or [kg] + ! [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 temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = temp_scale - if (present(unscale)) then ; scalefac = temp_scale * unscale - elseif (present(scale)) then ; scalefac = temp_scale * scale ; endif + + 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_MKS * 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)) / & - (temp_scale * 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. +!> 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 in - !! arbitrary, possibly rescaled units [A ~> a] + 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] + 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. + !! 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 [kg A ~> kg a] + 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] is used to indicate the arbitrary, possibly rescaled units of the + ! 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 ! The mass-weighted integral of the variable in a column [kg a] - 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] - real :: temp_scale ! A temporary scaling factor [1] or [a A-1 ~> 1] + ! [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 - temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale - scalefac = G%US%L_to_m**2*temp_scale - if (present(unscale)) then ; scalefac = scalefac * unscale - elseif (present(scale)) then ; scalefac = scalefac * scale ; endif - tmpForSumming(:,:) = 0.0 + if (present(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 @@ -377,9 +475,6 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale, unsca enddo ; enddo endif - if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & - global_mass_integral = global_mass_integral / temp_scale - end function global_mass_integral !> Find the global mass-weighted order invariant integral of a variable in mks units, @@ -390,13 +485,14 @@ function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale, unscale) 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 in - !! arbitrary, possibly rescaled units [A ~> a] + 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 + !! 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. @@ -406,9 +502,9 @@ function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale, unscale) !! kg times the arbitrary units of var [kg a] ! Local variables - ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! 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)) :: tmpForSum ! The mass-weighted integral of the variable in a column [kg a] + 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 @@ -440,9 +536,10 @@ 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, unscale) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in - !! arbitrary, possibly rescaled units [A ~> a] + 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 [nondim] @@ -458,7 +555,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale, unscale) !! is preferred and takes precedence if both are present. ! Local variables - ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! 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] @@ -540,9 +637,10 @@ 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, unscale) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in - !! arbitrary, possibly rescaled units [A ~> a] + 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 [nondim] @@ -558,7 +656,7 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale, unscale) !! is preferred and takes precedence if both are present. ! Local variables - ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! 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] @@ -640,8 +738,9 @@ 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, unscale) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted in - !! arbitrary, possibly rescaled units [A ~> a] + 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) @@ -652,13 +751,14 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale, unscale) !! Here unit_scale and unscale are synonymous, but unscale !! is preferred and takes precedence if both are present. ! Local variables - ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! 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(G%isc:G%iec, G%jsc:G%jec) :: posVals, negVals ! The positive or negative values in a cell or 0 [a] - real, dimension(G%isc:G%iec, G%jsc:G%jec) :: areaXposVals, areaXnegVals ! The cell area integral of the values [m2 a] + 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 :: I_scalefac ! The Adcroft reciprocal of scalefac [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 @@ -667,21 +767,19 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale, unscale) if (present(unscale)) then ; scalefac = unscale elseif (present(unit_scale)) then ; scalefac = unit_scale ; endif - I_scalefac = 0.0 ; if (scalefac /= 0.0) I_scalefac = 1.0 / scalefac - ! areaXposVals(:,:) = 0. ! This zeros out halo points. ! 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) ) @@ -691,12 +789,12 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale, unscale) 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 diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index a0f1d5157e..3971e04350 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -4,8 +4,8 @@ module MOM_sum_output ! This file is part of MOM6. See LICENSE.md for the license. use iso_fortran_env, only : int64 -use MOM_checksums, only : is_NaN -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, NOTE, is_root_pe @@ -21,9 +21,9 @@ module MOM_sum_output use MOM_io, only : attribute_info, set_attribute_info, delete_attribute_info use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_spatial_means, only : array_global_min_max -use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) +use MOM_time_manager, only : time_type, get_time, get_date, set_time use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<), operator(>) use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_stocks use MOM_unit_scaling, only : unit_scale_type @@ -338,41 +338,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 [m]. - 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_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 :: 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]. @@ -399,14 +397,18 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & 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 L 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 L 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, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer @@ -437,14 +439,14 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci real :: T_min ! The global minimum unmasked value of the temperature [degC] real :: T_max ! The global maximum unmasked value of the temperature [degC] real :: T_min_x ! The x-positions of the global temperature minima - ! in the units of G%geoLonT, often [degreeT_E] or [km] + ! 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 [degreeT_N] or [km] + ! 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 [degreeT_E] or [km] + ! 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 [degreeT_N] or [km] + ! in the units of G%geoLatT, often [degrees_N] or [km] real :: T_max_z ! The z-positions of the global temperature maxima [layer] @@ -489,7 +491,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 @@ -506,34 +508,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.") @@ -544,28 +550,21 @@ 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 - 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) - if (CS%do_APE_calc) then 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 + 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 @@ -692,7 +691,6 @@ 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 @@ -702,7 +700,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci 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 @@ -711,7 +709,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci 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 * 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 @@ -720,47 +718,43 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci 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.25 * PE_scale_factor * areaTm(i,j) * & + 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 * PE_scale_factor * areaTm(i,j) * (GV%Rlay(1)*GV%g_prime(1))) * & + 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))) * & + 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) + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=KE, unscale=RZL4_T2_to_J) - toten = KE_tot + PE_tot - - 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) + US%S_to_ppt*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 @@ -770,13 +764,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) @@ -803,36 +795,41 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci 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_chg = Salt_chg / mass_tot - temp = heat / (mass_tot*US%Q_to_J_kg*US%degC_to_C*tv%C_p) - temp_anom = Heat_anom / (mass_tot*US%Q_to_J_kg*US%degC_to_C*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) @@ -858,7 +855,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci if (date_stamped) then write(date_str,'("MOM Date",i7,2("/",i2.2)," ",i2.2,2(":",i2.2))') & - iyear, imonth, iday, ihour, iminute, isecond + iyear, imonth, iday, ihour, iminute, isecond else date_str = trim(mesg_intro)//trim(day_str) endif @@ -866,46 +863,44 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci 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 ",& + 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 + 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 else - write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, & - &", CFL ", F8.5, ", SL ",& + 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 + 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 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,")" )') & @@ -918,10 +913,10 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci 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,")" )') & @@ -954,7 +949,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci 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), H_0APE, 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) @@ -963,9 +958,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci 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), 0.001*Salt, reday) - call CS%fileenergy_nc%write_field(CS%fields(13), 0.001*salt_chg, reday) - call CS%fileenergy_nc%write_field(CS%fields(14), 0.001*salt_anom, reday) + 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) @@ -983,9 +978,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci if (is_NaN(En_mass)) then call MOM_error(FATAL, "write_energy : NaNs in total model energy forced model termination.") - elseif (En_mass > US%L_T_to_m_s**2*CS%max_Energy) then + elseif (En_mass > CS%max_Energy) then write(mesg,'("Energy per unit mass of ",ES11.4," exceeds ",ES11.4)') & - En_mass, US%L_T_to_m_s**2*CS%max_Energy + 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 @@ -1018,13 +1013,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 :: 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 @@ -1038,14 +1031,11 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) 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) + & + 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 @@ -1056,27 +1046,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) & @@ -1086,41 +1075,41 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! smg: old code if (associated(fluxes%heat_content_evap)) 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_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) + (tv%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*tv%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) + (tv%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 @@ -1129,9 +1118,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 @@ -1349,9 +1341,9 @@ subroutine write_depth_list(G, US, DL, filename) 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, 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 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) @@ -1447,22 +1439,23 @@ 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(:,:) ! A temporary array for output converted to MKS units [m] or [m2] allocate(field(G%isc:G%iec, G%jsc:G%jec)) ! Depth checksum do j=G%jsc,G%jec ; do i=G%isc,G%iec - field(i,j) = US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) + 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 1c508ec490..7abdab0a90 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -99,7 +99,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N 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-1 kg-1]. + 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]. @@ -163,7 +163,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N 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-1 kg-1] + 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. @@ -853,7 +853,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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 [R-1 H ~> 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 pr m7 s-2 kg-1]. + 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 [nondim]. real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. @@ -1303,9 +1303,9 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! 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] + 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] + 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 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 938634c1ea..4c7f86668c 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -17,7 +17,7 @@ module MOM_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 +use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp 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, calculate_TFreeze_TEOS_poly @@ -52,6 +52,7 @@ module MOM_EOS public cons_temp_to_pot_temp public abs_saln_to_prac_saln public gsw_sp_from_sr +public gsw_sr_from_sp public gsw_pt_from_ct public query_compressible public get_EOS_name @@ -1472,6 +1473,9 @@ subroutine EOS_init(param_file, EOS, US) character(len=12) :: TFREEZE_DEFAULT ! The default freezing point expression character(len=40) :: tmpstr logical :: EOS_quad_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] ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1512,10 +1516,19 @@ subroutine EOS_init(param_file, EOS, US) trim(tmpstr)//'"', 5) if (EOS%form_of_EOS == EOS_LINEAR) then + ! RHO(T,S) = RHO_TREF_SREF + DRHO_DT*(T-TREF) + DRHO_DS*(S-SREF) + ! = RHO_TREF_SREF - DRHO_DT*TREF - DRHO_DS*SREF + DRHO_DT*T + DRHO_DS*S + ! = RHO_T0_S0 + DRHO_DT*T + DRHO_DS*S EOS%Compressible = .false. - call get_param(param_file, mdl, "RHO_T0_S0", EOS%Rho_T0_S0, & + call get_param(param_file, mdl, "RHO_TREF_SREF", Rho_Tref_Sref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the density at T=TREF, S=SREF.", units="kg m-3", default=1000.0) + call get_param(param_file, mdl, "TREF", Tref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& + "this is the reference temperature.", units="degC", default=0.0) + call get_param(param_file, mdl, "SREF", Sref, & "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the density at T=0, S=0.", units="kg m-3", default=1000.0) + "this is the reference salinity.", units="psu", 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 "//& @@ -1524,6 +1537,10 @@ subroutine EOS_init(param_file, EOS, US) "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, "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=Rho_Tref_Sref - EOS%dRho_dT * Tref - EOS%dRho_dS * Sref) 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) endif if (EOS%form_of_EOS == EOS_WRIGHT) then diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index 6e4aaa762f..17f2f5156f 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -3,7 +3,7 @@ module MOM_EOS_TEOS10 ! This file is part of MOM6. See LICENSE.md for the license. -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 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 @@ -11,7 +11,7 @@ module MOM_EOS_TEOS10 implicit none ; private -public gsw_sp_from_sr, gsw_pt_from_ct +public gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp public TEOS10_EOS real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar [dbar Pa-1] diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 4e349e0fb7..8a172ce0c8 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -11,12 +11,13 @@ 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 @@ -83,21 +84,37 @@ 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 @@ -144,6 +161,9 @@ subroutine chksum0(scalar, mesg, scale, logunit, unscale) 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 @@ -204,6 +224,10 @@ subroutine zchksum(array, mesg, scale, logunit, unscale) 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, unscale) @@ -381,6 +405,7 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu ! 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 ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit @@ -391,6 +416,7 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu 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 @@ -451,27 +477,36 @@ 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 @@ -675,6 +710,7 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! 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 ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit @@ -750,33 +786,42 @@ 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 @@ -981,6 +1026,7 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! 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 ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit @@ -1065,39 +1111,48 @@ 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 @@ -1175,6 +1230,7 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! 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 ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit @@ -1259,39 +1315,48 @@ 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 @@ -1366,6 +1431,7 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu ! 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 ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit @@ -1438,27 +1504,36 @@ 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 - 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) - 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("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 (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 (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_NSEW("h-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, '("h-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains @@ -1532,6 +1607,7 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! 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 ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit @@ -1609,38 +1685,47 @@ 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 @@ -1718,6 +1803,7 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! 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 ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit @@ -1802,39 +1888,48 @@ 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 @@ -1912,6 +2007,7 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! 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 ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit @@ -1996,39 +2092,48 @@ 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 @@ -2275,119 +2380,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 [arbitrary] + 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 [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 [arbitrary] + 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 [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 [arbitrary] + 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 [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 [arbitrary] 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 [arbitrary] + 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 [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 [arbitrary] 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 [arbitrary] + 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 [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 [arbitrary] 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 diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index e4f5235da8..ea5e632039 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -51,7 +51,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 @@ -91,8 +92,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 in arbitrary units [a] +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 @@ -102,15 +104,17 @@ 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 @@ -120,7 +124,8 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, integer(kind=int64) :: ival, prec_error real :: rs ! The remaining value to add, in arbitrary units [a] real :: max_mag_term ! A running maximum magnitude of the values in arbitrary units [a] - logical :: over_check, do_sum_across_PEs + 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 @@ -130,7 +135,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, 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 @@ -150,32 +155,40 @@ 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), kind=int64) rs = rs - ival*pr(n) @@ -213,13 +226,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 in arbitrary units [a] + 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 @@ -228,7 +243,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 @@ -240,16 +255,18 @@ 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 !< The sum of the values in array in arbitrary units [a] - - ! This subroutine uses a conversion to an integer representation - ! of real numbers to give order-invariant sums that will reproduce - ! across PE count. This idea comes from R. Hallberg and A. Adcroft. + real, 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] - logical :: repro, do_sum_across_PEs + 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, is, ie, js, je @@ -260,7 +277,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & 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 @@ -280,19 +297,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 @@ -312,7 +335,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 @@ -322,9 +345,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 in arbitrary units [a] + 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 @@ -333,28 +357,31 @@ 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 in abitrary units [a] + real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer in the same + !! abitrary 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 !< The sum of the values in array in arbitrary units [a] - - ! This subroutine uses a conversion to an integer representation - ! of real numbers to give order-invariant sums that will reproduce - ! across PE count. This idea comes from R. Hallberg and A. Adcroft. + !! 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, & @@ -384,6 +411,8 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su 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 @@ -396,22 +425,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 @@ -458,21 +493,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 @@ -504,6 +545,15 @@ 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 @@ -516,9 +566,11 @@ function real_to_ints(r, prec_error, overflow) result(ints) 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=int64), dimension(ni) :: ints + ! This subroutine converts a real number to an equivalent representation ! using several long integers. + ! Local variables real :: rs ! The remaining value to add, in arbitrary units [a] character(len=80) :: mesg integer(kind=int64) :: ival, prec_err diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index b931a2ddd2..25a2937aaa 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -391,27 +391,33 @@ subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, ! Local variables real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in arbitrary units [A] integer :: q_turns ! The number of quarter turns through which array_out is to be rotated - integer :: index, is, ie, js, je, halo + integer :: index index = ind_flux ; if (present(field_index)) index = field_index q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) - halo = 0 ; if (present(halo_size)) halo = halo_size ! The case with non-trivial grid rotation is complicated by the fact that the data fields ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. if (q_turns == 0) then call CT_extract_data(var_in, bc_index, index, array_out, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) elseif (present(idim) .and. present(jdim)) then - ! Work only on the computational domain plus symmetric halos. - is = idim(2)-halo ; ie = idim(3)+halo ; js = jdim(2)-halo ; je = jdim(3)+halo - call allocate_rotated_array(array_out(is:ie,js:je), [1,1], -q_turns, array_unrot) - call CT_extract_data(var_in, bc_index, index, array_unrot, scale_factor=scale_factor, halo_size=halo) - call rotate_array(array_unrot, q_turns, array_out(is:ie,js:je)) + 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 allocate_rotated_array(array_out, [1,1], -q_turns, array_unrot) - call CT_extract_data(var_in, bc_index, index, array_unrot, scale_factor=scale_factor, halo_size=halo) + call 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 @@ -453,14 +459,12 @@ subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_fact ! as array_in [A] integer :: subfield ! An integer indicating which field to set. integer :: q_turns ! The number of quarter turns through which array_in is rotated - integer :: is, ie, js, je, halo q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) subfield = ind_csurf if (present(solubility)) then ; if (solubility) subfield = ind_alpha ; endif if (present(field_index)) subfield = field_index - halo = 0 ; if (present(halo_size)) halo = halo_size ! The case with non-trivial grid rotation is complicated by the fact that the data fields ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. @@ -468,12 +472,19 @@ subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_fact call CT_set_data(array_in, bc_index, subfield, var, & scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) elseif (present(idim) .and. present(jdim)) then - ! Work only on the computational domain plus symmetric halos. - is = idim(2)-halo ; ie = idim(3)+halo ; js = jdim(2)-halo ; je = jdim(3)+halo - call allocate_rotated_array(array_in(is:ie,js:je), [1,1], -q_turns, array_unrot) + call 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_unrot, bc_index, subfield, var, & - scale_factor=scale_factor, halo_size=halo_size) + + 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) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index c28e2e5896..1a43739147 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -31,6 +31,7 @@ module MOM_diag_mediator 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_time_manager, only : get_time use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -972,7 +973,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) @@ -1285,6 +1286,10 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) 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 @@ -1300,7 +1305,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 @@ -1328,6 +1338,10 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) 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 @@ -1353,7 +1367,12 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) 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 @@ -1415,6 +1434,10 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) 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 @@ -1493,17 +1516,22 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif 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.") @@ -1735,6 +1763,10 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) 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 @@ -1831,17 +1863,22 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) 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.") @@ -1998,6 +2035,10 @@ subroutine post_xy_average(diag_cs, diag, field) 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 @@ -2031,8 +2072,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) @@ -2164,6 +2209,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=16) :: dimensions integer :: num_modnm, num_varnm logical :: active @@ -2384,6 +2430,22 @@ 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) then + dimensions = trim(adjustl(dimensions)) + if (dimensions(len_trim(dimensions):len_trim(dimensions)) == ",") then + dimensions = dimensions(1:len_trim(dimensions) - 1) + endif + dimensions = trim(dimensions) + endif + 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)//'"' @@ -2395,7 +2457,7 @@ 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 @@ -2897,6 +2959,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & 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 @@ -2956,15 +3019,18 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & 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 @@ -3016,6 +3082,7 @@ function register_static_field(module_name, field_name, axes, & 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=16) :: dimensions MOM_missing_value = axes%diag_cs%missing_value if (present(missing_value)) MOM_missing_value = missing_value @@ -3108,15 +3175,32 @@ 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) then + dimensions = trim(adjustl(dimensions)) + if (dimensions(len_trim(dimensions):len_trim(dimensions)) == ",") then + dimensions = dimensions(1:len_trim(dimensions) - 1) + endif + dimensions = trim(dimensions) + endif + ! 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 @@ -3153,10 +3237,13 @@ function ocean_register_diag(var_desc, G, diag_CS, day) 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. @@ -3211,8 +3298,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 @@ -3280,10 +3367,12 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + call get_param(param_file, mdl, "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=.true.) + "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 "//& @@ -3860,13 +3949,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 + 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 @@ -3886,6 +3976,11 @@ subroutine log_available_diag(used, module_name, field_name, cell_methods_string 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)) & diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 1151cd04b2..38553a4351 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -820,9 +820,11 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag logical, dimension(:), intent(out) :: averaged_mask !< Mask for horizontally averaged field [nondim] ! Local variables - real :: volume(G%isc:G%iec, G%jsc:G%jec, size(field,3)) ! The area [m2], volume [m3] or mass [kg] of each cell. + 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 [m2 A], [m3 A] or [kg A], + ! 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] @@ -847,14 +849,13 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag stuff_sum(k) = 0. if (is_extensive) then do j=G%jsc, G%jec ; do I=G%isc, G%iec - volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) + 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 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_MKS * height) * G%mask2dCu(I,j) + 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 @@ -862,7 +863,7 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag 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%areaCu(I,j)) * G%mask2dCu(I,j) + 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 @@ -873,14 +874,13 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag do k=1,nz if (is_extensive) then do J=G%jsc, G%jec ; do i=G%isc, G%iec - volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) + 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 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_MKS * height) * G%mask2dCv(i,J) + 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 @@ -888,7 +888,7 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag 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%areaCv(i,J)) * G%mask2dCv(i,J) + 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 @@ -900,7 +900,7 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag 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. @@ -909,8 +909,7 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag 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_MKS * 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 @@ -918,7 +917,7 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag 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 @@ -930,8 +929,8 @@ subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, stag ! 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 diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index f32573815f..d999e1e680 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -221,7 +221,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 +229,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 +258,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 +309,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 +342,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 @@ -472,7 +485,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 @@ -712,6 +725,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 @@ -1000,7 +1062,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 d07ac1ad86..64b0508fe0 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -353,7 +353,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & 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, & @@ -439,7 +439,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & 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.", default=1, layoutParam=.true.) + "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. diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 987d5bf502..2e183cdbef 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -175,17 +175,20 @@ module MOM_dyn_horgrid 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 :: 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 !< The radius of the planet [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 @@ -400,9 +403,9 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns) 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 diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 22d3789ea5..291d44492d 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -8,7 +8,7 @@ module MOM_file_parser 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 @@ -125,7 +125,7 @@ module MOM_file_parser contains -!> Make the contents of a parameter input file availalble in a param_file_type +!> 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, @@ -562,10 +562,10 @@ 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 @@ -583,7 +583,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. @@ -618,7 +618,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 @@ -626,6 +626,8 @@ 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=CS%max_line_len) :: value_string(1) logical :: found, defined @@ -633,6 +635,7 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) 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 @@ -643,6 +646,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)// & @@ -650,7 +654,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 @@ -658,12 +662,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=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 @@ -676,6 +683,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)// & @@ -683,7 +691,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 @@ -693,6 +701,8 @@ 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=CS%max_line_len) :: value_string(1) @@ -702,6 +712,7 @@ subroutine read_param_real(CS, varname, value, fail_if_missing, scale) 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 @@ -712,6 +723,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)// & @@ -719,7 +731,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 @@ -729,6 +741,8 @@ 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=CS%max_line_len) :: value_string(1) @@ -739,7 +753,7 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) 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 @@ -750,6 +764,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)// & @@ -757,7 +772,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 @@ -765,6 +780,8 @@ 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=CS%max_line_len) :: value_string(1) logical :: found, defined @@ -776,10 +793,12 @@ subroutine read_param_char(CS, varname, value, fail_if_missing) 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 @@ -787,6 +806,8 @@ 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=CS%max_line_len) :: value_string(1), loc_string @@ -813,10 +834,12 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) 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 @@ -824,6 +847,8 @@ 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=CS%max_line_len) :: value_string(1) @@ -835,10 +860,13 @@ subroutine read_param_logical(CS, varname, value, fail_if_missing) 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.') 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 @@ -850,6 +878,8 @@ 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=CS%max_line_len) :: value_string(1) @@ -891,6 +921,7 @@ 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 @@ -899,6 +930,7 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f call MOM_error(FATAL, 'Variable '//trim(varname)//' found but not set in input files.') endif endif ; endif + if (present(set)) set = .false. endif return @@ -989,7 +1021,7 @@ function max_input_line_length(CS, pf_num) result(max_len) 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 interepreted in a way +!! 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, @@ -1391,7 +1423,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 @@ -1400,7 +1432,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 @@ -1419,7 +1452,7 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & 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 @@ -1464,7 +1497,7 @@ 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, unscale) + 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 @@ -1473,7 +1506,8 @@ subroutine log_param_real_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=*), intent(in) :: units !< The units of this parameter - real, optional, intent(in) :: default !< The default value of the 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 @@ -1498,7 +1532,7 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & write(myunits(1:240),'(A)') trim(units) if (present(desc)) & - call doc_param(CS%doc, varname, desc, myunits, log_val, 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 @@ -1702,7 +1736,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, & - 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 @@ -1723,15 +1757,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 - 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 @@ -1744,8 +1800,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, & - 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 @@ -1755,7 +1811,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) :: 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 @@ -1766,20 +1823,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)) value(:) = default - call read_param_int_array(CS, varname, value, fail_if_missing) + 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 @@ -1788,7 +1877,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, & - 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 @@ -1811,15 +1900,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 - 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 @@ -1835,8 +1946,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, & - 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 @@ -1846,7 +1957,8 @@ subroutine get_param_real_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=*), intent(in) :: units !< The units of this parameter - real, optional, intent(in) :: default !< The default value of the 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 @@ -1859,20 +1971,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)) value(:) = default - call read_param_real_array(CS, varname, value, fail_if_missing) + 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(:) @@ -1884,7 +2028,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, & - 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 @@ -1905,15 +2049,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 - 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 @@ -1926,7 +2092,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) + 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 @@ -1943,18 +2109,40 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & !! 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 + 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)) value(:) = default - call read_param_char_array(CS, varname, value, fail_if_missing) + + 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 @@ -1976,7 +2164,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, & - 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 @@ -1997,15 +2185,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 - 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 @@ -2020,7 +2230,7 @@ end subroutine get_param_logical subroutine get_param_time(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & timeunit, layoutParam, debuggingParam, & - log_as_date) + 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 @@ -2045,8 +2255,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. + ! 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 @@ -2054,7 +2270,23 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - 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 @@ -2066,6 +2298,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 diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 324808e374..8e988ccce8 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -591,7 +591,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (PRESENT(homogenize)) then ; if (homogenize) then - call homogenize_field(tr_out, mask_out, G, scale, answer_date) + 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 @@ -908,7 +908,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (PRESENT(homogenize)) then ; if (homogenize) then - call homogenize_field(tr_out, mask_out, G, scale, answer_date) + 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 @@ -950,14 +950,15 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & 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, weight, G, scale, answer_date, wt_unscale) +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, dimension(SZI_(G),SZJ_(G)), intent(in) :: weight !< The weights for the tracer in arbitrary units that + 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] - real, intent(in) :: scale !< A rescaling factor that has been used for the - !! variable and has to be undone before the - !! reproducing sums [A a-1 ~> 1] 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 @@ -971,12 +972,11 @@ subroutine homogenize_field(field, weight, G, scale, answer_date, wt_unscale) ! 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(SZI_(G),SZJ_(G)) :: field_for_Sums ! The field times the weights with the scaling undone [a b] - real, dimension(SZI_(G),SZJ_(G)) :: wts_for_Sums ! A copy of the wieghts with the scaling undone [b] + 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_descale ! A factor that undoes any dimensional scaling of the weights so that they - ! can be used with reproducing sums [b B-1 ~> 1] - real :: wt_sum ! The sum of the weights, in [b] (reproducing) or [B ~> b] (non-reproducing) + 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. @@ -988,23 +988,27 @@ subroutine homogenize_field(field, weight, G, scale, answer_date, wt_unscale) use_repro_sums = .false. ; if (present(answer_date)) use_repro_sums = (answer_date >= 20230101) - if (scale == 0.0) then - ! This seems like an unlikely case to ever be used, but dealing with it is better than having NaNs arise? - varAvg = 0.0 - elseif (use_repro_sums) then - wt_descale = 1.0 ; if (present(wt_unscale)) wt_descale = wt_unscale - var_unscale = wt_descale / scale + 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 - field_for_Sums(:,:) = 0.0 - wts_for_Sums(:,:) = 0.0 do j=js,je ; do i=is,ie - wts_for_Sums(i,j) = wt_descale * weight(i,j) - field_for_Sums(i,j) = var_unscale * (field(i,j) * weight(i,j)) + field_for_Sums(i,j) = field(i,j) * weight(i,j) enddo ; enddo - wt_sum = reproducing_sum(wts_for_Sums) + wt_sum = reproducing_sum(weight, unscale=wt_unscale) if (abs(wt_sum) > 0.0) & - varAvg = reproducing_sum(field_for_Sums) * (scale / wt_sum) + 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. @@ -1021,8 +1025,12 @@ subroutine homogenize_field(field, weight, G, scale, answer_date, wt_unscale) 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 diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 8ee192323a..9177017c30 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -555,10 +555,10 @@ subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & pack = 1 if (present(checksums)) then fields(k) = IO_handle%register_field(axes(1:numaxes), vars(k)%name, vars(k)%units, & - vars(k)%longname, pack=pack, checksum=checksums(k,:)) + vars(k)%longname, pack=pack, checksum=checksums(k,:), conversion=vars(k)%conversion) else fields(k) = IO_handle%register_field(axes(1:numaxes), vars(k)%name, vars(k)%units, & - vars(k)%longname, pack=pack) + vars(k)%longname, pack=pack, conversion=vars(k)%conversion) endif enddo @@ -1880,6 +1880,8 @@ 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) @@ -2084,6 +2086,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) @@ -2126,9 +2131,8 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom !! 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 @@ -2159,9 +2163,9 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom !! 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 @@ -2177,12 +2181,13 @@ 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 in arbitrary units [A ~> a] - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + 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 !< A scaling factor that the variable is multiplied by @@ -2191,31 +2196,39 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & 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. - integer :: turns ! Number of quarter-turns from input to model grid + ! 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 + + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) + + 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_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) + timelevel, position, rescale, turns) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname @@ -2231,8 +2244,11 @@ subroutine read_netCDF_data_2d(filename, fieldname, values, MOM_Domain, & !< 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 :: turns + integer :: qturns ! Number of quarter-turns from input to model grid real, allocatable :: values_in(:,:) ! Field array on the unrotated input grid @@ -2253,13 +2269,15 @@ subroutine read_netCDF_data_2d(filename, fieldname, values, MOM_Domain, & call handle%open(filename, action=READONLY_FILE, MOM_domain=MOM_domain) call handle%update() - turns = MOM_domain%turns - if (turns == 0) then + 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], -turns, values_in) + 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, turns, values) + call rotate_array(values_in, qturns, values) deallocate(values_in) endif @@ -2294,13 +2312,17 @@ subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_ 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 @@ -2308,12 +2330,13 @@ 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 in arbitrary units [A ~> a] - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + 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 !< A scaling factor that the variable is multiplied by @@ -2322,25 +2345,32 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & 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. - integer :: turns ! Number of quarter-turns from input to model grid + ! 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 + + 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. @@ -2368,13 +2398,17 @@ subroutine MOM_read_data_3d_region(filename, fieldname, data, start, nread, MOM_ 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,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 @@ -2382,129 +2416,162 @@ 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 in arbitrary units [A ~> a] - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + 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 !< A scaling factor that the variable is multiplied by + 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. - integer :: turns ! Number of quarter-turns from input to model grid + ! 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 + + 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 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), intent(in) :: MOM_Domain !< Model domain decomposition + 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 !< A scaling factor that the vector is multiplied by + 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. - integer :: turns ! Number of quarter-turns from input to model grid + ! 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 - turns = MOM_Domain%turns - if (turns == 0) then + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) + + 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 in arbitrary units [A ~> a] real, dimension(:,:,:), intent(inout) :: v_data !< Field value in v in arbitrary units [A ~> a] - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + 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 !< A scaling factor that the vector is multiplied by + 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. - integer :: turns ! Number of quarter-turns from input to model grid + ! 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 - turns = MOM_Domain%turns - if (turns == 0) then + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) + + 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,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 !> Write a 4d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale, unscale) + 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 @@ -2521,6 +2588,8 @@ subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tst !! 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 [a] or @@ -2532,13 +2601,13 @@ subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tst 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) @@ -2548,7 +2617,7 @@ end subroutine MOM_write_field_legacy_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale, unscale) + 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 @@ -2565,6 +2634,8 @@ subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tst !! 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 [a] or @@ -2576,13 +2647,13 @@ subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tst 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) @@ -2592,7 +2663,7 @@ end subroutine MOM_write_field_legacy_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale, unscale) + 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 @@ -2609,6 +2680,8 @@ subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tst !! 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 [a] or @@ -2620,13 +2693,13 @@ subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tst 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) @@ -2635,7 +2708,7 @@ end subroutine MOM_write_field_legacy_2d !> Write a 1d field to an output file -subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) +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 in arbitrary units [A ~> a] @@ -2649,16 +2722,21 @@ subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_va !! 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 [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 - if (scale_fac == 1.0) then + design_zeros = .false. ; if (present(zero_zeros)) design_zeros = zero_zeros + + 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))) @@ -2666,6 +2744,9 @@ subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_va 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 @@ -2673,7 +2754,7 @@ end subroutine MOM_write_field_legacy_1d !> Write a 0d field to an output file -subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) +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 in arbitrary units [A ~> a] @@ -2687,6 +2768,8 @@ subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_va !! 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] @@ -2698,6 +2781,7 @@ subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_va 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 write_field(IO_handle, field_md, scaled_val, tstamp=tstamp) end subroutine MOM_write_field_legacy_0d @@ -2705,7 +2789,7 @@ 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) + 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 @@ -2722,6 +2806,8 @@ subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, ti !! 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] @@ -2732,13 +2818,13 @@ subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, ti 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 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) - 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 IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) @@ -2747,7 +2833,7 @@ end subroutine MOM_write_field_4d !> Write a 3d field to an output file, potentially with rotation subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale, unscale) + 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 @@ -2764,6 +2850,8 @@ subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, ti !! 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] @@ -2774,13 +2862,13 @@ subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, ti 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 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) - 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 IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) @@ -2789,7 +2877,7 @@ end subroutine MOM_write_field_3d !> Write a 2d field to an output file, potentially with rotation subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale, unscale) + 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 @@ -2806,6 +2894,8 @@ subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, ti !! 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] @@ -2816,13 +2906,13 @@ subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, ti 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 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) - 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 IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) @@ -2830,7 +2920,7 @@ subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, ti end subroutine MOM_write_field_2d !> Write a 1d field to an output file -subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale) +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] @@ -2844,16 +2934,21 @@ subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, sc !! 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 - if (scale_fac == 1.0) then + 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))) @@ -2861,13 +2956,16 @@ 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 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) +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] @@ -2881,6 +2979,8 @@ subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, sc !! 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] @@ -2892,6 +2992,7 @@ subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, sc 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 diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index 261d4b628d..682f967099 100644 --- a/src/framework/MOM_io_file.F90 +++ b/src/framework/MOM_io_file.F90 @@ -128,6 +128,8 @@ module MOM_io_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 @@ -454,7 +456,7 @@ 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) result(field) + 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 @@ -473,6 +475,8 @@ function i_register_field(handle, axes, label, units, longname, & !< 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 @@ -1011,7 +1015,7 @@ 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) result(field) + 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 @@ -1029,6 +1033,8 @@ function register_field_infra(handle, axes, label, units, longname, pack, & !< 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 @@ -1047,6 +1053,7 @@ function register_field_infra(handle, axes, label, units, longname, pack, & 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 @@ -1069,10 +1076,19 @@ subroutine write_field_4d_infra(handle, field_md, MOM_domain, field, tstamp, & !< 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) - call write_field(handle%handle_infra, field_infra, MOM_domain, field, & - tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + 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 @@ -1086,7 +1102,7 @@ subroutine write_field_3d_infra(handle, field_md, MOM_domain, field, tstamp, & type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition real, intent(inout) :: field(:,:,:) - !< Field to write + !< 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 @@ -1095,10 +1111,20 @@ subroutine write_field_3d_infra(handle, field_md, MOM_domain, field, tstamp, & !< 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) - call write_field(handle%handle_infra, field_infra, MOM_domain, field, & - tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + 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 @@ -1121,10 +1147,19 @@ subroutine write_field_2d_infra(handle, field_md, MOM_domain, field, tstamp, & !< 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) - call write_field(handle%handle_infra, field_infra, MOM_domain, field, & - tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + 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 @@ -1140,9 +1175,17 @@ subroutine write_field_1d_infra(handle, field_md, field, 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) - call write_field(handle%handle_infra, field_infra, field, tstamp=tstamp) + 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 @@ -1158,9 +1201,11 @@ subroutine write_field_0d_infra(handle, field_md, field, 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) - call write_field(handle%handle_infra, field_infra, field, tstamp=tstamp) + unscaled_field = field_md%conversion*field + call write_field(handle%handle_infra, field_infra, unscaled_field, tstamp=tstamp) end subroutine write_field_0d_infra @@ -1403,7 +1448,7 @@ 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) result(field) + 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(:) @@ -1421,6 +1466,8 @@ function register_field_nc(handle, axes, label, units, longname, pack, & !< 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 @@ -1438,6 +1485,7 @@ function register_field_nc(handle, axes, label, units, longname, pack, & 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 @@ -1475,11 +1523,19 @@ subroutine write_field_4d_nc(handle, field_md, MOM_domain, field, tstamp, & !< 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) - call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + 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 @@ -1502,11 +1558,19 @@ subroutine write_field_3d_nc(handle, field_md, MOM_domain, field, tstamp, & !< 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) - call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + 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 @@ -1529,11 +1593,19 @@ subroutine write_field_2d_nc(handle, field_md, MOM_domain, field, tstamp, & !< 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) - call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + 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 @@ -1549,11 +1621,19 @@ subroutine write_field_1d_nc(handle, field_md, field, 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) - call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + 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 @@ -1569,11 +1649,13 @@ subroutine write_field_0d_nc(handle, field_md, field, 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) - call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + 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 diff --git a/src/framework/MOM_murmur_hash.F90 b/src/framework/MOM_murmur_hash.F90 new file mode 100644 index 0000000000..16283f61e3 --- /dev/null +++ b/src/framework/MOM_murmur_hash.F90 @@ -0,0 +1,251 @@ +!> 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_restart.F90 b/src/framework/MOM_restart.F90 index 8152564b4f..b99cd3f184 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -4,9 +4,10 @@ module MOM_restart ! This file is part of MOM6. See LICENSE.md for the license. use, intrinsic :: iso_fortran_env, only : int64 -use MOM_checksums, only : chksum => rotated_field_chksum +use MOM_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, FATAL, WARNING, NOTE, is_root_pe +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_MOM_file, file_exists @@ -24,6 +25,7 @@ module MOM_restart implicit none ; private public restart_init, restart_end, restore_state, register_restart_field +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 @@ -73,7 +75,7 @@ module MOM_restart 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 Adcroft reciprocal of this factor. + !! 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 @@ -100,6 +102,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 @@ -154,6 +167,17 @@ module MOM_restart 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 @@ -368,7 +392,7 @@ 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, conversion) + 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 @@ -379,22 +403,30 @@ subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & 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, conversion) - call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) + 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, conversion) - call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) + 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, conversion) + 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 @@ -405,22 +437,30 @@ subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & 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, conversion) - call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) + 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, conversion) - call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) + 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, conversion) + 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 @@ -431,18 +471,62 @@ subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & 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, conversion) - call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) + 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, conversion) - call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) + 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. @@ -1324,12 +1408,167 @@ 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(I8), " vs ", 3(I8))') 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 @@ -1361,14 +1600,17 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ 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=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. + character(len=256) :: mesg, var_name integer(kind=int64) :: check_val(CS%max_fields,1) - integer :: isL, ieL, jsL, jeL, pos - integer :: turns + 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 @@ -1380,6 +1622,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ "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 @@ -1424,11 +1667,11 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ 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, & + 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(hor_grid, z_grid, t_grid, G, nz) + 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 @@ -1464,41 +1707,46 @@ 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(I8))') isL, ieL, jsL, jeL + elseif (pos == CORNER) then + write(mesg, '(" is in CORNER position, checksum range ",4(I8))') isL, ieL, jsL, jeL + elseif (pos == NORTH_FACE) then + write(mesg, '(" is in NORTH_FACE position, checksum range ",4(I8))') isL, ieL, jsL, jeL + elseif (pos == EAST_FACE) then + write(mesg, '(" is in EAST_FACE position, checksum range ",4(I8))') isL, ieL, jsL, jeL + else + write(mesg, '(" is in another position, ",I4,", checksum range ",4(I8))') 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(conv*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(conv*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(conv*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(conv*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(conv*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 @@ -1513,19 +1761,24 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,next_var-1 if (associated(CS%var_ptr3d(m)%p)) then call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr3d(m)%p, & - restart_time, unscale=CS%restart_field(m)%conv, turns=-turns) + 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, unscale=CS%restart_field(m)%conv, turns=-turns) + 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, unscale=CS%restart_field(m)%conv, turns=-turns) + 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, unscale=CS%restart_field(m)%conv) + 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, unscale=CS%restart_field(m)%conv) + restart_time, unscale=CS%restart_field(m)%conv, & + zero_zeros=CS%unsigned_zeros) endif enddo @@ -1566,7 +1819,6 @@ subroutine restore_state(filename, directory, day, G, CS) 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 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(:) @@ -1648,24 +1900,15 @@ 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 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 - call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + 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 IO_handles(n)%get_field_atts(fields(i), name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then @@ -1681,41 +1924,42 @@ subroutine restore_state(filename, directory, day, G, CS) ! 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, scale=scale, MOM_Domain=G%Domain) - if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr1d(m)%p(:)) + 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, scale=scale, MOM_Domain=G%Domain) - if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + 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, scale=scale) + 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(conv*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, scale=scale) + 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(conv*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, scale=scale, global_file=unit_is_global(n)) + 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(conv*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 @@ -1759,6 +2003,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 @@ -2022,8 +2268,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.) @@ -2054,6 +2304,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, & @@ -2150,9 +2413,11 @@ subroutine restart_error(CS) 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 @@ -2165,20 +2430,24 @@ 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 @@ -2189,7 +2458,7 @@ function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_z) result(var_s 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_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 868352102e..8b4f9266a8 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -47,6 +47,7 @@ module MOM_unit_scaling 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] @@ -224,6 +225,8 @@ subroutine set_unit_scaling_combos(US) ! 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 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..0947ed3141 --- /dev/null +++ b/src/framework/numerical_testing_type.F90 @@ -0,0 +1,371 @@ +!> A simple type for keeping track of numerical tests +module numerical_testing_type + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public testing +public testing_type_unit_test + +!> 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 testing_type_unit_test(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(testing) :: test ! The instance to be tested + logical :: tmpflag ! Temporary for return flags + + testing_type_unit_test = .false. ! Assume all is well at the outset + if (verbose) write(test%stdout,*) " ===== testing_type: testing_type_unit_test ============" + + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + call test%set( stderr=0 ) ! Sets stderr + 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 + + call test%test( .false., "This should pass" ) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => test(F) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%test( .true., "This should fail but be ignored", ignore=.true. ) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => test(T,ignore) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%real_scalar(1., 1., "s == s should pass", robits=0, tol=0.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => real(s,s) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%real_scalar(1., 2., "s != t but ignored", ignore=.true.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => real(s,t,ignore) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%real_arr(2, (/1.,2./), (/1.,2./), "a == a should pass", robits=0, tol=0.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => real(a,a) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%real_arr(2, (/1.,2./), (/3.,4./), "a != b but ignored", ignore=.true.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => real(a,b,ignore) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%int_arr(2, (/1,2/), (/1,2/), "i == i should pass") + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => int(a,a) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%int_arr(2, (/1,2/), (/3,4/), "i != j but ignored", ignore=.true.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => int(a,b,ignore) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + tmpflag = test%summarize("This summary is for a passing state") + if (verbose .and. .not. tmpflag) then + write(test%stdout,*) " => summarize(F) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + ! This following all fail + test%state = .false. ! reset + call test%test( .true., "This should fail" ) + if (verbose .and. test%state) then + write(test%stdout,*) " => test(T) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + test%state = .false. ! reset + call test%real_scalar(1., 2., "s != t should fail") + if (verbose .and. test%state) then + write(test%stdout,*) " => real(s,t) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + test%state = .false. ! reset + call test%real_arr(2, (/1.,2./), (/3.,4./), "a != b and should fail") + if (verbose .and. test%state) then + write(test%stdout,*) " => real(a,b) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + test%state = .false. ! reset + call test%int_arr(2, (/1,2/), (/3,4/), "i != j and should fail") + if (verbose .and. test%state) then + write(test%stdout,*) " => int(a,b) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + tmpflag = test%summarize("This summary should have 3 fails") + if (verbose .and. tmpflag) then + write(test%stdout,*) " => summarize(T) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + if (verbose .and. .not. testing_type_unit_test) write(test%stdout,*) "testing_type_unit_test passed" + +end function testing_type_unit_test + +!> \namespace numerical_testing_type +!! +end module numerical_testing_type diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index bac5b0fce9..2def8097ea 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -353,8 +353,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) character(len=160) :: mesg ! The text of an error message integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, ied, jed, it1, it3 - real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation [m3] - !for all ice sheets, Antarctica only, or Greenland only [m3] + real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation [Z L2 ~> m3] + !for all ice sheets, Antarctica only, or Greenland only [Z L2 ~> m3] if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") @@ -856,7 +856,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) - call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott) + 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) call cpu_clock_end(id_clock_shelf) @@ -874,16 +875,18 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) end subroutine shelf_calc_flux -subroutine integrate_over_ice_sheet_area(G, ISS, var, var_scale, var_out, hemisphere) +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) :: var_scale !< Dimensional scaling for variable to integrate [a A-1 ~> 1] - real, intent(out) :: var_out !< Variable integrated over the area of the ice sheet in arbitrary units [a m2] + 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 m2] + !! 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 @@ -903,16 +906,16 @@ subroutine integrate_over_ice_sheet_area(G, ISS, var, var_scale, var_out, hemisp 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) + mask(G%isc:G%iec,G%jsc:G%jec) = ISS%hmask(G%isc:G%iec,G%jsc:G%jec) endif var_cell(:,:)=0.0 do j = G%jsc,G%jec; do i = G%isc,G%iec - if (mask(i,j)>0) var_cell(i,j) = (var(i,j) * var_scale) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + 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) -end subroutine integrate_over_ice_sheet_area + 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 @@ -1139,9 +1142,9 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) ! 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 cell where the mass flux @@ -1252,10 +1255,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) 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%mass_handle, 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 @@ -1315,7 +1316,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) endif enddo ; enddo - balancing_area = global_area_integral(bal_frac, G, area=G%areaT) + balancing_area = global_area_integral(bal_frac, G, area=G%areaT, tmp_scale=1.0) if (balancing_area > 0.0) then balancing_flux = ( global_area_integral(ISS%water_flux, G, tmp_scale=US%RZ_T_to_kg_m2s, & area=ISS%area_shelf_h) + & @@ -1853,7 +1854,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 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, conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + .false., CS%restart_CSp, conversion=US%RLZ_T2_to_Pa) endif endif @@ -1875,7 +1876,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 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. @@ -1997,134 +2003,162 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 'Fric vel under shelf', 'm/s', conversion=US%Z_to_m*US%s_to_T) 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') - 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) + 'ice shelf thickness mask', 'none', conversion=1.0) endif - !scalars (area integrated over all ice sheets) + 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') + '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') + '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') + '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') + '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') + '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', 'm3') + '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', 'm3') + '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') + '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') + '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') + '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', 'm3 s-1') - CS%id_adot = register_scalar_field('ice_shelf_model', 'int_adot', CS%diag%axesT1, CS%Time, & - 'Area integrated rate of change in ice-sheet thickness due to surface accum+melt', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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') + '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') + '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') + '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') + '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') + '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', 'm3') + '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', 'm3') + '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') + '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') + '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') + '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', 'm3 s-1') - CS%id_Ant_adot = register_scalar_field('ice_shelf_model', 'int_adot_A', CS%diag%axesT1, CS%Time, & - 'Area integrated rate of change in Antarctic ice-sheet thickness due to surface accum+melt', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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') + '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') + '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') + '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') + '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') + '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', 'm3') + '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', 'm3') + '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') + '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') + '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') + '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', 'm3 s-1') - CS%id_Gr_adot = register_scalar_field('ice_shelf_model', 'int_adot_G', CS%diag%axesT1, CS%Time, & - 'Area integrated rate of change in Greenland ice-sheet thickness due to surface accum+melt', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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', 'm3 s-1') + '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. & @@ -2151,7 +2185,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 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 @@ -2324,8 +2357,8 @@ 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 +!! 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. @@ -2385,7 +2418,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 @@ -2396,15 +2429,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%mass_handle, 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. @@ -2525,7 +2553,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in ! coupled ice-ocean dynamics. integer :: is, ie, js, je, i, j real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation - !for all ice sheets, Antarctica only, or Greenland only [m3] + !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] @@ -2609,16 +2637,19 @@ end subroutine solo_step_ice_shelf !> Post_data calls for ice-sheet scalars subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real :: vaf0 !< The previous volumes above floatation for all ice sheets [m3] - real :: vaf0_A !< The previous volumes above floatation for the Antarctic ice sheet [m3] - real :: vaf0_G !< The previous volumes above floatation for the Greenland ice sheet [m3] + real :: 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 :: vaf ! The current ice-sheet volume above floatation [m3] + 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 @@ -2636,13 +2667,13 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh if (CS%id_vaf > 0) call post_scalar_data(CS%id_vaf ,vaf ,CS%diag) !current vaf if (CS%id_dvafdt > 0) call post_scalar_data(CS%id_dvafdt,(vaf-vaf0)*Itime_step,CS%diag) !d(vaf)/dt if (CS%id_adott > 0 .or. CS%id_adot > 0) then !surface accumulation - surface melt - call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val) + 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) - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + 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 @@ -2651,12 +2682,12 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie tmp(i,j) = dh_adott(i,j) - tmp(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + 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 - call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val) + 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 @@ -2665,7 +2696,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + 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 @@ -2674,22 +2705,22 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val) + 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; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) + 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 - tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + ones(:,:) = 1.0 ; call masked_var_grounded(G, CS%dCS, ones, tmp) if (CS%id_g_area > 0) then !grounded only ice sheet area - call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val) + 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) - call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val) + 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 @@ -2700,13 +2731,13 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh if (CS%id_Ant_vaf > 0) call post_scalar_data(CS%id_Ant_vaf ,vaf ,CS%diag) !current vaf if (CS%id_Ant_dvafdt > 0) call post_scalar_data(CS%id_Ant_dvafdt,(vaf-vaf0_A)*Itime_step,CS%diag) !d(vaf)/dt if (CS%id_Ant_adott > 0 .or. CS%id_Ant_adot > 0) then !surface accumulation - surface melt - call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val, hemisphere=0) + 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) - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + 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 @@ -2715,12 +2746,12 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie tmp(i,j) = dh_adott(i,j) - tmp(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + 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 - call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val, hemisphere=0) + 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 @@ -2729,7 +2760,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + 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 @@ -2738,22 +2769,22 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=0) + 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; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=0) + 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 - tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + 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 - call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=0) + 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) - call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val, hemisphere=0) + 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 @@ -2764,13 +2795,13 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh if (CS%id_Gr_vaf > 0) call post_scalar_data(CS%id_Gr_vaf ,vaf ,CS%diag) !current vaf if (CS%id_Gr_dvafdt > 0) call post_scalar_data(CS%id_Gr_dvafdt,(vaf-vaf0_A)*Itime_step,CS%diag) !d(vaf)/dt if (CS%id_Gr_adott > 0 .or. CS%id_Gr_adot > 0) then !surface accumulation - surface melt - call integrate_over_ice_sheet_area(G, ISS, dh_adott, US%Z_to_m, val, hemisphere=1) + 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) - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + 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 @@ -2779,12 +2810,12 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie tmp(i,j) = dh_adott(i,j) - tmp(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + 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 - call integrate_over_ice_sheet_area(G, ISS, dh_bdott, US%Z_to_m, val, hemisphere=1) + 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 @@ -2793,7 +2824,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + 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 @@ -2802,22 +2833,22 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh do j=js,je ; do i=is,ie if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) enddo; enddo - call integrate_over_ice_sheet_area(G, ISS, tmp, US%Z_to_m, val, hemisphere=1) + 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; call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=1) + 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 - tmp(:,:) = 1.0; call masked_var_grounded(G,CS%dCS,tmp,tmp) + 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 - call integrate_over_ice_sheet_area(G, ISS, tmp, 1.0, val, hemisphere=1) + 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) - call integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, 1.0, val, hemisphere=1) + 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 diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 5ecfb9e788..fe54dd6533 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -132,6 +132,7 @@ subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) G%x_axis_units = "degrees_E" ; G%y_axis_units = "degrees_N" G%x_ax_unit_short = "degrees_E" ; G%y_ax_unit_short = "degrees_N" + G%grid_unit_to_L = 0.0 if (index(lowercase(trim(grid_config)),"cartesian") > 0) then ! This is a cartesian grid, and may have different axis units. @@ -145,9 +146,11 @@ subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) 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" + G%grid_unit_to_L = 1000.0*diag_cs%US%m_to_L 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" + G%grid_unit_to_L = diag_cs%US%m_to_L endif call log_param(param_file, mdl, "explicit AXIS_UNITS", G%x_axis_units) else diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 9c7dda22de..9f50a77881 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -108,10 +108,10 @@ module MOM_ice_shelf_dynamics 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 L3 T-1 ~> kg s-1] + !! 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 (s m-1)^(n_basal_fric) + !! 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]. @@ -168,8 +168,8 @@ module MOM_ice_shelf_dynamics real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs !! i.e. dt <= CFL_factor * min(dx / u) [nondim] - real :: min_h_shelf !< The minimum ice thickness used during ice dynamics [L ~> m]. - real :: min_basal_traction !< The minimum basal traction for grounded ice (Pa m-1 s) [R L T-1 ~> kg m-2 s-1] + real :: 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]. @@ -177,7 +177,7 @@ module MOM_ice_shelf_dynamics 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 [Pa] + 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 @@ -358,8 +358,9 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) 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%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] - allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L3 T-1 ~> kg s-1] - allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (s m-1)^n_sliding] + 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) @@ -396,7 +397,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & "fractional degree of grounding", "nondim") call register_restart_field(CS%C_basal_friction, "C_basal_friction", .true., restart_CS, & - "basal sliding coefficients", "Pa (s m-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, & @@ -511,7 +512,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "MIN_H_SHELF", CS%min_h_shelf, & "min. ice thickness used during ice dynamics", & - units="m", default=0.,scale=US%m_to_L) + 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) @@ -536,7 +537,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 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, fail_if_missing=.false.) + 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.) @@ -838,7 +839,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & '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 s m-1', conversion=1e-6*US%RL2_T2_to_Pa/(365.0*86400.0*US%L_T_to_m_s)) + '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) @@ -1010,10 +1011,10 @@ subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state - real, intent(out) :: vaf !< area integrated volume above floatation [m3] + 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 [m3] + 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 @@ -1049,16 +1050,15 @@ subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere) if (mask(i,j)>0) then if (CS%bed_elev(i,j) <= 0) then !grounded above sea level - vaf_cell(i,j)= (ISS%h_shelf(i,j) * G%US%Z_to_m) * (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + 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) * G%US%Z_to_m) * & - (ISS%area_shelf_h(i,j) * G%US%L_to_m**2) + 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) + 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 @@ -1193,7 +1193,8 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, 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, mass_tot, KE_scale_factor, mass_scale_factor + 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 @@ -1243,24 +1244,22 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) 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 - KE_scale_factor = US%L_to_m**2 * (US%RZ_to_kg_m2 * US%L_T_to_m_s**2) + tmp1(:,:) = 0.0 do j=js,je ; do i=is,ie - tmp1(i,j) = (KE_scale_factor * 0.03125) * (mass(i,j) * area(i,j)) * & + 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) + 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 - mass_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 + tmp1(:,:) = 0.0 do j=js,je ; do i=is,ie - tmp1(i,j) = mass_scale_factor * (mass(i,j) * area(i,j)) + tmp1(i,j) = mass(i,j) * area(i,j) enddo; enddo - mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) + 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 @@ -1306,7 +1305,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) else ; write(n_str, '(I10)') 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), KE_tot/mass_tot, mass_tot + 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 @@ -1449,12 +1448,15 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. 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 ! Used for convergence + 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, nodefloat integer :: Isdq, Iedq, Jsdq, Jedq, isd, ied, jsd, jed integer :: Iscq, Iecq, Jscq, Jecq, isc, iec, jsc, jec - real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv, Norm, PrevNorm + real :: 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 :: 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] 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 @@ -1553,7 +1555,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call max_across_PEs(err_init) elseif (CS%nonlin_solve_err_mode == 3) then - Normvec=0.0 + 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) @@ -1570,11 +1572,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq - if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) - if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) + 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 = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) - Norm = sqrt(Norm) + 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(:,:) @@ -1662,14 +1663,13 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i err_init = max_vel elseif (CS%nonlin_solve_err_mode == 3) then - PrevNorm=Norm; Norm=0.0; Normvec=0.0 + 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 * US%L_T_to_m_s**2) - if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) + 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 = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) - Norm = sqrt(Norm) - err_max=2.*abs(Norm-PrevNorm); err_init=Norm+PrevNorm + 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 @@ -1797,7 +1797,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) Ru(:,:) = (RHSu(:,:) - Au(:,:)) ; Rv(:,:) = (RHSv(:,:) - Av(:,:)) - resid_scale = (US%L_to_m**2*US%s_to_T)*(US%RZ_to_kg_m2*US%L_T_to_m_s**2) + resid_scale = US%s_to_T*(US%RZL2_to_kg*US%L_T_to_m_s**2) resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 sum_vec(:,:) = 0.0 @@ -2642,7 +2642,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, !! relative to sea-level [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear - !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. + !! 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 @@ -2675,10 +2675,11 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt, qp, qpv logical :: visc_qp4 - real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell, Vcell, Hcell, Usub, Vsub - real, dimension(2,2,4) :: uret_qp, vret_qp - real, dimension(SZDIB_(G),SZDJB_(G),4) :: uret_b, vret_b + 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)) @@ -3316,9 +3317,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (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) + 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. elseif (model_qp4) then !calculate viscosity at 4 quadrature points per cell @@ -3347,9 +3348,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (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) + 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. enddo; enddo endif endif @@ -3376,12 +3377,13 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js - real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] - real :: alpha !Coulomb coefficient [nondim] + 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 [Pa] + 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 :: fN_scale !To convert effective pressure to mks units during Coulomb friction [Pa T2 R-1 L-2 ~> 1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -3399,7 +3401,6 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) else alpha = 1.0 endif - fN_scale = US%R_to_kg_m3 * US%L_T_to_m_s**2 endif do j=jsd+1,jed @@ -3413,16 +3414,16 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) if (CS%CoulombFriction) then !Effective pressure Hf = max((CS%density_ocean_avg/CS%density_ice) * CS%bed_elev(i,j), 0.0) - fN = max(fN_scale*((CS%density_ice * CS%g_Earth) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) - Hf)),CS%CF_MinN) + 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) CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * & - (unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric))) * & - (US%Pa_to_RLZ_T2*US%L_T_to_m_s) + (unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(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) CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * & - (US%Pa_to_RLZ_T2*US%L_T_to_m_s) + 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)) @@ -3942,7 +3943,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node, min_h_shelf) real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - real, intent(in) :: min_h_shelf !< The minimum ice thickness used during ice dynamics [L ~> m]. + 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, ic, jc real :: h_arr(2,2) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index f976187c2b..ec24aef2d0 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -321,7 +321,7 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b 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) !### This conversion factor is wrong? + 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) @@ -557,11 +557,13 @@ 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 + !! 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 @@ -574,7 +576,7 @@ 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 (s m-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 elseif (trim(config)=="FILE") then @@ -595,7 +597,7 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) 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 @@ -660,11 +662,11 @@ end subroutine initialize_ice_AGlen 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 [kg m-2 s-1] + 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 [kg m-2 s-1] + 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 diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index ef78a896c3..705cfc8b8d 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -84,7 +84,7 @@ 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) @@ -102,7 +102,6 @@ subroutine set_grid_metrics(G, param_file, US) 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") @@ -176,7 +175,8 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) 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 or longitudes [degN] or [degE] + 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" @@ -251,6 +251,11 @@ 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, scale=US%m_to_L) @@ -440,9 +445,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. diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 2197fdf038..9a4be62fc2 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -485,7 +485,6 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) 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_N] or [km] or [m] - real :: Rad_Earth_L ! The radius of the planet in rescaled units [L ~> m] real :: y_scl ! A scaling factor from the units of latitude [L lat-1 ~> m lat-1] 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. @@ -503,18 +502,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 @@ -1313,24 +1310,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 ! Masked and unscaled cell areas [m2] - 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 ! ----------------------------------------------------------------------------- diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4b9ba5ceef..ded9557d97 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -29,8 +29,8 @@ module MOM_state_initialization use MOM_open_boundary, only : update_OBC_segment_data !use MOM_open_boundary, only : set_3D_OBC_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics -use MOM_restart, only : restore_state, is_new_run, MOM_restart_CS -use MOM_restart, only : restart_registry_lock +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 @@ -161,7 +161,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & real :: dt ! The baroclinic dynamics timestep for this run [T ~> s]. logical :: from_Z_file, useALE - logical :: new_sim + logical :: new_sim, rotate_index logical :: use_temperature, use_sponge, use_OBC, use_oda_incupd logical :: verify_restart_time logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. @@ -278,6 +278,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \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"//& @@ -318,6 +319,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & just_read=just_read) case ("list"); call initialize_thickness_list(dz, depth_tot, G, GV, US, PF, & just_read=just_read) + 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(dz, depth_tot, G, GV, US, PF, tv, & @@ -543,6 +546,18 @@ 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 + 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 if ( use_temperature ) then @@ -1014,6 +1029,68 @@ subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_r call callTree_leave(trim(mdl)//'()') end subroutine initialize_thickness_list +!> 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(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 + 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 + + 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. + + e0(nz+1) = -G%max_depth + do k=nz, 1, -1 + e0(K) = e0(K+1) + dz(k) + 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 + + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_thickness_param + !> 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") @@ -1143,6 +1220,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) ! 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, & @@ -1165,7 +1243,10 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) "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) @@ -1215,7 +1296,8 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) do j=G%jsc,G%jec ; do i=G%isc,G%iec call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j)+G%Z_ref, min_thickness, & tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), & - p_surf(i,j), h(i,j,:), remap_CS, z_tol=z_tolerance) + 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 @@ -1306,7 +1388,7 @@ end subroutine calc_sfc_displacement !> Adjust the layer thicknesses by removing the top of the water column above the !! depth where the hydrostatic pressure matches p_surf subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, T_t, T_b, & - S, S_t, S_b, p_surf, h, remap_CS, z_tol) + 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. @@ -1326,6 +1408,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, !! if associated real, intent(in) :: z_tol !< The tolerance with which to find the depth !! matching the specified pressure [Z ~> m]. + 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 positions for reconstructions [Z ~> m] @@ -1354,7 +1437,8 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, 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) + 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 @@ -1570,7 +1654,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) @@ -1597,7 +1684,7 @@ real function my_psi(ig,jg) r = sqrt( (x**2) + (y**2) ) ! Circular stream function is a function of radius only r = min(1.0, r) ! Flatten stream function in corners of box my_psi = 0.5*(1.0 - cos(dpi*r)) - my_psi = my_psi * (circular_max_u * G%US%m_to_L*G%len_lon*1e3 / dpi) ! len_lon is in km + my_psi = my_psi * (circular_max_u * G%len_lon * G%grid_unit_to_L / dpi) ! len_lon is in km end function my_psi end subroutine initialize_velocity_circular @@ -2357,26 +2444,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 ! Masked and unscaled areas for sums [m2] - real :: area_scale ! A conversion factor to prepare for reproducing sums [m2 L-2 ~> 1] - 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) @@ -2595,10 +2662,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + call get_param(PF, mdl, "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=.true.) + "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_ANSWER_DATE", hor_regrid_answer_date, & @@ -2899,8 +2968,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just if (homogenize) then ! Horizontally homogenize data to produce perfectly "flat" initial conditions do k=1,nz - call homogenize_field(tv%T(:,:,k), G%mask2dT, G, scale=US%degC_to_C, answer_date=hor_regrid_answer_date) - call homogenize_field(tv%S(:,:,k), G%mask2dT, G, scale=US%ppt_to_S, answer_date=hor_regrid_answer_date) + 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 @@ -3110,7 +3179,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, z_tol=z_tol) + 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 @@ -3129,7 +3199,8 @@ subroutine MOM_state_init_tests(G, GV, US, tv) ! 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) + 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) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 515a4150f9..b100e0bf1c 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -142,10 +142,12 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(PF, mdl, "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=.true.) + "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_ANSWER_DATE", hor_regrid_answer_date, & diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index d620962222..4826477ad8 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -675,9 +675,9 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) integer :: i, j integer :: isc, iec, jsc, jec real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_tend_inc !< an adjustment to the temperature - !! tendency [C T-1 -> degC s-1] + !! 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] + !! 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 diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 360f9f3c02..24a637bfae 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -273,7 +273,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (allocated(MEKE%mom_src)) & call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%mom_src_bh)) & - call hchksum(MEKE%mom_src_bh, 'MEKE mom_src_bh', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + 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, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GM_src)) & @@ -856,13 +856,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h 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 + 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, CS, SIZE(h), Time, features_array, MEKE%MEKE) + 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 @@ -1011,7 +1011,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m 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 :: h_neglect ! A negligible thickness [H ~> m or kg m-2] integer :: i, j, is, ie, js, je, n1, n2 @@ -1781,7 +1781,7 @@ subroutine ML_MEKE_init(diag, G, US, Time, param_file, dbcomms_CS, CS) "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%L_T_to_m_s**2) + units="m2 s-2", default=2., scale=US%m_s_to_L_T**2) ! Set the machine learning model if (dbcomms_CS%colocated) then @@ -1866,22 +1866,22 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f ! 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 + 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; + 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 + 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 + 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 + 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 @@ -1911,7 +1911,7 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f 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 + enddo ; enddo call pass_var(slope_z, G%Domain) ! Calculate relative vorticity @@ -1920,11 +1920,11 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f 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 + enddo ; enddo ! Interpolate RV to t-point, revisit this calculation to include metrics - do j=js,je; do i=is,ie + 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 + enddo ; enddo ! Construct the feature array @@ -1941,8 +1941,9 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f end subroutine ML_MEKE_calculate_features !> Use the machine learning interface to predict EKE -subroutine predict_MEKE(G, CS, npts, Time, features_array, MEKE) +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 @@ -1952,13 +1953,18 @@ subroutine predict_MEKE(G, CS, npts, Time, features_array, MEKE) !! 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 eddy kinetic - ! energy [L2 T-2 ~> m2 s-2] - + 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) @@ -1978,21 +1984,30 @@ subroutine predict_MEKE(G, CS, npts, Time, features_array, MEKE) db_return_code = CS%client%unpack_tensor( model_out(1), MEKE_vec, shape(MEKE_vec) ) call cpu_clock_end(CS%id_unpack_tensor) - !### Does MEKE_vec need to be rescaled from [m2 s-2] to [L2 T-2 ~> m2 s-2] by - ! multiplying MEKE_vec by US%m_s_to_L_T**2 here? - MEKE = reshape(MEKE_vec, shape(MEKE)) - do j=js,je; do i=is,ie - MEKE(i,j) = MIN(MAX(exp(MEKE(i,j)),0.),CS%eke_max) - enddo; enddo - call pass_var(MEKE,G%Domain) + 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, shape(MEKE)) + 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 +!> 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] @@ -2034,7 +2049,7 @@ subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) 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) diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index 38bdd72452..e277036716 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -24,7 +24,7 @@ module MOM_MEKE_types !! backscatter from unresolved eddies (see Jansen and Held, 2014). real, allocatable :: Au(:,:) !< The MEKE-derived lateral biharmonic viscosity !! coefficient [L4 T-1 ~> m4 s-1]. - real, allocatable :: Le(:,:) !< Eddy length scale [L m] + real, allocatable :: Le(:,:) !< Eddy length scale [L ~> m] ! Parameters real :: KhTh_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTh [nondim] diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 056dcb7a15..f6e45cffb0 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -327,8 +327,8 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, ! 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_bh, & ! depth integrated energy dissipated by biharmonic 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] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] @@ -389,9 +389,9 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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] dz, & ! Height change across layers [Z ~> m] - FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] - FrictWork_bh, & ! work done by the biharmonic MKE dissipation mechanisms [R L2 T-3 ~> W m-2] - FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] + 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]. @@ -539,7 +539,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, endif ! Set the halo sizes used for the thickness-point viscosities. - if (CS%use_Leithy) then + 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 @@ -1519,8 +1519,6 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, 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 @@ -1624,40 +1622,55 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, ! 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) & + 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) - + if (legacy_bound) then ! Older method of bounding for stability - if (legacy_bound) & + do J=js-1,Jeq ; do I=is-1,Ieq Kh(I,J) = min(Kh(I,J), CS%Kh_Max_xy(I,J)) + enddo ; enddo + endif + 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 + + 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) - if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then - ! *Add* the MEKE contribution (might be negative) - if (use_kh_struct) then Kh(I,J) = Kh(I,J) + 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) * meke_res_fn - else - Kh(I,J) = Kh(I,J) + 0.25*( (MEKE%Ku(i,j) + & - MEKE%Ku(i+1,j+1)) + & + 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) + + Kh(I,J) = Kh(I,J) + 0.25 * ( & + (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + & (MEKE%Ku(i+1,j) + & MEKE%Ku(i,j+1)) ) * meke_res_fn - endif + enddo ; enddo endif + endif - 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) .and. (CS%better_bound_Ah)) then visc_bound_rem(I,J) = 1.0 @@ -1671,23 +1684,34 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, elseif (CS%better_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 - if (CS%use_Leithy) then + 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))) - end if + enddo ; enddo + end if - if (CS%id_Kh_q>0 .or. CS%debug) & + 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 - if ( .not. CS%use_Leithy) then + 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 @@ -1813,20 +1837,18 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, ! Backscatter using MEKE if (CS%EY24_EBT_BS) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + 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))) ) + (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)) ) + 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 @@ -2235,13 +2257,11 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (CS%debug) then if (CS%Laplacian) then - ! In symmetric memory mode, Kh_h should also be valid with a haloshift of 1. - call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, unscale=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 - ! In symmetric memory mode, Ah_h should also be valid with a haloshift of 1. - call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) + 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 endif @@ -3254,9 +3274,9 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) if (CS%EY24_EBT_BS) then CS%id_BS_coeff_h = register_diag_field('ocean_model', 'BS_coeff_h', diag%axesTL, Time, & - 'Backscatter coefficient at h points', 'm2 s-1') + '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', 'm2 s-1') + '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,& diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index c7101ac6b7..794de22636 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -106,19 +106,19 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:,:,:) :: TKE_slope_loss !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: TKE_input_glo_dt - !< The energy input to the internal waves * dt [H Z2 T-2 ~> m3 s-2 or J m-2]. + !< 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 - !< energy lost due to misc background processes * dt [H Z2 T-2 ~> m3 s-2 or J m-2] + !< 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 - !< energy lost due to quadratic bottom drag * dt [H Z2 T-2 ~> m3 s-2 or J m-2] + !< 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 - !< energy lost due to wave breaking [H Z2 T-2 ~> m3 s-2 or J m-2] + !< 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 T-2 ~> m3 s-2 or J m-2] + !< 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 T-2 ~> m3 s-2 or J m-2] + !< 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, @@ -147,13 +147,15 @@ module MOM_internal_tides !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 s-2] real :: q_itides !< fraction of local dissipation [nondim] real :: mixing_effic !< mixing efficiency [nondim] - real :: En_sum !< global sum of energy for use in debugging, in MKS units [H Z2 T-2 L2 ~> m5 s-2 or J] + real :: En_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. 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 [T-1 ~> s-1]. + 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 @@ -161,7 +163,7 @@ module MOM_internal_tides 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] + 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 @@ -174,16 +176,18 @@ module MOM_internal_tides !! 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 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_ini_glo(:,:) - !< The internal wave energy density as a function of (frequency,mode) - !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + !< 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) - !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + !< 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) @@ -324,17 +328,13 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C real :: en_subRO ! A tiny energy to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] real :: En_a, En_b ! Energies for time stepping [H Z2 T-2 ~> m3 s-2 or J m-2] real :: En_new, En_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] - real :: En_sumtmp ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_sumtmp ! Energies for debugging [H Z2 L2 T-2 ~> m5 s-2 or J] real :: En_initial, Delta_E_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [H Z2 T-3 ~> m3 s-3 or W m-2] - real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks - ! [H Z2 T-3 ~> m3 s-3 or W m-2] - real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks - ! [H Z2 T-2 ~> m3 s-2 or J m-2] - real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal - ! [m3 s-3 or W m-2 ~> H Z2 T-3] + real :: 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 - ! [m3 s-2 or J m-2 ~> H Z2 T-2] + ! units [H Z2 s2 T-2 kg-1 ~> m3 kg-1 or 1] character(len=160) :: mesg ! The text of an error message integer :: En_halo_ij_stencil ! The halo size needed for energy advection integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle @@ -346,9 +346,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle - HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) - W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) cn_subRO = 1e-30*US%m_s_to_L_T @@ -402,7 +400,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C do m=1,CS%nMode ; do fr=1,CS%nFreq En_sumtmp = 0. do a=1,CS%nAngle - En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, scale=HZ2_T2_to_J_m2) + 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 @@ -424,14 +422,14 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call pass_var(cn,G%Domain) if (CS%debug) then - call hchksum(cn(:,:,1), "CN mode 1", G%HI, haloshift=0, scale=US%L_to_m*US%s_to_T) + call hchksum(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, scale=US%m_to_Z) - call hchksum(CS%u_struct_bot(:,:,1), "Ustruct_bot mode 1", G%HI, haloshift=0, scale=US%m_to_Z) - call hchksum(CS%u_struct_max(:,:,1), "Ustruct_max mode 1", G%HI, haloshift=0, scale=US%m_to_Z) - call hchksum(CS%int_w2(:,:,1), "int_w2", G%HI, haloshift=0, scale=GV%H_to_MKS) - call hchksum(CS%int_U2(:,:,1), "int_U2", G%HI, haloshift=0, scale=GV%H_to_mks*US%m_to_Z**2) - call hchksum(CS%int_N2w2(:,:,1), "int_N2w2", G%HI, haloshift=0, scale=GV%H_to_mks*US%s_to_T**2) + 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.********************** @@ -449,8 +447,8 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C if (CS%debug) then call hchksum(TKE_itidal_input(:,:,1), "TKE_itidal_input", G%HI, haloshift=0, & - scale=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T)**3) - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides bf input", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -489,14 +487,14 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C if (CS%init_forcing_only) CS%add_tke_forcing=.false. if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af input", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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, scale=HZ2_T2_to_J_m2) + G, tmp_scale=HZ2_T2_to_J_m2) enddo CS%TKE_input_glo_dt(fr,m) = En_sumtmp enddo ; enddo @@ -508,7 +506,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call start_group_pass(pass_test, G%domain) if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -535,7 +533,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -546,7 +544,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C 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) + '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 @@ -565,7 +563,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo R", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -596,7 +594,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -608,7 +606,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset if (abs(CS%En(i,j,a,fr,m))>CS%En_check_tol) then ! only print if large write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', CS%En(i,j,a,fr,m) + '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.") @@ -638,7 +636,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -649,7 +647,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C 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) + '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 @@ -677,7 +675,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) En_b = CS%En(i,j,a,fr,m) ! save previous value - En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * CS%decay_rate)) ! implicit update + 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 @@ -694,7 +692,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after leak", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -707,7 +705,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C 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) + '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 @@ -718,7 +716,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C En_sumtmp = 0. do a=1,CS%nAngle En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_leak_loss(:,:,a,fr,m)*dt, G, & - scale=HZ2_T2_to_J_m2) + tmp_scale=HZ2_T2_to_J_m2) enddo CS%TKE_leak_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo @@ -754,8 +752,8 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C enddo ; enddo ; enddo ; enddo endif - if (CS%debug) call hchksum(drag_scale(:,:,1,1), "dragscale", G%HI, haloshift=0, scale=US%s_to_T) - if (CS%debug) call hchksum(tot_vel_btTide2(:,:), "tot_vel_btTide2", G%HI, haloshift=0, scale=US%L_T_to_m_s**2) + 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 @@ -778,13 +776,13 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after quad", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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, & - scale=HZ2_T2_to_J_m2) + tmp_scale=HZ2_T2_to_J_m2) enddo CS%TKE_quad_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo @@ -794,7 +792,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C 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) + '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 @@ -865,7 +863,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after wave", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -875,7 +873,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C En_sumtmp = 0. do a=1,CS%nAngle En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_itidal_loss(:,:,a,fr,m)*dt, G, & - scale=HZ2_T2_to_J_m2) + tmp_scale=HZ2_T2_to_J_m2) enddo CS%TKE_itidal_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo @@ -885,7 +883,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C 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) + '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 @@ -939,7 +937,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after froude", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -951,7 +949,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C En_sumtmp = 0. do a=1,CS%nAngle En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_Froude_loss(:,:,a,fr,m)*dt, G, & - scale=HZ2_T2_to_J_m2) + tmp_scale=HZ2_T2_to_J_m2) enddo CS%TKE_Froude_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo @@ -961,7 +959,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C 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) + '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 @@ -994,7 +992,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after slope", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + 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 @@ -1003,7 +1001,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C En_sumtmp = 0. do a=1,CS%nAngle En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_residual_loss(:,:,a,fr,m)*dt, G, & - scale=HZ2_T2_to_J_m2) + tmp_scale=HZ2_T2_to_J_m2) enddo CS%TKE_residual_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo @@ -1015,7 +1013,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C do m=1,CS%nMode ; do fr=1,CS%nFreq En_sumtmp = 0. do a=1,CS%nAngle - En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, scale=HZ2_T2_to_J_m2) + 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 @@ -1025,7 +1023,8 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C CS%TKE_quad_loss_glo_dt(fr,m) - CS%TKE_itidal_loss_glo_dt(fr,m) - & CS%TKE_Froude_loss_glo_dt(fr,m) - CS%TKE_residual_loss_glo_dt(fr,m) - & CS%En_end_glo(fr,m) - if (is_root_pe()) write(stdout,'(A,F18.10)') "error in Energy budget", CS%error_mode(fr,m) + 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 @@ -1215,16 +1214,16 @@ subroutine sum_En(G, GV, US, CS, En, label) intent(in) :: En !< The energy density of the internal tides [H Z2 T-2 ~> m3 s-2 or J m-2]. character(len=*), intent(in) :: label !< A label to use in error messages ! Local variables - real :: En_sum ! The total energy in MKS units for potential output [J] + 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 [J] + ! 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 ! The time in days for use in output messages [days] En_sum = 0.0 do a=1,CS%nAngle - En_sum = En_sum + global_area_integral(En(:,:,a), G, unscale=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T)**2) + 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 @@ -1282,13 +1281,12 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe real :: En_negl ! negligibly small number to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] real :: En_a, En_b ! energy before and after timestep [H Z2 T-2 ~> m3 s-2 or J m-2] real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] - real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal [m3 s-2 or J m-2 ~> H Z2 T-2] - real :: HZ2_T3_to_W_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + 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) - HZ2_T3_to_W_m2 = GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3) I_dt = 1.0 / dt q_itides = CS%q_itides @@ -1301,9 +1299,9 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe if (CS%debug) then call hchksum(TKE_loss_fixed, "TKE loss fixed", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2*(US%Z_to_m**3)*GV%m_to_H*(US%m_to_L**2)) - call hchksum(Nb(:,:), "Nbottom", G%HI, haloshift=0, scale=US%s_to_T) - call hchksum(Ub(:,:,1,1), "Ubottom", G%HI, haloshift=0, scale=US%L_to_m*US%s_to_T) + 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 @@ -1412,54 +1410,56 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 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] + !! [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] + !! [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] + !! [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] + !! [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] + !! [H-1 ~> m-1 or m2 kg-1] ! local variables - real :: TKE_loss ! temp variable to pass value of internal tides TKE loss [R Z-3 T-3 ~> W/m2] - real :: renorm_N ! renormalization for N profile [H T-1 ~> m s-1] - real :: renorm_N2 ! renormalization for N2 profile [H T-2 ~> m s-2] + real :: TKE_loss ! temp variable to pass value of internal tides TKE loss [R Z-3 T-3 ~> 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] - real :: htmp ! local value of thickness in layers [H ~> m] - real :: h_d ! expomential decay length scale [H ~> m] - real :: h_s ! expomential decay length scale on the slope [H ~> m] - real :: I_h_d ! inverse of expomential decay length scale [H-1 ~> m-1] - real :: I_h_s ! inverse of expomential decay length scale on the slope [H-1 ~> m-1] + real :: 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] - real, dimension(SZK_(GV)) :: profile_N2 ! vertical profile varying with N2 [H-1 ~> m-1] - real, dimension(SZK_(GV)) :: profile_StLaurent ! vertical profile according to St Laurent 2002 [H-1 ~> m-1] - real, dimension(SZK_(GV)) :: profile_StLaurent_slope ! vertical profile according to St Laurent 2002 [H-1 ~> m-1] - real, dimension(SZK_(GV)) :: profile_BBL ! vertical profile Heavyside BBL [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: 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] - real :: h_rmn ! Remaining thickness in k-loop [H ~> m] + 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 :: verif_N, & ! profile verification [nondim] verif_N2, & ! profile verification [nondim] verif_bbl, & ! profile verification [nondim] verif_stl1,& ! profile verification [nondim] verif_stl2,& ! profile verification [nondim] - threshold_renorm_N2,& ! Maximum allowable error on N2 profile [H T-2 ~> m.s-2] - threshold_renorm_N, & ! Maximum allowable error on N profile [H T-1 ~> m.s-1] + threshold_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 @@ -2082,6 +2082,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) 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, fr, m @@ -2106,6 +2107,8 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) Angle_size = (8.0*atan(1.0)) / real(NAngle) I_Angle_size = 1.0 / Angle_size + 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') @@ -2113,109 +2116,88 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) enddo ; enddo endif - 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%Coriolis2Bu(I,J) - speed(I,J) = 0.25*((cn(i,j) + cn(i+1,j+1)) + (cn(i+1,j) + cn(i,j+1))) * & - sqrt(max(freq2 - f2, 0.0)) * Ifreq - enddo ; enddo - - call pass_var(speed, G%Domain) - - do a=1,na - ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. - LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie - 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 + ! 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 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 + 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 - speed_x(:,:) = 0. - do j=jsh,jeh ; do I=ish-1,ieh - f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I,J-1)) - speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & - sqrt(max(freq2 - f2, 0.0)) * Ifreq - enddo ; enddo + speed_x(:,:) = 0. + do j=jsh,jeh ; do I=ish-1,ieh + f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I,J-1)) + speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & + sqrt(max(freq2 - f2, 0.0)) * Ifreq + enddo ; enddo - speed_y(:,:) = 0. - do J=jsh-1,jeh ; do i=ish,ieh - f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J)) - speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & - sqrt(max(freq2 - f2, 0.0)) * Ifreq - enddo ; enddo + speed_y(:,:) = 0. + do J=jsh-1,jeh ; do i=ish,ieh + f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J)) + speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & + sqrt(max(freq2 - f2, 0.0)) * Ifreq + enddo ; enddo - call pass_vector(speed_x, speed_y, G%Domain, stagger=CGRID_NE) - call pass_var(En, G%domain) + call pass_vector(speed_x, speed_y, G%Domain, stagger=CGRID_NE) + call pass_var(En, G%domain) - ! Apply propagation in x-direction (reflection included) - LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh + ! 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) + else + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) + 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 + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo - if (CS%debug) then - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_x') - if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after propagate_x', CS%En_sum - enddo ; enddo - endif + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_x') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after propagate_x', CS%En_sum + enddo ; enddo + endif - ! Update halos - call pass_var(En, G%domain) - call pass_var(residual_loss, G%domain) + ! Update halos + call pass_var(En, G%domain) + call pass_var(residual_loss, G%domain) - if (CS%debug) then - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after halo update') - if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after halo update', CS%En_sum - enddo ; enddo - endif - ! Apply propagation in y-direction (reflection included) - ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport - LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh + 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) + else + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) + 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 - - call pass_var(En, G%domain) - call pass_var(residual_loss, G%domain) - - if (CS%debug) then - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_y') - if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after propagate_y', CS%En_sum - enddo ; enddo - endif + ! 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 - endif + call pass_var(En, G%domain) + call pass_var(residual_loss, G%domain) if (CS%debug) then do m=1,CS%nMode ; do fr=1,CS%Nfreq @@ -2226,296 +2208,6 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) end subroutine propagate -!> 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 [H Z2 T-2 ~> m3 s-2 or J m-2]. - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed), & - intent(in) :: speed !< The magnitude of the group velocity at the cell - !! corner points [L T-1 ~> m s-1]. - 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 structure - type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. - ! Local variables - integer :: i, j, ish, ieh, jsh, jeh, m - real :: TwoPi ! The radius of the circumference of a circle to its radius [nondim] - real :: Angle_size ! The size of each angular wedge [radians] - real :: energized_angle ! angle through center of current wedge [radians] - real :: theta ! angle at edge of each sub-wedge [radians] - real :: Nsubrays ! number of sub-rays for averaging [nondim] - ! 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 [nondim] - real :: cos_thetaDT, sin_thetaDT ! cos(theta)*dt, sin(theta)*dt [T ~> s] - real :: xNE, xNW, xSW, xSE ! corner point x-coordinates of advected fluid parcel [L ~> m] - real :: yNE, yNW, ySW, ySE ! corner point y-coordinates of advected fluid parcel [L ~> m] - real :: CFL_xNE, CFL_xNW, CFL_xSW, CFL_xSE ! Various x-direction CFL numbers for propagation [nondim] - real :: CFL_yNE, CFL_yNW, CFL_ySW, CFL_ySE ! Various y-direction CFL numbers for propagation [nondim] - real :: CFL_max ! The maximum of the x- and y-CFL numbers for propagation [nondim] - real :: xN, xS, xE, xW ! intersection point x-coordinates of parcel edges and grid [L ~> m] - real :: yN, yS, yE, yW ! intersection point y-coordinates of parcel edges and grid [L ~> m] - real :: xCrn, yCrn ! Coordinates of grid point contained within advected fluid parcel [L ~> m] - real :: xg, yg ! Positions of grid point of interest [L ~> m] - real :: slopeN, slopeW, slopeS, slopeE ! Coordinate-space slopes of parcel sides [nondim] - real :: bN, bW, bS, bE ! parameters defining parcel sides [L ~> m] - real :: aNE, aN, aNW, aW, aSW, aS, aSE, aE, aC ! sub-areas of advected parcel [L2 ~> m2] - real :: a_total ! total area of advected parcel [L2 ~> m2] - ! real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel [L2 ~> m2] - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x, y ! coordinates of cell corners [L ~> m] - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx, Idy ! inverse of dx,dy at cell corners [L-1 ~> m-1] - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx, dy ! dx,dy at cell corners [L ~> m] - real, dimension(2) :: E_new ! Energy in cell after advection for subray [H Z2 T-2 ~> m3 s-2 or J m-2]; set size - ! here to define Nsubrays - this should be made an input option later! - - ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh - 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 - - 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 - - ! 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 - - ! 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 - aW = 0.5 * (((yCrn - yNW)*(xW - xN)) + ((xCrn - xNW)*(yN - yW))) - ! 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 - aSW = 0.5 * (((yCrn - ySW)*(xS - xW)) + ((xCrn - xSW)*(yW - yS))) - ! 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 - aS = 0.5 * (((yCrn - ySE)*(xE - xS)) + ((xCrn - xSE)*(yS - yE))) - ! 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 - aC = 0.5 * (((yCrn - yNE)*(xN - xE)) + ((xCrn - xNE)*(yE - yN))) - 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 - aS = 0.5 * (((yCrn - ySW)*(xS - xW)) + ((xCrn - xSW)*(yW - yS))) - ! 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 - aSE = 0.5 * (((yCrn - ySE)*(xE - xS)) + ((xCrn - xSE)*(yS - yE))) - ! 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 - aE = 0.5 * (((yCrn - yNE)*(xN - xE)) + ((xCrn - xNE)*(yE - yN))) - ! 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 - aC = 0.5 * (((yCrn - yNW)*(xW - xN)) + ((xCrn - xNW)*(yN - yW))) - 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 - aE = 0.5 * (((yCrn - ySE)*(xE - xS)) + ((xCrn - xSE)*(yS - yE))) - ! 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 - aNE = 0.5 * (((yCrn - yNE)*(xN - xE)) + ((xCrn - xNE)*(yE - yN))) - ! 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 - aN = 0.5 * (((yCrn - yNW)*(xW - xN)) + ((xCrn - xNW)*(yN - yW))) - ! 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 - aC = 0.5 * (((yCrn - ySW)*(xS - xW)) + ((xCrn - xSW)*(yW - yS))) - 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 - aN = 0.5 * (((yCrn - yNE)*(xN - xE)) + ((xCrn - xNE)*(yE - yN))) - ! 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 - aNW = 0.5 * (((yCrn - yNW)*(xW - xN)) + ((xCrn - xNW)*(yN - yW))) - ! 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 - aW = 0.5 * (((yCrn - ySW)*(xS - xW)) + ((xCrn - xSW)*(yW - yS))) - ! 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 - aC = 0.5 * (((yCrn - ySE)*(xE - xS)) + ((xCrn - xSE)*(yS - yE))) - endif - - ! energy weighting ---------------------------------------- - a_total = (((aNE + aSW) + (aNW + aSE)) + ((aN + aS) + (aW + aE))) + aC - - E_new(m) = ( ( ( ( (aNE*En(i+1,j+1)) + (aSW*En(i-1,j-1)) ) + & - ( (aNW*En(i-1,j+1)) + (aSE*En(i+1,j-1)) ) ) + & - ( ( (aN*En(i,j+1)) + (aS*En(i,j-1)) ) + & - ( (aW*En(i-1,j)) + (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, residual_loss) @@ -2867,7 +2559,7 @@ 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 @@ -3281,14 +2973,14 @@ subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_CS) default=.true., do_not_log=.true.) non_Bous = .not.(Boussinesq .or. semi_Boussinesq) - units="J m-2" - if (non_Bous) units="m3 s-2" + 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 + 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) @@ -3386,6 +3078,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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 [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 @@ -3395,10 +3090,12 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! nominal ocean depth, or a negative value for no limit [nondim] real :: period_1 ! The period of the gravest modeled mode [T ~> s] real :: period ! A tidal period read from namelist [T ~> s] - real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-2 ~> m3 s-2 or J m-2] - real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] - real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] - real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal [m3 s-2 or J m-2 ~> H Z2 T-2] + 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, nz type(axes_grp) :: axes_ang @@ -3411,7 +3108,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=200) :: filename character(len=200) :: refl_angle_file character(len=200) :: refl_pref_file, refl_dbl_file, trans_file - character(len=200) :: h2_file + character(len=200) :: h2_file, decay_file character(len=80) :: rough_var ! Input file variable names character(len=240), dimension(:), allocatable :: energy_fractions @@ -3422,7 +3119,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) - W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) CS%initialized = .true. @@ -3545,18 +3241,18 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=0.2) call get_param(param_file, mdl, "MAX_TKE_TO_KD", CS%max_TKE_to_Kd, & "Limiter for TKE_to_Kd.", & - units="", default=1e9, scale=US%Z_to_m*US%s_to_T**2) - call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & + 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. "//& @@ -3610,10 +3306,12 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "mode speeds are not calculated but are simply reported as 0. This must be "//& "non-negative for the wave_speeds routine to be used.", & units="m s-1", default=0.01, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "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=.true.) + "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) @@ -3677,6 +3375,32 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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, & @@ -4002,7 +3726,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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, '[]') + 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 diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 9078728f44..f2f476b0c8 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -557,9 +557,9 @@ subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] real, dimension(SZI_(G), SZJ_(G)) :: f ! Absolute value of the Coriolis parameter at h point [T-1 ~> s-1] real :: N2 ! Positive buoyancy frequency square or zero [L2 Z-2 T-2 ~> s-2] - real :: dzc ! Spacing between two adjacent layers in stretched vertical coordinate [m] + real :: 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 [m] + real, dimension(SZI_(G), SZJ_(G)) :: Le ! Eddy length scale [L ~> 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 @@ -1834,10 +1834,12 @@ 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 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=.true.) + "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, & diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index bb31255261..b578a57316 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -965,7 +965,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d / (f2_h * max(little_h(i,j), GV%Angstrom_H)) enddo ; enddo - ! Rescale from [Z2 H-1 to L] + ! 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) & @@ -1037,12 +1037,12 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 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 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 @@ -1059,24 +1059,24 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d !$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-3 - h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! H ~> m or kg m-3 - grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 - r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 - psi_mag = ( ( ( (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 + 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] + 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] + 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] @@ -1089,8 +1089,8 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 ] - uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k) * dt ! [ L2 H ] + 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 @@ -1100,28 +1100,28 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d !$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-3 - h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! H ~> m or kg m-3 - grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 - r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 - psi_mag = ( ( ( (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 + 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] + 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] + 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] + ! 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) @@ -1130,8 +1130,8 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 ] - vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k) * dt ! [ L2 H ] + 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 diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index f72b6f513e..5b2ba9bad1 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -1,16 +1,18 @@ 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 : read_param, get_param, log_version, param_file_type +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_io, only : slasher, MOM_read_data +use MOM_load_love_numbers, only : Love_Data use MOM_obsolete_params, only : obsolete_logical, obsolete_int -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type 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_load_love_numbers, only : Love_Data +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -27,12 +29,21 @@ module MOM_self_attr_load logical :: use_tidal_sal_prev = .false. !< If true, read the tidal SAL from the previous iteration of the tides to !! facilitate convergence. - real :: sal_scalar_value !< The constant of proportionality between sea surface height - !! (really it should be bottom pressure) anomalies and bottom - !! geopotential anomalies [nondim]. - type(sht_CS), allocatable :: sht !< Spherical harmonic transforms (SHT) control structure - integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] - real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nodim] + 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 :: ebot_ref(:,:) + !< Reference bottom pressure scaled by Rho_0 and G_Earth[Z ~> m] + 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 @@ -41,47 +52,54 @@ module MOM_self_attr_load contains -!> This subroutine calculates seawater self-attraction and loading based on sea surface height. This should -!! be changed into bottom pressure anomaly in the future. 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. +!> 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. + 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 [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from - !! self-attraction and loading [Z ~> m]. + !! 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] + 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 - real :: eta_prop ! The scalar constant of proportionality between eta and eta_sal [nondim] 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%ebot_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 - call scalar_SAL_sensitivity(CS, eta_prop) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_sal(i,j) = eta_prop*eta(i,j) + 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, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd, tmp_scale=tmp_scale) + 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) + 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 @@ -98,38 +116,36 @@ subroutine calc_SAL(eta, eta_sal, G, CS, tmp_scale) call cpu_clock_end(id_clock_SAL) end subroutine calc_SAL -!> This subroutine calculates the partial derivative of the local geopotential height with the input -!! sea surface height due to the scalar approximation of self-attraction and loading. +!> 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]. - - if (CS%use_sal_scalar .and. CS%use_tidal_sal_prev) then - deta_sal_deta = 2.0*CS%sal_scalar_value - elseif (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then - deta_sal_deta = CS%sal_scalar_value - else - deta_sal_deta = 0.0 - endif + 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(nlm, rhoW, rhoE, Love_Scaling) - integer, intent(in) :: nlm !< Maximum spherical harmonics degree [nondim] - 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, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] +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 + 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 " // & @@ -146,36 +162,46 @@ subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) 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(l+n-m) = (3.0 / real(2*n+1)) * (rhoW / rhoE) * (1.0 + KDat(n+1) - HDat(n+1)) + 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(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. +subroutine SAL_init(G, GV, US, param_file, CS) + type(ocean_grid_type), intent(inout) :: 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 ! 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 :: rhoW ! The average density of sea water [R ~> kg m-3]. real :: rhoE ! The average density of Earth [R ~> kg m-3]. + character(len=200) :: filename, ebot_ref_file, inputdir ! Strings for file/path + character(len=200) :: ebot_ref_varname ! Variable name in file + logical :: calculate_sal, tides, use_tidal_sal_file + integer :: tides_answer_date ! Recover old answers with tides + real :: sal_scalar_value ! Scaling SAL factors [nondim] + integer :: isd, ied, jsd, jed - logical :: calculate_sal - logical :: tides, use_tidal_sal_file - real :: tide_sal_scalar_value ! Scaling SAL factor [nondim] + 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, mdl, "CALCULATE_SAL", calculate_sal, "If true, calculate "//& - " self-attraction and loading.", default=tides, do_not_log=.True.) + call get_param(param_file, '', "CALCULATE_SAL", calculate_sal, default=tides, do_not_log=.True.) if (.not. calculate_sal) return if (tides) then @@ -183,23 +209,47 @@ subroutine SAL_init(G, US, param_file, CS) default=.false., do_not_log=.True.) call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", use_tidal_sal_file, & default=.false., do_not_log=.True.) + call get_param(param_file, '', "TIDES_ANSWER_DATE", tides_answer_date, & + default=20230630, do_not_log=.True.) endif + 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 correct for homogenous flow.", default=.False.) + if (CS%use_bpa) then + call get_param(param_file, '', "INPUTDIR", inputdir, default=".", do_not_log=.True.) + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "REF_BOT_PRES_FILE", ebot_ref_file, & + "Reference bottom pressure file used by self-attraction and loading (SAL).", & + default="pbot.nc") + call get_param(param_file, mdl, "REF_BOT_PRES_VARNAME", ebot_ref_varname, & + "The name of the variable in REF_BOT_PRES_FILE with reference bottom "//& + "pressure. The variable should have the unit of Pa.", & + default="pbot") + filename = trim(inputdir)//trim(ebot_ref_file) + call log_param(param_file, mdl, "INPUTDIR/REF_BOT_PRES_FILE", filename) + + allocate(CS%ebot_ref(isd:ied, jsd:jed), source=0.0) + call MOM_read_data(filename, trim(ebot_ref_varname), CS%ebot_ref, G%Domain,& + scale=US%Pa_to_RL2_T2) + call pass_var(CS%ebot_ref, G%Domain) + endif + 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, 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)) - call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & - units="m m-1", default=0.0, do_not_log=.True.) - if (tide_sal_scalar_value/=0.0) & - call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& - "Use SAL_SCALAR_VALUE instead." ) - call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & - "The constant of proportionality between sea surface "//& - "height (really it should be bottom pressure) anomalies "//& - "and bottom geopotential anomalies. This is only used if "//& - "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & - default=tide_sal_scalar_value, units="m m-1", & - do_not_log=(.not. CS%use_sal_scalar) .and. (.not. CS%use_tidal_sal_prev)) + 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, mdl, "SAL_HARMONICS", CS%use_sal_sht, & "If true, use the online spherical harmonics method to calculate "//& "self-attraction and loading.", default=.false.) @@ -207,20 +257,35 @@ subroutine SAL_init(G, US, param_file, CS) "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, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, & - units="kg m-3", do_not_log=.True.) 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)); CS%Snm_Re(:) = 0.0 - allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 + allocate(CS%Snm_Re(lmax), source=0.0) + allocate(CS%Snm_Im(lmax), source=0.0) - allocate(CS%Love_Scaling(lmax)); CS%Love_Scaling(:) = 0.0 - call calc_love_scaling(CS%sal_sht_Nd, rhoW, rhoE, CS%Love_Scaling) + 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) @@ -234,8 +299,11 @@ end subroutine SAL_init 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%ebot_ref)) deallocate(CS%ebot_ref) + if (CS%use_sal_sht) then - if (allocated(CS%Love_Scaling)) deallocate(CS%Love_Scaling) + 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) @@ -247,20 +315,20 @@ end subroutine SAL_end !! !! \section section_SAL Self attraction and loading !! -!! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height (SSH) -!! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or -!! storm surges, but the effect applies to all motions. +!! 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]. +!! 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]. +!! SAL. Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set +!! by SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across +!! Scales (MPAS)-Ocean developed by Los Alamos National Laboratory and University of Michigan +!! [\cite Barton2022 and \cite Brus2023]. !! !! References: !! diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 4f9cee03aa..7606ac3ce1 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -1,12 +1,12 @@ !> 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 -use MOM_coms_infra, only : sum_across_PEs -use MOM_coms, only : reproducing_sum implicit none ; private @@ -29,8 +29,6 @@ module MOM_spherical_harmonics 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]. - real, allocatable :: Snm_Re_raw(:,:,:), & !< Array to store un-summed SHT coefficients - Snm_Im_raw(:,:,:) !< at the t-cells for reproducing sums [same as input variable] logical :: reprod_sum !< True if use reproducible global sums end type sht_CS @@ -46,9 +44,13 @@ 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 [A] - real, intent(out) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) [A] - real, intent(out) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) [A] + 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 @@ -61,10 +63,13 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd, tmp_scale 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 :: scale ! A rescaling factor to temporarily convert var to MKS units during the - ! reproducing sums [a A-1 ~> 1] - real :: I_scale ! The inverse of scale [A a-1 ~> 1] - real :: sum_tot ! The total of all components output by the reproducing sum in arbitrary units [a] + 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 @@ -75,26 +80,27 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd, tmp_scale 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 + 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 + 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 + do l=1,Ltot ; Snm_Re(l) = 0.0 ; Snm_Im(l) = 0.0 ; enddo if (CS%reprod_sum) then - scale = 1.0 ; if (present(tmp_scale)) scale = tmp_scale + 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 - CS%Snm_Re_raw(i,j,l) = (scale*var(i,j)) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) - CS%Snm_Im_raw(i,j,l) = (scale*var(i,j)) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) + 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 @@ -102,8 +108,8 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd, tmp_scale 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) - CS%Snm_Re_raw(i,j,l+n-m) = (scale*var(i,j)) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) - CS%Snm_Im_raw(i,j,l+n-m) = (scale*var(i,j)) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) + 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 @@ -133,15 +139,9 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd, tmp_scale 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(CS%Snm_Re_raw(:,:,1:Ltot), sums=Snm_Re(1:Ltot)) - sum_tot = reproducing_sum(CS%Snm_Im_raw(:,:,1:Ltot), sums=Snm_Im(1:Ltot)) - if (scale /= 1.0) then - I_scale = 1.0 / scale - do l=1,Ltot - Snm_Re(l) = I_scale * Snm_Re(l) - Snm_Im(l) = I_scale * Snm_Im(l) - enddo - endif + 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) @@ -156,10 +156,13 @@ end subroutine spherical_harmonics_forward 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) [A] - real, intent(in) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) [A] + 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 [A] + 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 @@ -179,13 +182,13 @@ subroutine spherical_harmonics_inverse(G, CS, Snm_Re, Snm_Im, var, Nd) 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 + 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 + pmn(i,j) = 0.0 ; pmnm1(i,j) = 0.0 ; pmnm2(i,j) = 0.0 var(i,j) = 0.0 enddo ; enddo @@ -250,8 +253,8 @@ subroutine spherical_harmonics_init(G, param_file, CS) default=.False.) ! Calculate recurrence relationship coefficients - allocate(CS%a_recur(CS%ndegree+1, CS%ndegree+1)); CS%a_recur(:,:) = 0.0 - allocate(CS%b_recur(CS%ndegree+1, CS%ndegree+1)); CS%b_recur(:,:) = 0.0 + 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))) @@ -259,10 +262,10 @@ subroutine spherical_harmonics_init(G, param_file, CS) enddo ; enddo ! Calculate complex exponential factors - allocate(CS%cos_lonT_wtd(is:ie, js:je, CS%ndegree+1)); CS%cos_lonT_wtd(:,:,:) = 0.0 - allocate(CS%sin_lonT_wtd(is:ie, js:je, CS%ndegree+1)); CS%sin_lonT_wtd(:,:,:) = 0.0 - allocate(CS%cos_lonT(is:ie, js:je, CS%ndegree+1)); CS%cos_lonT(:,:,:) = 0.0 - allocate(CS%sin_lonT(is:ie, js:je, CS%ndegree+1)); CS%sin_lonT(:,:,:) = 0.0 + 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)) @@ -273,28 +276,23 @@ subroutine spherical_harmonics_init(G, param_file, CS) enddo ! Calculate sine and cosine of colatitude - allocate(CS%cos_clatT(is:ie, js:je)); CS%cos_clatT(:,:) = 0.0 + 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)); CS%Pmm(:,:,:) = 0.0 + 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 + 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 - if (CS%reprod_sum) then - allocate(CS%Snm_Re_raw(is:ie, js:je, CS%lmax)); CS%Snm_Re_raw = 0.0 - allocate(CS%Snm_Im_raw(is:ie, js:je, CS%lmax)); CS%Snm_Im_raw = 0.0 - endif - 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) @@ -310,8 +308,6 @@ subroutine spherical_harmonics_end(CS) 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) - if (CS%reprod_sum) & - deallocate(CS%Snm_Re_raw, CS%Snm_Im_raw) end subroutine spherical_harmonics_end !> Calculates the number of real elements (cosine) of spherical harmonics given maximum degree Nd. diff --git a/src/parameterizations/lateral/MOM_streaming_filter.F90 b/src/parameterizations/lateral/MOM_streaming_filter.F90 index a91f6661f2..7a8bc1b774 100644 --- a/src/parameterizations/lateral/MOM_streaming_filter.F90 +++ b/src/parameterizations/lateral/MOM_streaming_filter.F90 @@ -1,119 +1,209 @@ !> Streaming band-pass filter for detecting the instantaneous tidal signals in the simulation + module MOM_streaming_filter -use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL +use MOM_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_type_to_real use MOM_unit_scaling, only : unit_scale_type implicit none ; private -public Filt_register, Filt_accum +public Filt_register, Filt_init, Filt_accum #include -!> The control structure for storing the filter infomation of a particular field +!> Control structure for the MOM_streaming_filter module type, public :: Filter_CS ; private - real :: a, & !< Parameter that determines the bandwidth [nondim] - om, & !< Target frequency of the filter [T-1 ~> s-1] - old_time = -1.0 !< The time of the previous accumulating step [T ~> s] - real, allocatable, dimension(:,:) :: s1, & !< Dummy variable [A] - u1 !< Filtered data [A] + 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 each of the fields to be filtered. -subroutine Filt_register(a, om, grid, HI, CS) - real, intent(in) :: a !< Parameter that determines the bandwidth [nondim] - real, intent(in) :: om !< Target frequency of the filter [T-1 ~> s-1] - character(len=*), intent(in) :: grid !< Horizontal grid location: h, u, or v - type(hor_index_type), intent(in) :: HI !< Horizontal index type structure - type(Filter_CS), intent(out) :: CS !< Control structure for the current field +!> 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 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - if (a <= 0.0) call MOM_error(FATAL, "MOM_streaming_filter: bandwidth <= 0") - if (om <= 0.0) call MOM_error(FATAL, "MOM_streaming_filter: target frequency <= 0") - - CS%a = a - CS%om = om + type(axis_info) :: filter_axis(1) + real, dimension(:), allocatable :: n_filters !< Labels of filters [nondim] + integer :: c - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed - IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + CS%nf = nf + CS%key = key select case (trim(grid)) case ('h') - allocate(CS%s1(isd:ied,jsd:jed)) ; CS%s1(:,:) = 0.0 - allocate(CS%u1(isd:ied,jsd:jed)) ; CS%u1(:,:) = 0.0 - CS%is = isd ; CS%ie = ied ; CS%js = jsd ; CS%je = jed + CS%is = HI%isd ; CS%ie = HI%ied ; CS%js = HI%jsd ; CS%je = HI%jed case ('u') - allocate(CS%s1(IsdB:IedB,jsd:jed)) ; CS%s1(:,:) = 0.0 - allocate(CS%u1(IsdB:IedB,jsd:jed)) ; CS%u1(:,:) = 0.0 - CS%is = IsdB ; CS%ie = IedB ; CS%js = jsd ; CS%je = jed + CS%is = HI%IsdB ; CS%ie = HI%IedB ; CS%js = HI%jsd ; CS%je = HI%jed case ('v') - allocate(CS%s1(isd:ied,JsdB:JedB)) ; CS%s1(:,:) = 0.0 - allocate(CS%u1(isd:ied,JsdB:JedB)) ; CS%u1(:,:) = 0.0 - CS%is = isd ; CS%ie = ied ; CS%js = JsdB ; CS%je = JedB + 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 timesteps the filter equations. It takes model output u at the current time step as the input, -!! and returns tidal signal u1 as the output, which is the solution of a set of two ODEs (the filter equations). +!> 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 the MOM_streaming_filter module + 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, is, ie, js, je + integer :: i, j, k now = US%s_to_T * time_type_to_real(Time) - is = CS%is ; ie = CS%ie ; js = CS%js ; je = CS%je - ! Initialize u1 - if (CS%old_time < 0.0) then + ! 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 streaming_filter +!> \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". !! -!! This module detects instantaneous tidal signals in the model output using a set of coupled ODEs (the filter -!! equations), given the target frequency (om) and the bandwidth parameter (a) of the filter. At each timestep, -!! the filter takes model output (u) as the input and returns a time series consisting of sinusoidal motions (u1) -!! near its target frequency. The filtered tidal signals can be used to parameterize frequency-dependent drag, or -!! to detide the model output. See Xu & Zaron (2024) for detail. +!! 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. !! -!! Reference: Xu, C., & Zaron, E. D. (2024). Detecting instantaneous tidal signals in ocean models utilizing -!! streaming band-pass filters. Journal of Advances in Modeling Earth Systems. Under review. +!! 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 cfccf8bcfc..cf06be4ed2 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -60,7 +60,8 @@ module MOM_thickness_diffuse 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 squared buoyancy frequency in the Ferrari et al., 2010, - !! streamfunction formulation [T-2 ~> s-2]. + !! 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 @@ -743,10 +744,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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 :: 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 times rescaling - ! factors from depths to thicknesses [H2 L2 Z-3 T-2 ~> m s-2 or kg m-2 s-2] - real :: c2_dz_v(SZI_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at v-points times rescaling - ! factors from depths to thicknesses [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + 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 @@ -822,7 +821,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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 * US%Z_to_L**2 + N2_floor = CS%N2_floor use_EOS = associated(tv%eqn_of_state) present_slope_x = PRESENT(slope_x) @@ -2187,7 +2186,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) real :: omega ! The Earth's rotation rate [T-1 ~> s-1] real :: strat_floor ! A floor for buoyancy frequency in the Ferrari et al. 2010, ! streamfunction formulation, expressed as a fraction of planetary - ! rotation [nondim]. + ! 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 @@ -2322,7 +2321,7 @@ 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) + 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.) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 177becf84f..c19b7252f2 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -45,12 +45,12 @@ module MOM_tidal_forcing !! 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]. @@ -70,7 +70,9 @@ module MOM_tidal_forcing ampsal(:,:,:), & !< The amplitude of the SAL [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]. + 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 @@ -95,8 +97,8 @@ subroutine astro_longitudes_init(time_ref, longitudes) 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_type_to_real(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 @@ -151,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") @@ -246,21 +248,25 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) 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 [s-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. + 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 :: 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 logical :: HA_ssh, HA_ubt, HA_vbt ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. character(len=128) :: mesg character(len=200) :: tidal_input_files(4*MAX_CONSTITUENTS) - real :: tide_sal_scalar_value ! The constant of proportionality with the scalar approximation to SAL [nondim] 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 @@ -355,18 +361,13 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) "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, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & - units="m m-1", default=0.0, do_not_log=.True.) - if (tide_sal_scalar_value/=0.0) & - call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& - "Use SAL_SCALAR_VALUE instead." ) - call get_param(param_file, mdl, "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 "//& - "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & - default=tide_sal_scalar_value, units="m m-1", & - do_not_log=(.not. CS%use_tidal_sal_prev)) + 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, & @@ -385,14 +386,14 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) 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 ! Using a reference date but not using phase relative to equilibrium. @@ -400,7 +401,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) ! 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 @@ -480,7 +481,8 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_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))// & @@ -527,8 +529,46 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_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 + if (present(HA_CS)) then - call HA_init(Time, US, param_file, CS%time_ref, CS%nc, CS%freq, CS%phase0, CS%const_name, HA_CS) + call HA_init(Time, US, param_file, CS%time_ref, CS%nc, CS%freq, CS%phase0, CS%const_name, & + CS%tide_fn, CS%tide_un, HA_CS) call get_param(param_file, mdl, "HA_SSH", HA_ssh, & "If true, perform harmonic analysis of sea serface height.", default=.false.) if (HA_ssh) call HA_register('ssh', 'h', HA_CS) @@ -613,8 +653,8 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) 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 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)) @@ -622,8 +662,8 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) enddo if (CS%use_tidal_sal_file) then ; do c=1,CS%nc - cosomegat = cos(CS%freq(c)*now) - sinomegat = sin(CS%freq(c)*now) + 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)) @@ -631,8 +671,8 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) enddo ; endif if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc - cosomegat = cos(CS%freq(c)*now) - sinomegat = sin(CS%freq(c)*now) + 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)) @@ -691,8 +731,8 @@ subroutine calc_tidal_forcing_legacy(Time, e_sal, e_sal_tide, e_tide_eq, e_tide_ 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 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 @@ -701,8 +741,8 @@ subroutine calc_tidal_forcing_legacy(Time, e_sal, e_sal_tide, e_tide_eq, e_tide_ enddo if (CS%use_tidal_sal_file) then ; do c=1,CS%nc - cosomegat = cos(CS%freq(c)*now) - sinomegat = sin(CS%freq(c)*now) + 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 amp_cossin = CS%ampsal(i,j,c) & * (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) @@ -712,8 +752,8 @@ subroutine calc_tidal_forcing_legacy(Time, e_sal, e_sal_tide, e_tide_eq, e_tide_ enddo ; endif if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc - cosomegat = cos(CS%freq(c)*now) - sinomegat = sin(CS%freq(c)*now) + 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 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)) diff --git a/src/parameterizations/lateral/MOM_wave_drag.F90 b/src/parameterizations/lateral/MOM_wave_drag.F90 new file mode 100644 index 0000000000..a507c762c1 --- /dev/null +++ b/src/parameterizations/lateral/MOM_wave_drag.F90 @@ -0,0 +1,135 @@ +!> 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] +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(2) !< 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(filter_names(CS%nf)) ; read(filter_name_str, *) filter_names + + 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_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))+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) + + 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, k + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + Drag_u(:,:) = 0.0 ; Drag_v(:,:) = 0.0 + + !$OMP do + do k=1,CS%nf ; do j=js,je ; do I=is-1,ie + Drag_u(I,j) = Drag_u(I,j) + u(I,j,k) * CS%coef_u(I,j,k) + enddo ; enddo ; enddo + + !$OMP do + do k=1,CS%nf ; do J=js-1,je ; do i=is,ie + Drag_v(i,J) = Drag_v(i,J) + v(i,J,k) * CS%coef_v(i,J,k) + enddo ; enddo ; enddo + +end subroutine wave_drag_calc + +!> \namespace mom_wave_drag +!! +!! By Chengzhu Xu (chengzhu.xu@oregonstate.edu) and Edward D. Zaron, December 2024 +!! +!! 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. + +end module MOM_wave_drag + diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 0dfead633c..fb305915f7 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -236,10 +236,12 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + call get_param(param_file, mdl, "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=.true.) + "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. "//& @@ -304,7 +306,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, 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(:,:) else @@ -348,15 +350,15 @@ 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 + 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 @@ -520,10 +522,12 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) + call get_param(param_file, mdl, "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=.true.) + "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, "//& @@ -590,8 +594,8 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I 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 + 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 @@ -618,12 +622,12 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I 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 + 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 @@ -659,16 +663,23 @@ subroutine init_ALE_sponge_diags(Time, G, diag, CS, US) 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 do m=1,CS%fldno CS%id_sp_tendency(m) = -1 - CS%id_sp_tendency(m) = register_diag_field('ocean_model', & - 'sp_tendency_' // CS%Ref_val(m)%name, diag%axesTL, Time, & - 'Time tendency due to restoring ' // CS%Ref_val(m)%long_name, & - CS%Ref_val(m)%unit, conversion=US%s_to_T) + 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 @@ -712,8 +723,8 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS, & 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 + 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 @@ -728,6 +739,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS, & 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 @@ -771,15 +783,15 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, 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 + 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 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 "//& @@ -884,8 +896,8 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename 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. @@ -1077,7 +1089,7 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) 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 @@ -1124,7 +1136,7 @@ subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) 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 diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 41fb14f8b7..8e42694b36 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1092,11 +1092,11 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl call cpu_clock_begin(id_clock_KPP_compute_BLD) ! some constants - GoRho = US%Z_to_m*US%s_to_T**2 * (US%L_to_Z**2 * 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 = US%L_to_Z**2 * GV%Z_to_H * GV%g_Earth / GV%Rho0 + GoRho_Z_L2 = GV%Z_to_H * GV%g_Earth_Z_T2 / GV%Rho0 else - GoRho_Z_L2 = US%L_to_Z**2 * GV%g_Earth * GV%RZ_to_H + 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 @@ -1315,7 +1315,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl 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) * (US%L_to_Z**2 * GV%g_Earth) * & + 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)) ) / & @@ -1459,7 +1459,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl 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*US%T_to_s * Vt2_1d(:) + 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 diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index ce592a2d9c..74a0305ce1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -181,9 +181,9 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) integer :: i, j, k if (GV%Boussinesq) then - g_o_rho0 = (US%L_to_Z**2*US%s_to_T**2*GV%Z_to_H) * GV%g_Earth / GV%Rho0 + g_o_rho0 = (US%s_to_T**2*GV%Z_to_H) * GV%g_Earth_Z_T2 / GV%Rho0 else - g_o_rho0 = (US%L_to_Z**2*US%s_to_T**2*GV%RZ_to_H) * GV%g_Earth + g_o_rho0 = (US%s_to_T**2*GV%RZ_to_H) * GV%g_Earth_Z_T2 endif ! initialize dummy variables diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 958b2478f3..173ab7a36d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -35,7 +35,7 @@ module MOM_CVMix_ddiff 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 [H ~> m or kg-2] + 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 diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 46d7b98502..a4a336d867 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -94,7 +94,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) 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 @@ -141,7 +141,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (GV%Boussinesq .or. GV%semi_Boussinesq) then dRho = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) else - dRho = (US%L_to_Z**2 * GV%g_Earth) * (rho_1D(kk+1) - rho_1D(kk+2)) / (0.5*(rho_1D(kk+1) + rho_1D(kk+2))) + 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 diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 64e7f17ef2..b42bd3a8ad 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -60,7 +60,7 @@ module MOM_bkgnd_mixing !! twice the Earth's rotation period, used with the !! Henyey scaling from the mixing [nondim] real :: Henyey_max_lat !< A latitude poleward of which the Henyey profile - !! is returned to the minimum diffusivity [degN] + !! is returned to the minimum diffusivity [degrees_N] real :: prandtl_bkgnd !< Turbulent Prandtl number used to convert !! vertical background diffusivity into viscosity [nondim] real :: Kd_tanh_lat_scale !< A nondimensional scaling for the range of diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index b30a74e151..690688dc1e 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -46,16 +46,18 @@ module MOM_bulk_mixed_layer !! ocean, instead of passing through to the bottom mud. real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE !! 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 [nondim]. - real :: bulk_Ri_convective !< The efficiency with which convectively - !! released mean kinetic energy becomes TKE [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 L2 T-2 ~> m3 s-2 or J m-2]. The default is so small that its actual + !! [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 @@ -129,21 +131,21 @@ module MOM_bulk_mixed_layer real :: Allowed_S_chg !< The amount by which salinity is allowed !! to exceed previous values during detrainment [S ~> ppt] - ! These are terms in the mixed layer TKE budget, all in [H L2 T-3 ~> m3 s-3 or W m-2] 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 [H L2 T-3 ~> m3 s-3 or W m-2]. - diag_TKE_RiBulk, & !< The resolved KE source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. - diag_TKE_conv, & !< The convective source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. - diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating [H L2 T-3 ~> m3 s-3 or W m-2]. - diag_TKE_mech_decay, & !< The decay of mechanical TKE [H L2 T-3 ~> m3 s-3 or W m-2]. - diag_TKE_conv_decay, & !< The decay of convective TKE [H L2 T-3 ~> m3 s-3 or W m-2]. - diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [H L2 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 L2 T-3 ~> m3 s-3 or W m-2]. + 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 @@ -251,9 +253,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! 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 [H L2 T-2 ~> m3 s-2 or J m-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 [H L2 T-2 ~> m3 s-2 or J m-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 @@ -298,7 +300,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C 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 [H L2 T-3 ~> m3 s-3 or W m-2]. + ! 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 @@ -314,17 +316,17 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C 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 ! A combination of constants used in the river mixing energy - ! calculation [H L2 Z-1 T-2 R-2 ~> m8 s-2 kg-2 or m5 s-2 kg-1] or - ! [H L2 Z-1 T-2 ~> m2 s-2 or kg m-1 s-2] + ! 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 - ! [H L2 T-2 ~> m3 s-2 or J m-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 [H L2 T-2 ~> m3 s-2 or J m-2]. + ! adjustment [H Z2 T-2 ~> m3 s-2 or J m-2]. cTKE ! The turbulent kinetic energy source due to convective - ! adjustment [H L2 T-2 ~> m3 s-2 or J m-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 [H ~> m or kg m-2]. @@ -517,7 +519,7 @@ 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[H 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 @@ -525,14 +527,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) if (CS%nonBous_energetics) then - RmixConst = -0.5*CS%rivermix_depth * GV%g_Earth + 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 * Irho0**2 + 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)) + & @@ -867,10 +869,10 @@ subroutine convective_adjustment(h, u, v, R0, SpV0, 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 [H L2 T-2 ~> m3 s-2 or J m-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 - !! [H L2 T-2 ~> m3 s-2 or J m-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 structure @@ -899,12 +901,12 @@ subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, & real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: g_H_2Rho0 ! Half the gravitational acceleration times ! the conversion from H to Z 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]. logical :: unstable integer :: is, ie, nz, i, k, k1, nzc, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke - 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) nzc = nz ; if (present(nz_conv)) nzc = nz_conv nkmb = CS%nkml+CS%nkbl @@ -938,7 +940,7 @@ subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, & 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 * GV%H_to_RZ) * & + 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 @@ -1078,9 +1080,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & 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 [H L2 T-2 ~> m3 s-2 or J m-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 [H L2 T-2 ~> m3 s-2 or J m-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. @@ -1126,7 +1128,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! h_ent between iterations [H ~> m or kg m-2]. real :: g_H_2Rho0 ! Half the gravitational acceleration times ! the conversion from H to Z divided by the mean density, - ! [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + ! [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 @@ -1140,7 +1142,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Angstrom = GV%Angstrom_H C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.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) Idt = 1.0 / dt is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1391,7 +1393,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & 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 * GV%H_to_RZ) * h_ent * & + 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 @@ -1448,25 +1450,25 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F !! 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 [H L2 T-2 ~> m3 s-2 or J m-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 - !! [H L2 T-2 ~> m3 s-2 or J m-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 - !! [H L2 T-2 ~> m3 s-2 or J m-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 [H L2 T-2 ~> m3 s-2 or J m-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 [H L2 T-2 ~> m3 s-2 or J m-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 - !! [H L2 T-3 ~> m3 s-3 or W m-2]. + !! [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]. @@ -1484,13 +1486,13 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F ! convection to drive mechanical entrainment. ! Local variables - real :: dKE_conv ! The change in mean kinetic energy due to all convection [H L2 T-2 ~> m3 s-2 or J m-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 [H L2 T-2 ~> m3 s-2 or J m-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, [H Z2 T-2 ~> m3 s-2 or J m-2]. @@ -1499,7 +1501,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F 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 converted to thickness units [H-1 ~> m-1 or m2 kg-1] - real :: wind_TKE_src ! The surface wind source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + 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 @@ -1561,7 +1563,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F 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 * & @@ -1573,14 +1575,14 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F 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 * (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 * (H_to_Z**2*(absf*h_CA(i))**3) * totEn_Z)) @@ -1606,11 +1608,11 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F ! At this point, it is assumed that cTKE is positive and stored in TKE_CA! ! Note: Removed factor of 2 in u*^3 terms. if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then - TKE(i) = (dt*CS%mstar)*((GV%Z_to_H*US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & + 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*US%Z_to_L**2*U_star**3 = GV%RZ_to_H * US%Z_to_L*fluxes%tau_mag(i,j) * U_star - TKE(i) = (dt*CS%mstar) * ((GV%RZ_to_H*US%Z_to_L * fluxes%tau_mag(i,j) * U_star)*exp_kh) + & + ! 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 @@ -1620,9 +1622,9 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F if (CS%TKE_diagnostics) then if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then - wind_TKE_src = CS%mstar*(GV%Z_to_H*US%Z_to_L**2*U_star*U_Star*U_Star) * diag_wt + 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 * US%Z_to_L*fluxes%tau_mag(i,j) * U_star) * diag_wt + 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 ) @@ -1710,7 +1712,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! 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 [H L2 T-2 ~> m3 s-2 or J m-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)), & @@ -1735,22 +1737,22 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & 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 - ! [H L2 T-2 ~> m3 s-2 or J m-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 [H2 L2 T-2 ~> m4 s-2 or kg2 m-2 s-2] - real :: TKE_ent ! The TKE that remains if h_ent were entrained [H L2 T-2 ~> m3 s-2 or J m-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 [H L2 T-2 ~> m3 s-2 or J m-2] - real :: dTKE_dh ! The partial derivative of TKE with h_ent [L2 T-2 ~> m2 s-2] + ! 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]. @@ -1769,7 +1771,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & 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 @@ -1782,7 +1784,7 @@ 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 if (CS%nonBous_energetics) then - dRL = 0.5 * (GV%g_Earth * GV%H_to_RZ) * (SpV0_tot(i) - SpV0(i,k)*htot(i)) + 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 @@ -1827,7 +1829,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif if (CS%nonBous_energetics) then Pen_En_Contrib = Pen_En_Contrib - & - (0.5 * (GV%g_Earth * GV%H_to_RZ) * dSpV0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + (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) @@ -1911,7 +1913,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & opacity*h_ent*f2_x1) endif if (CS%nonBous_energetics) then - Cpen1 = -0.5 * (GV%g_Earth * GV%H_to_RZ) * dSpV0_dT(i) * Pen_SW_bnd(n,i) + 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 @@ -1994,7 +1996,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 @@ -2553,13 +2555,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_e ! 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 Z L2 T-2 ~> J m-2]. + ! 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 Z L2 T-2 ~> J m-2]. + ! 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]. @@ -2608,8 +2610,8 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_e ! [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 @@ -2619,7 +2621,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_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 :: 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] @@ -2641,8 +2643,8 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_e 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 @@ -3104,7 +3106,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_e ! 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*GV%H_to_RZ**2*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) + 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 @@ -3206,7 +3208,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_e ! 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*GV%H_to_RZ**2 * & + 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 @@ -3585,7 +3587,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, SpV0, Rcv, RcvTgt, dt, dt_diag, d_e 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] + !! 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 @@ -3637,16 +3639,16 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, SpV0, Rcv, RcvTgt, dt, dt_diag, d_e real :: dt_Time ! The timestep divided by the detrainment timescale [nondim]. 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 T-3 H-1 R-1 ~> m4 s-3 kg-1 or m7 s-3 kg-2]. + ! 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 - ! [L2 R H-1 T-3 ~> kg m s-3 or m4 s-3]. + ! [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 - ! [L2 R2 Z H-2 T-3 ~> kg2 m-2 s-3 or m4 s-3]. + ! [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 logical :: must_unmix @@ -3660,10 +3662,10 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, SpV0, Rcv, RcvTgt, dt, dt_diag, d_e dt_Time = dt / CS%BL_detrain_time if (CS%nonBous_energetics) then - nB_g_H_2dt = (GV%g_Earth * GV%H_to_RZ) / (2.0 * dt_diag) + 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 * GV%H_to_Z**2) / (2.0 * dt_diag) + 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 @@ -3992,7 +3994,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "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.) + 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.", & @@ -4010,7 +4012,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "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) + 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) @@ -4022,7 +4024,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "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, & + 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, & @@ -4147,34 +4149,34 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) 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=GV%H_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=GV%H_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=GV%H_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=GV%H_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=GV%H_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=GV%H_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=GV%H_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=GV%H_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=GV%H_to_m) CS%id_Hsfc_used = register_diag_field('ocean_model', 'Hs_used', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index d4d2d53e68..b6d4dfa489 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -805,7 +805,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t 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. @@ -816,7 +816,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t 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 @@ -1040,11 +1040,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! 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) * ( US%L_to_Z**2*GV%g_Earth ) / tv%SpV_avg(i,j,1) + 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)) + & @@ -1294,7 +1294,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t 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 * GV%H_to_RZ * US%L_to_Z**2 + 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, & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7fe5d0b777..95c1d3d265 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -22,6 +22,8 @@ module MOM_diabatic_driver 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 @@ -33,7 +35,8 @@ 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 @@ -149,7 +152,7 @@ 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 - !! [H2 T-1 ~> m2 s-1 or kg2 m-4 s-2]. The entrainment at the + !! [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 @@ -177,12 +180,15 @@ module MOM_diabatic_driver real :: MLD_En_vals(3) !< Energy values for energy mixed layer diagnostics [R Z3 T-2 ~> J m-2] real :: ref_h_mld = 0.0 !< The depth of the "surface" density used in a difference mixed based !! MLD calculation [Z ~> m]. + 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_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 @@ -236,6 +242,8 @@ module MOM_diabatic_driver 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(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 @@ -564,7 +572,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim 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] + 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)) :: & U_star, & ! The friction velocity [Z T-1 ~> m s-1]. @@ -572,16 +582,29 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim 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 + real, dimension(SZI_(G)) :: & + p_i ,& ! Pressure at the interface [R L2 T-2 ~> Pa] + d_pres, & ! pressure change across a layer [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 ! sufficiently thick that the no-flux boundary conditions have not restricted ! the entrainment - usually sqrt(Kd*dt). + 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 :: 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_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 [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. @@ -589,6 +612,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim 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, dimension(2) :: EOSdom ! The i-computational domain for the equation of state logical :: showCallTree ! If true, show the call tree integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -596,6 +625,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim 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 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 @@ -605,6 +640,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, 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) @@ -641,10 +678,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, 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)") @@ -858,7 +895,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim 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, & + 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, waves=waves) call energetic_PBL_get_MLD(CS%ePBL, BLD(:,:), G, US) @@ -991,6 +1028,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, 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) @@ -1025,6 +1068,68 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, 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) @@ -1179,7 +1284,9 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, 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] + 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)) :: & U_star, & ! The friction velocity [Z T-1 ~> m s-1]. @@ -1191,23 +1298,50 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, 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] + d_pres, & ! pressure change across a layer [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 :: 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_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 [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. - real :: Idt ! The inverse time step [T-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 logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + 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 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 @@ -1221,6 +1355,8 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, 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) @@ -1257,10 +1393,10 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, 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)") @@ -1410,7 +1546,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, 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, & + 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, waves=waves) call energetic_PBL_get_MLD(CS%ePBL, BLD(:,:), G, US) @@ -1535,12 +1671,18 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, 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_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 @@ -1575,6 +1717,68 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, 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) @@ -1893,10 +2097,10 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e 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)") @@ -3236,6 +3440,18 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di Time, "Advective diapycnal salnity flux across interfaces", & 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)', units='m', conversion=US%Z_to_m, & cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & @@ -3248,13 +3464,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di '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, & "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%W_m2_to_RZ3_T3*US%s_to_T) - 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%W_m2_to_RZ3_T3*US%s_to_T, & - 2500.*US%W_m2_to_RZ3_T3*US%s_to_T, & - 250000.*US%W_m2_to_RZ3_T3*US%s_to_T /) - endif + "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 @@ -3281,6 +3492,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di '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. "//& @@ -3615,6 +3833,10 @@ end subroutine register_diabatic_restarts 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) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 7ca432fea4..d197a7a8f1 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -73,12 +73,12 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) 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 :: dz_h_int ! The ratio of the vertical distances across the layers surrounding an interface - ! over the layer thicknesses [H Z-1 ~> nonodim or kg m-3] + ! 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 [H2 ~> m2 or kg2 m-6] + 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 @@ -851,7 +851,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_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*(dz_tr(k-1) + dz_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 @@ -862,7 +862,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_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*(dz_tr(k-1) + dz_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 diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index f10e2f445d..c94e1032fe 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -5,6 +5,7 @@ module MOM_energetic_PBL 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 : time_type, diag_ctrl use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type @@ -16,7 +17,7 @@ module MOM_energetic_PBL 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_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 @@ -59,6 +60,8 @@ 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 [nondim]. @@ -66,7 +69,12 @@ module MOM_energetic_PBL !! 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 @@ -92,9 +100,8 @@ 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 @@ -155,6 +162,53 @@ module MOM_energetic_PBL !! 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]. + !/ 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. + + !/ 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. @@ -170,38 +224,30 @@ module MOM_energetic_PBL !! 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 [H ~> m or kg m-2] - ! 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_ML_depth = -1, id_hML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -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_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_BBL_decay_scale = -1, id_BBL_depth = -1 integer :: id_MSTAR_mix = -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 @@ -236,11 +282,14 @@ module MOM_energetic_PBL !>@{ 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 ! 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_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 @@ -249,7 +298,7 @@ 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, & +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, 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. @@ -279,6 +328,8 @@ 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 @@ -287,7 +338,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface 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 @@ -335,12 +386,17 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS 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 [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + 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]. - SpV_dt ! Specific volume interpolated to interfaces divided by dt or 1.0 / (dt * Rho0) + 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 convsersion factors for + ! [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 @@ -351,16 +407,72 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS 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 :: I_rho ! The inverse of the Boussinesq reference density times a ratio of scaling - ! factors [Z L-1 R-1 ~> m3 kg-1] + real :: u_star_BBL ! The bottom boundary layer friction velocity [H T-1 ~> m s-1 or kg m-2 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 :: 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 = kg s-3]. + 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_MIX, & ! Mstar used in EPBL [nondim] + diag_mStar_LT, & ! Mstar due to Langmuir turbulence [nondim] + diag_LA, & ! Langmuir number [nondim] + diag_LA_MOD ! Modified Langmuir number [nondim] + + ! 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 @@ -380,24 +492,69 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS h_neglect = GV%H_subroundoff - I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. + 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)) ! 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 + + ! 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 - ! 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,I_dt, & + !!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. @@ -414,7 +571,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS 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) = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) + SpV_dt(K) = 1.0 / (dt*GV%Rho0) enddo else do K=1,nz+1 @@ -446,30 +603,22 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS 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(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) - u_star_Mean = sqrt(US%L_to_Z*fluxes%tau_mag_gustless(i,j) * tv%SpV_avg(i,j,1)) - mech_TKE = dt * u_star * US%L_to_Z*fluxes%tau_mag(i,j) + 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(US%L_to_Z*fluxes%tau_mag_gustless(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 * US%L_to_Z*fluxes%tau_mag(i,j) + ! The line above is equivalent to: mech_TKE = dt * u_star * fluxes%tau_mag(i,j) endif if (allocated(tv%SpV_avg) .and. .not.GV%Boussinesq) then - if (CS%answer_date < 20240101) then - SpV_dt(1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,1) * I_dt - do K=2,nz - SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) * 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt - enddo - SpV_dt(nz+1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,nz) * I_dt - else - 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 + 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) @@ -491,77 +640,199 @@ 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) + 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, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, TKE_forcing, B_flux, absf, & + 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, & TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) else - call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, TKE_forcing, B_flux, absf, & + 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 + ! 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 + 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 + u_star_BBL = max(visc%ustar_BBL(i,j), CS%ustar_min*GV%Z_to_H) + + ! 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) + + 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, 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 outputting 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_MIX > 0) diag_mStar_mix(i,j) = eCD%mstar + 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) + 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, 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, 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%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_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) + 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_MIX > 0) call post_data(CS%id_MSTAR_MIX, diag_mStar_MIX, 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) + 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 @@ -591,7 +862,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, !! 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 convsersion factors for answer dates of + !! 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. @@ -618,14 +889,14 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, !! [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 structure + 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. + 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 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] - 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) ! 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 @@ -684,6 +955,9 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, 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 [C H ~> degC m or degC kg m-2]. Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit @@ -698,12 +972,9 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, ! 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 diapycnal diffusivity times a timestep divided by the - ! average thicknesses around a layer [H ~> m or kg m-2]. + 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 @@ -757,8 +1028,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, 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 [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]. @@ -806,12 +1077,18 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, ! 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 :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter + 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 ! An estimate of the potential energy change [R Z3 T-2 ~> J m-2] @@ -837,6 +1114,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, 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 @@ -862,7 +1140,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, 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) @@ -905,602 +1183,1448 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, 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. + + !/ 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, & + 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, 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 - ! Reset ML_depth - MLD_output = dz(1) - sfc_connected = .true. + 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 - !/ 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, & - MStar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& - mstar_LT=mstar_LT) + 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, 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%answer_date < 20190101) .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 + 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 + + 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 + + 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 = MSTAR_total * mech_TKE_in - ! mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) + mech_TKE = mech_TKE * exp_kh endif - ! stochastically perturb mech_TKE in the UFS - if (present(TKE_gen_stoch)) mech_TKE = mech_TKE*TKE_gen_stoch - 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 + ! 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 - 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 + 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) + 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) + 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, 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 thickuness flux units [H T-1 ~> m s-1 or kg m-2 s-1] + 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]. + 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. + 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 = 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] + logical :: BBL_converged ! Flag for convergence of BBLD + 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. + + ! 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)) .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. + + mech_BBL_TKE = BBL_TKE_in + + 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 + I_BBLD = 1.0 / BBLD_guess dz_rsum = 0.0 - MixLen_shape(1) = 1.0 - do K=2,nz+1 - dz_rsum = dz_rsum + dz(k-1) - if (CS%MixLenExponent==2.0) then + 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, (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 - dz_rsum)*I_MLD) )**2 ! CS%MixLenExponent - else + (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, (MLD_guess - dz_rsum)*I_MLD) )**CS%MixLenExponent - endif - enddo + (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) ; dztot = dz(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. - 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 + ! 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(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 + 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_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 - 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 (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 + 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 = 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 + ! 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. + ! on how much energy is available. 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) - else - Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) + 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%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) - 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, 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, 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 + 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 - 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 + dz(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 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) + 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 (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 (sfc_connected) MLD_output = MLD_output + (PE_chg / (PE_chg_g0)) * dz(k) + 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 - 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 (bot_connected) BBLD_output = BBLD_output + (PE_chg / PE_chg_g0) * dz(k-1) - 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 ) + mech_BBL_TKE = 0.0 + bot_disconnect = .true. + endif ! End of convective or forced mixing cases to determine Kd. endif - 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) - + 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) - dztot = dz(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) - dztot = dztot + dz(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)) + & @@ -1508,58 +2632,118 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, 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 - 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 - else - eCD%LA = 0.0 ; eCD%LAmod = 0.0 ; eCD%mstar = mstar_total ; eCD%mstar_LT = 0.0 + + enddo ! Iteration loop for converged boundary layer thickness. + + eCD%BBL_its = min(BBL_it, CS%max_BBLD_its) + + BBLD_io = BBLD_output endif - MLD_io = MLD_output +end subroutine ePBL_BBL_column -end subroutine ePBL_column +!> 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 interface's diapycnal diffusivity times a timestep. @@ -1568,10 +2752,10 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_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 @@ -1580,7 +2764,7 @@ 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 [C H ~> degC m or degC kg m-2]. @@ -1630,14 +2814,14 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! 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 realized 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]. @@ -1706,6 +2890,153 @@ 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 interface's diapycnal diffusivity times a timestep !! using the original form used in the first version of ePBL. @@ -2074,12 +3405,16 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_energetic_PBL" ! This module's name. - character(len=20) :: tmpstr + character(len=20) :: tmpstr ! A string that is parsed for 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 integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: use_temperature, use_omega + 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 @@ -2092,6 +3427,9 @@ 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) @@ -2101,7 +3439,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "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, & @@ -2130,27 +3468,32 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "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) + 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, & "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) @@ -2209,7 +3552,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) 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 "//& "effectively at low values (weakly developed OSBLs).", & @@ -2276,10 +3619,14 @@ 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, "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=.true., do_not_log=.not.CS%Use_MLD_iteration) ! The default should be changed to .false. 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, & @@ -2294,7 +3641,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"//& @@ -2303,31 +3650,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, & @@ -2343,6 +3690,86 @@ 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 "//& @@ -2360,7 +3787,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, do_not_log=.true.) call get_param(param_file, mdl, "LT_ENHANCE", LT_enhance, default=-1) if (LT_ENHANCE == 0) then @@ -2384,7 +3811,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) @@ -2404,7 +3831,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "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", & + "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, & "Coefficient for modification of Langmuir number due to "//& @@ -2428,6 +3855,27 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=0.95, do_not_log=(CS%LT_enhance_form==No_Langmuir)) endif + !/ 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. @@ -2441,32 +3889,54 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Checking output flags 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_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) + Time, 'Velocity Scale that is used.', units='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, 'Total mstar that is used.', 'nondim') + if ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0)) 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) + endif if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') @@ -2476,37 +3946,33 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) 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)) 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 @@ -2518,26 +3984,20 @@ subroutine energetic_PBL_end(CS) 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)) 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 de13322652..5141176d08 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -841,9 +841,9 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & if (CS%id_diff_work > 0) then if (GV%Boussinesq .or. .not.associated(tv%eqn_of_state)) then - g_2dt = 0.5 * GV%H_to_Z**2 * US%L_to_Z**2 * (GV%g_Earth / dt) + 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 * US%L_to_Z**2 * (GV%g_Earth / dt) + 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 diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 47550fa93d..2384844f6e 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -52,7 +52,7 @@ module MOM_int_tide_input !! 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 [Z T-1 ~> m s-1]. + tideamp !< The amplitude of the tidal velocities [L T-1 ~> m s-1]. character(len=200) :: inputdir !< The directory for input files. @@ -116,8 +116,10 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! equation of state. logical :: avg_enabled ! for testing internal tides (BDM) type(time_type) :: time_end !< For use in testing internal tides (BDM) - real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] - real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] + 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, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global @@ -249,7 +251,7 @@ subroutine find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, h2, N2_bot, Rho_bo 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%H_to_RZ + G_Rho0 = GV%g_Earth_Z_T2 / GV%H_to_RZ EOSdom(:) = EOS_domain(G%HI) ! Find the (limited) density jump across each interface. @@ -404,8 +406,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height [nondim]. real :: kappa_itides ! topographic wavenumber and non-dimensional scaling [L-1 ~> m-1] real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion [Z ~> m]. - real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] - real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] + 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 diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index f2c47ab214..53d6b36e4a 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -90,6 +90,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. @@ -97,6 +101,11 @@ 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 :: 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 @@ -107,7 +116,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 + 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 @@ -149,6 +159,11 @@ 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 [H ~> m or kg m-2]. dz_2d, & ! Vertical distance between interface heights [Z ~> m]. @@ -170,7 +185,12 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & 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 [H Z T-1 ~> m2 s-1 or Pa s] - tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + 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]. @@ -194,8 +214,14 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & k0dt = dt*CS%kappa_0 dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) + if (CS%id_N2_init>0) diag_N2_init(:,:,:) = 0.0 + if (CS%id_S2_init>0) 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. @@ -282,7 +308,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif - 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) @@ -295,7 +320,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US) + 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. @@ -308,16 +334,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) then ; do K=1,nz+1 + diag_N2_init(i,j,K) = N2_init(K) + enddo ; endif + if (CS%id_S2_init>0) 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) diag_N2_init(i,j,K) = N2_init(kc(K)) + if (CS%id_S2_init>0) 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) & + 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) & + diag_S2_init(i,j,K) = (1.0-kf(K)) * S2_init(kc(K)) + kf(K) * S2_init(kc(K)+1) endif enddo endif @@ -332,6 +385,7 @@ 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 @@ -343,6 +397,10 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & 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 @@ -385,15 +443,25 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ !! 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]. + 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)+1) :: & + h_vert ! Thicknesses interpolated to vertices [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZIB_(G),SZK_(GV)) :: & - h_2d, & ! A 2-D version of h [H ~> m or kg m-2]. + 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 [C ~> degC], S [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 [H Z T-1 ~> m2 s-1 or Pa s] + 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)) :: & @@ -408,14 +476,20 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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 [H Z T-1 ~> m2 s-1 or Pa s] - tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + 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 [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 masked thickness weights [H-1 ~> m-1 or m2 kg-1]. + 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. @@ -425,11 +499,21 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ! 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 geomentric 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] + 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) diag_N2_init(:,:,:) = 0.0 + if (CS%id_S2_init>0) 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 @@ -439,10 +523,10 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ! 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) + !$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 @@ -577,49 +661,144 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US) + 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) else 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) then ; do K=1,nz+1 + diag_N2_init(i,j,K) = N2_init(K) + enddo ; endif + if (CS%id_S2_init>0) 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) diag_N2_init(I,J,K) = N2_init(kc(K)) + if (CS%id_S2_init>0) 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) & + 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) & + 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) then + ! This conversion factor is required to allow for aribtrary fracional powers of the diffusivities. + if (CS%VS_GeometricMean) 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 (CS%VS_GeometricMean) then + 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 thikncess-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 + else + ! 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 + endif + 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, 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) @@ -627,13 +806,19 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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, hlay, dz_lay, & - u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, tke_avg, tv, CS, GV, US) + 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 [H Z T-1 ~> m2 s-1 or Pa s] @@ -660,6 +845,14 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la 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 @@ -766,7 +959,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la Ri_crit = CS%Rino_crit gR0 = GV%H_to_RZ * GV%g_Earth - g_R0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 + 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) @@ -901,19 +1094,19 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la 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) = (US%L_to_Z**2 * GV%g_Earth) * (rho_int(K) * dSpV_dT(K)) - dbuoy_dS(K) = (US%L_to_Z**2 * GV%g_Earth) * (rho_int(K) * dSpV_dS(K)) + 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) = -(US%L_to_Z**2 * GV%g_Earth) / GV%Rlay(1) + dbuoy_dT(1) = -GV%g_Earth_Z_T2 / GV%Rlay(1) do K=2,nzc - dbuoy_dT(K) = -(US%L_to_Z**2 * GV%g_Earth) / (0.5*(GV%Rlay(k-1) + GV%Rlay(k))) + dbuoy_dT(K) = -GV%g_Earth_Z_T2 / (0.5*(GV%Rlay(k-1) + GV%Rlay(k))) enddo - dbuoy_dT(nzc+1) = -(US%L_to_Z**2 * GV%g_Earth) / GV%Rlay(nzc) + dbuoy_dT(nzc+1) = -GV%g_Earth_Z_T2 / GV%Rlay(nzc) endif ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 @@ -926,13 +1119,19 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la ! This call just calculates N2 and S2. 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 ( h_Int(K) > 0.0 ) & @@ -1104,8 +1303,11 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la 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 @@ -1873,6 +2075,25 @@ 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, "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=.true., do_not_log=just_read.or.(.not.CS%KS_at_vertex)) + 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) @@ -1956,7 +2177,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) 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 "//& @@ -2013,9 +2234,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=GV%HZ_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 diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 81c0194438..b62f67feee 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -17,7 +17,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 @@ -78,8 +78,21 @@ module MOM_opacity !! radiation that is in the blue band [nondim]. 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 @@ -368,9 +381,9 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir SW_pen_tot = 0.0 if (G%mask2dT(i,j) > 0.0) 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)) + 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)) * 0.5*sw_total(i,j) + SW_pen_tot = SW_pen_frac_morel(chl_data(i,j), CS) * 0.5*sw_total(i,j) endif endif @@ -426,19 +439,21 @@ 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) * US%Z_to_m - 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) * US%Z_to_m - ! 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*US%Z_to_m ; 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.0) & - optics%opacity_band(1,i,j,k) = US%Z_to_m * opacity_morel(chl_data(i,j)) + 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) @@ -463,28 +478,25 @@ 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) +function opacity_morel(chl_data, CS) real, intent(in) :: chl_data !< The chlorophyll-A concentration in [mg m-3] - real :: opacity_morel !< The returned opacity [m-1] + 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 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, dimension(6), parameter :: & - Z2_coef = (/7.925, -6.644, 3.662, -1.815, -0.218, 0.502/) ! Extinction length coefficients [m] 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) +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 @@ -493,24 +505,13 @@ function SW_pen_frac_morel(chl_data) ! 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 [nondim] - real, dimension(6), parameter :: & - V1_coef = (/0.321, 0.008, 0.132, 0.038, -0.017, -0.007/) ! Penetrating fraction coefficients [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 [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, SpV_avg) @@ -710,9 +711,9 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l TKE_calc = (present(TKE) .and. present(dSV_dT)) if (optics%answer_date < 20190101) then - 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 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 @@ -1035,9 +1036,25 @@ 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] + 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 @@ -1166,25 +1183,104 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) 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 "//& @@ -1394,6 +1490,12 @@ subroutine opacity_end(CS, optics) 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)) & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index fc6d8380c5..67e57c7cdf 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -13,6 +13,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 @@ -75,8 +76,12 @@ module MOM_set_diffusivity logical :: LOTW_BBL_use_omega !< If true, use simpler/less precise, BBL diffusivity. 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 [nondim] + 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] real :: cdrag !< quadratic drag coefficient [nondim] real :: dz_BBL_avg_min !< A minimal distance over which to average to determine the average !! bottom boundary layer density [Z ~> m] @@ -159,11 +164,17 @@ module MOM_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 20240630 use more accurate - !! expressions for cases where USE_LOTW_BBL_DIFFUSIVITY is true. + !! 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 @@ -182,6 +193,7 @@ module MOM_set_diffusivity 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 @@ -192,7 +204,8 @@ module MOM_set_diffusivity 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 => 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] @@ -226,7 +239,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 @@ -252,9 +265,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i 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 !! [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 @@ -274,6 +289,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i 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 [C ~> degC] and [S ~> ppt] with properties in massless layers ! filled vertically by diffusion or the properties after full convective adjustment. @@ -359,7 +375,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)) & @@ -367,7 +384,8 @@ 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.) @@ -419,6 +437,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i 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) @@ -473,6 +494,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 @@ -502,6 +526,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 @@ -514,6 +545,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 @@ -549,7 +586,7 @@ 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 + 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 @@ -562,7 +599,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%use_tidal_mixing) & 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 @@ -593,6 +630,21 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i 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) = Kd_leak_2d(i,K) + enddo ; enddo ; endif + if (associated (VBF%Kd_quad)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_quad(i,j,K) = Kd_quad_2d(i,K) + enddo ; enddo ; endif + if (associated (VBF%Kd_itidal)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_itidal(i,j,K) = Kd_itidal_2d(i,K) + enddo ; enddo ; endif + if (associated (VBF%Kd_Froude)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_Froude(i,j,K) = Kd_Froude_2d(i,K) + enddo ; enddo ; endif + if (associated (VBF%Kd_slope)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_slope(i,j,K) = Kd_slope_2d(i,K) + enddo ; enddo ; endif if (CS%id_prof_leak > 0) then ; do k=1,nz; do i=is,ie dd%prof_leak(i,j,k) = prof_leak_2d(i,k) @@ -620,6 +672,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & 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 @@ -638,9 +693,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i 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 @@ -662,7 +720,7 @@ 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)) then + if (associated(dd%Kd_Work)) then do k=1,nz ; do i=is,ie 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 @@ -675,6 +733,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) @@ -716,17 +780,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (CS%debug) then - if (CS%id_prof_leak > 0) call hchksum(dd%prof_leak, "leakage_profile", G%HI, haloshift=0, scale=GV%m_to_H) - if (CS%id_prof_slope > 0) call hchksum(dd%prof_slope, "slope_profile", G%HI, haloshift=0, scale=GV%m_to_H) - if (CS%id_prof_Froude > 0) call hchksum(dd%prof_Froude, "Froude_profile", G%HI, haloshift=0, scale=GV%m_to_H) - if (CS%id_prof_quad > 0) call hchksum(dd%prof_quad, "quad_profile", G%HI, haloshift=0, scale=GV%m_to_H) - if (CS%id_prof_itidal > 0) call hchksum(dd%prof_itidal, "itidal_profile", G%HI, haloshift=0, scale=GV%m_to_H) - if (CS%id_TKE_to_Kd > 0) call hchksum(dd%TKE_to_Kd, "TKE_to_Kd", G%HI, haloshift=0, scale=US%m_to_Z*US%T_to_s**2) - if (CS%id_Kd_leak > 0) call hchksum(dd%Kd_leak, "Kd_leak", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - if (CS%id_Kd_quad > 0) call hchksum(dd%Kd_quad, "Kd_quad", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - if (CS%id_Kd_itidal > 0) call hchksum(dd%Kd_itidal, "Kd_itidal", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - if (CS%id_Kd_Froude > 0) call hchksum(dd%Kd_Froude, "Kd_Froude", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - if (CS%id_Kd_slope > 0) call hchksum(dd%Kd_slope, "Kd_slope", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + 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 @@ -754,12 +818,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i 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 @@ -773,7 +838,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) @@ -851,7 +917,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! 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 :: grav ! Gravitational acceleration [Z T-1 ~> m s-2] + 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 @@ -868,7 +934,7 @@ 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 dz_neglect = GV%dZ_subroundoff - grav = (US%L_to_Z**2 * GV%g_Earth) + 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 @@ -999,7 +1065,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! maxTKE is found by determining the kappa that gives maxEnt. ! kappa_max = I_dt * dRho_int(i,K+1) * maxEnt(i,k) * & ! G_IRho0*(h(i,j,k) + dh_max) / (G_Rho0*dRho_lay) - ! maxTKE(i,k) = (GV%g_Earth*US%L_to_Z**2) * dRho_lay * kappa_max + ! maxTKE(i,k) = GV%g_Earth_Z_T2 * dRho_lay * kappa_max ! dRho_int should already be non-negative, so the max is redundant? dh_max = maxEnt(i,k) * (1.0 + dsp1_ds(i,k)) dRho_lay = 0.5 * max(dRho_int(i,K) + dRho_int(i,K+1), 0.0) @@ -1081,7 +1147,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & 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%H_to_RZ + G_Rho0 = GV%g_Earth_Z_T2 / GV%H_to_RZ H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -1372,7 +1438,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, TKE_Ray = 0.0 ; Rayleigh_drag = .false. if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. - R0_g = GV%H_to_RZ / (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 @@ -1399,10 +1465,14 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, ! 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)*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) * GV%RZ_to_H * & + 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 @@ -1458,7 +1528,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, 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) * & + 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) + & @@ -1563,6 +1633,8 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo 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] @@ -1626,14 +1698,13 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar ! Energy input at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. - ! (Note that visc%TKE_BBL is in [H Z2 T-3 ~> m3 s-3 or W m-2], 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) + ! (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 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) * GV%RZ_to_H - TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. + ! 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 if (CS%LOTW_BBL_answer_date > 20240630) then @@ -1657,7 +1728,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo ! 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) * & + 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) + & @@ -1751,8 +1822,7 @@ subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_t real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] 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 reference density times a ratio of scaling - ! factors [Z L-1 R-1 ~> m3 kg-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] @@ -1768,7 +1838,7 @@ subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_t C1_6 = 1.0 / 6.0 kml = GV%nkml dz_neglect = GV%dz_subroundoff - I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. + 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 @@ -1790,12 +1860,12 @@ subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_t 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(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1), CS%ustar_min**2) - u_star_H = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + 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(US%L_to_Z*fluxes%tau_mag(i,j) * GV%Rho0) + 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) @@ -1932,12 +2002,15 @@ subroutine set_BBL_TKE(u, v, h, tv, 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 (.not.CS%bottomdraglaw .or. (CS%BBL_effic<=0.0 .and. CS%ePBL_BBL_effic<=0.0)) 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 (allocated(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 @@ -2062,7 +2135,13 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) (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 * & + 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))) + & @@ -2272,7 +2351,9 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ 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.", & + "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) @@ -2345,9 +2426,11 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "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, "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 "//& @@ -2386,6 +2469,12 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "USE_LOTW_BBL_DIFFUSIVITY is true.", & default=20190101, do_not_log=.not.CS%use_LOTW_BBL_diffusivity) !### Set default as default=default_answer_date, or use SET_DIFF_ANSWER_DATE. + 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=20250101, do_not_log=CS%use_LOTW_BBL_diffusivity.or.(CS%BBL_effic<=0.0)) + !### Set default as default=default_answer_date, or use SET_DIFF_ANSWER_DATE. CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) @@ -2517,6 +2606,8 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ 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=(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, & diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 3b388385f5..70292380e7 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -197,7 +197,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) S_vel, & ! Arithmetic mean of the layer salinities adjacent to a ! velocity point [S ~> ppt]. SpV_vel, & ! Arithmetic mean of the layer averaged specific volumes adjacent to a - ! velocity point [R-1 ~> kg m-3]. + ! 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] @@ -314,7 +314,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) h_neglect = GV%H_subroundoff dz_neglect = GV%dZ_subroundoff - Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) + Rho0x400_G = 400.0*(GV%H_to_RZ / GV%g_Earth_Z_T2) if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//& "Module must be initialized before it is used.") @@ -417,6 +417,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (.not.use_BBL_EOS) Rml_vel(:,:) = 0.0 + ! 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 @@ -583,6 +584,21 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif endif ; endif + ! 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) = 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) = 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 ; 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. @@ -592,18 +608,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) dztot_vel = 0.0 ; dzwtot = 0.0 Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0 - ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant - if (CS%BBL_use_tidal_bg) then - if (m==1) 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) = 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 - else - u2_bg(i) = CS%drag_bg_vel * CS%drag_bg_vel - endif do k=nz,1,-1 if (htot_vel>=CS%Hbbl) exit ! terminate the k loop @@ -803,19 +807,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then ; C2f = G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J) else ; C2f = G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J) ; endif - ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant - if (CS%BBL_use_tidal_bg) then - if (m==1) 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) = 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 - else - u2_bg(i) = CS%drag_bg_vel * CS%drag_bg_vel - endif - ! The thickness of a rotation limited BBL ignoring stratification is ! h_f ~ Cn u* / f (limit of KW99 eq. 2.20 for N->0). ! The buoyancy limit of BBL thickness (h_N) is already in the variable htot from above. @@ -2046,7 +2037,7 @@ 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%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) + Rho0x400_G = 400.0*(GV%H_to_RZ / GV%g_Earth_Z_T2) 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 @@ -2959,9 +2950,6 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS 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, & @@ -3142,7 +3130,8 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS 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) @@ -3217,7 +3206,8 @@ subroutine set_visc_end(visc, CS) if (associated(visc%Kv_shear)) deallocate(visc%Kv_shear) if (associated(visc%Kv_shear_Bu)) deallocate(visc%Kv_shear_Bu) if (allocated(visc%ustar_bbl)) deallocate(visc%ustar_bbl) - if (allocated(visc%TKE_bbl)) deallocate(visc%TKE_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) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 5b57103078..b045fe6bde 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -5,6 +5,7 @@ module MOM_tidal_mixing 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_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : openParameterBlock, closeParameterBlock @@ -695,7 +696,7 @@ end function tidal_mixing_init !! tidal dissipation and to add the effect of internal-tide-driven mixing to the layer or interface !! diffusivities. 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) + 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 @@ -729,13 +730,14 @@ subroutine calculate_tidal_mixing(dz, j, N2_bot, Rho_bot, N2_lay, N2_int, TKE_to real, dimension(SZI_(G),SZK_(GV)+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(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) else 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) + G, GV, US, CS, Kd_max, Kd_lay, Kd_int, VBF) endif endif end subroutine calculate_tidal_mixing @@ -992,7 +994,7 @@ end subroutine calculate_CVMix_tidal !! 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(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & - G, GV, US, CS, Kd_max, Kd_lay, Kd_int) + 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 @@ -1022,6 +1024,7 @@ subroutine add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, m real, dimension(SZI_(G),SZK_(GV)+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 diagnostics structure for vertical buoyancy fluxes ! local @@ -1302,38 +1305,57 @@ subroutine add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, m endif ! diagnostics - if (allocated(CS%dd%Kd_itidal)) then + if (allocated(CS%dd%Kd_itidal).or.(associated(VBF%Kd_itidal))) 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 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 :: tau_scale ! A scaling factor for the interpolated wind stress magnitude [H R-1 L-1 ~> m3 kg-1 or nondim] 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 [H T-1 ~> m s-1 or Pa s m-1]. @@ -1864,8 +1863,6 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, nz = GV%ke h_neglect = GV%dZ_subroundoff - tau_scale = US%L_to_Z * GV%RZ_to_H - 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 @@ -1964,11 +1961,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, dhc = hvel(i,nz)*0.5 ! These expressions assume that Kv_tot(i,nz+1) = CS%Kv, consistent with ! the suppression of turbulent mixing by the presence of a solid boundary. - if (dhc < bbl_thick(i)) then - a_cpl(i,nz+1) = kv_bbl(i) / ((dhc+h_neglect) + I_amax*kv_bbl(i)) - else - a_cpl(i,nz+1) = kv_bbl(i) / ((bbl_thick(i)+h_neglect) + I_amax*kv_bbl(i)) - endif + a_cpl(i,nz+1) = kv_bbl(i) / ((min(dhc, bbl_thick(i)) + h_neglect) + I_amax*kv_bbl(i)) endif ; enddo 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 diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 76546f834c..1b1fd85316 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -180,7 +180,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & 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 or kg m-2]. + ! 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] diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index fe20daaefd..f9aa421f86 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -490,7 +490,7 @@ subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US 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] + 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, is, ie, js, je, m @@ -516,7 +516,7 @@ subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US ! 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] kw_coeff = (US%m_to_Z*US%s_to_T*US%L_to_m**2) * 6.97e-7 ! set unit conversion factors @@ -552,7 +552,7 @@ subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US 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) CS%CFC_data(1)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(1)%conc(i,j,1)) * Rho0 diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 7947cc72ed..0a80cfaf2f 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -451,7 +451,7 @@ 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, turns=G%HI%turns) call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index aac951d698..4a822592fb 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -143,10 +143,13 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) + call get_param(param_file, mdl, "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=.true.) + "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, & @@ -414,7 +417,7 @@ subroutine hbd_grid(boundary, G, GV, hbl, h, CS) end subroutine hbd_grid -!> Calculate the harmonic mean of two quantities +!> Calculate the harmonic mean of two quantities [arbitrary] !! See \ref section_harmonic_mean. real function harmonic_mean(h1,h2) real :: h1 !< Scalar quantity [arbitrary] diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 1aaf7409d2..6e9f9c9f06 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -238,10 +238,12 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(param_file, mdl, "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=.true.) + "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, & om4_remap_via_sub_cells=om4_remap_via_sub_cells, & @@ -1129,6 +1131,7 @@ 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 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 @@ -1287,9 +1290,9 @@ 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 [H ~> m or kg m-2] or other arbitrary units @@ -1570,7 +1573,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] @@ -1873,7 +1876,8 @@ 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 diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index cf18210cc5..4adf8de293 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -654,7 +654,7 @@ subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, s logical :: do_ale real :: convert_to_H ! A scale conversion factor from the thickness units in the - ! file to H [H m-1 or H m2 kg-1 ~> 1] + ! file to H [H m-1 ~> 1] or [H m2 kg-1 ~> 1] integer :: i, j, k, is, ie, js, je, nz do_ale = .false. diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index f772e0bc8a..b0537955ef 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -625,27 +625,24 @@ real function remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: trans_rem_col !< The vertical sum of the absolute value of - !! transports through the faces of a column, in MKS units [kg]. + !! 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] - real :: HL2_to_kg_scale !< Unit conversion factor to cell mass [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 - HL2_to_kg_scale = GV%H_to_kg_m2 * US%L_to_m**2 - trans_rem_col(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie 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) + HL2_to_kg_scale * trans_cell + trans_rem_col(i,j) = trans_rem_col(i,j) + GV%H_to_RZ * trans_cell enddo ; enddo ; enddo ! The factor of 0.5 here is to avoid double-counting because two cells share a face. - remaining_transport_sum = 0.5 * GV%kg_m2_to_H*US%m_to_L**2 * & - reproducing_sum(trans_rem_col, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) + 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 @@ -673,7 +670,7 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p 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 :: 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] + 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 :: Kd_bot ! Near-bottom diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -876,8 +873,8 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, 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 - ! fluxes through the faces of a column or within a column, in mks units [kg] - real :: sum_flux ! Globally summed absolute value of fluxes in mks units [kg], which is + ! 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)) :: & @@ -890,7 +887,6 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, ! Work arrays for temperature and salinity integer :: iter real :: dt_iter ! The timestep of each iteration [T ~> s] - real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] character(len=160) :: mesg ! The text of an error message integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -993,22 +989,22 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, call pass_vector(uhtr,vhtr,G%Domain) ! Calculate how close we are to converging by summing the remaining fluxes at each point - HL2_to_kg_scale = US%L_to_m**2*GV%H_to_kg_m2 rem_col_flux(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - rem_col_flux(i,j) = rem_col_flux(i,j) + HL2_to_kg_scale * & + 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 - sum_flux = reproducing_sum(rem_col_flux, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) + 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) 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 + write(mesg,*) "offline_advection_layer: Iteration ", iter, " remaining total fluxes: ", sum_flux*US%RZL2_to_kg call MOM_mesg(mesg) endif diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 0e129b2d03..13fc5499c3 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -18,6 +18,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,11 +34,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 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 @@ -108,6 +109,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first 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. @@ -117,6 +120,9 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first landvolfill = 1.0e-20 ! This is arbitrary, but must be positive. 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.") if (.not. associated(Reg)) call MOM_error(FATAL, "MOM_tracer_advect: "// & @@ -125,12 +131,30 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first call cpu_clock_begin(id_clock_advect) x_first = (MOD(G%first_direction,2) == 0) - ! increase stencil size for Colella & Woodward PPM - use_PPM_stencil = CS%usePPM .and. .not. CS%useHuynhStencilBug - if (use_PPM_stencil) 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 - 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 @@ -252,14 +276,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first do k=1,nz ; if (domore_k(k) > 0) then ! First, advect zonally. call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & - isv, iev, jsv-stencil, jev+stencil, k, G, GV, US, CS%usePPM, CS%useHuynh) + 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(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & - isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + isv, iev, jsv, jev, k, G, GV, US, local_advect_scheme) ! Update domore_k(k) for the next iteration domore_k(k) = 0 @@ -274,14 +299,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first do k=1,nz ; if (domore_k(k) > 0) then ! First, advect meridionally. call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & - isv-stencil, iev+stencil, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + 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(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & - isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + isv, iev, jsv, jev, k, G, GV, US, local_advect_scheme) ! Update domore_k(k) for the next iteration domore_k(k) = 0 @@ -327,7 +353,7 @@ 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 @@ -348,9 +374,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & 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]. @@ -393,10 +417,14 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! 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) @@ -513,69 +541,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 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 + 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 @@ -648,6 +678,21 @@ 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 ((OBC%exterior_OBC_bug .eqv. .false.) .and. (OBC%OBC_pe)) then + if (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally) then + do i=is,ie-1 ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do_i(i+1,j) = .false. + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + do_i(i,j) = .false. + endif + endif ; enddo + endif + endif + endif + ! update tracer concentration from i-flux and save some diagnostics do m=1,ntr @@ -670,7 +715,8 @@ 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 @@ -703,7 +749,7 @@ 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 @@ -724,9 +770,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & 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]. @@ -765,10 +809,14 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & 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) @@ -785,7 +833,9 @@ 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 @@ -899,68 +949,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 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 + 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 @@ -980,7 +1033,9 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & 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 + else + flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc + endif enddo endif enddo @@ -1039,6 +1094,26 @@ 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 ((OBC%exterior_OBC_bug .eqv. .false.) .and. (OBC%OBC_pe)) then + if (OBC%specified_v_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then + do i=is,ie + if (OBC%segnum_v(i,J-1) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J-1))%direction == OBC_DIRECTION_N) then + do_i(i,j) = .false. + endif + endif + if (OBC%segnum_v(i,J) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + do_i(i,j) = .false. + endif + endif + enddo + endif + endif + endif + ! update tracer and save some diagnostics do m=1,ntr do i=is,ie ; if (do_i(i,j)) then @@ -1050,7 +1125,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, 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_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 @@ -1115,26 +1191,12 @@ 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 - - if (CS%usePPM) then - if (CS%useHuynh) then + 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. " & @@ -1142,7 +1204,6 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) // "configurations, but may be required to reproduce results in " & // "legacy simulations.", & default=.false.) - endif endif id_clock_advect = cpu_clock_id('(Ocean advect tracer)', grain=CLOCK_MODULE) @@ -1169,19 +1230,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 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. +!! * 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. +!! +!! 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..630f451cfa --- /dev/null +++ b/src/tracer/MOM_tracer_advect_schemes.F90 @@ -0,0 +1,43 @@ +!> This module contains constants for the tracer advection schemes. +module MOM_tracer_advect_schemes + +! This file is part of MOM6. See LICENSE.md for the license. + +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_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index f144faf69e..9c69a06c7c 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -30,7 +30,8 @@ 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 @@ -50,12 +51,13 @@ module MOM_tracer_registry !> 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, 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, & + 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, underflow_conc, Tr_out) + 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 @@ -129,6 +131,9 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit !! 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() character(len=256) :: mesg ! Message for error messages. @@ -229,6 +234,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 @@ -244,7 +252,9 @@ 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. @@ -367,7 +377,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u 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., & + "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", & @@ -385,11 +396,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') 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), & + 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_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & - diag%axesCvL, Time, "Horizontal Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + 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 @@ -435,7 +448,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u 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) @@ -446,7 +459,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u 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, & @@ -471,45 +485,58 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u 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, & + x_cell_method='sum', y_cell_method='sum', 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') 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, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + diag%axesTL, Time, "Horizontal boundary 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_2d = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency_2d', & + 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, & x_cell_method='sum', y_cell_method='sum') else cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& - trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' + 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)), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, & + cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff', & + cmor_long_name=trim(cmor_var_lname), & + cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& - trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' - Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & + 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)), & + 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_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & - diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & + diag%axesTL, Time, & + "Horizontal boundary 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_2d = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency_2d', & + 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, & x_cell_method='sum', y_cell_method='sum') @@ -519,7 +546,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u trim(units)//' s-1', conversion=Tr%conc_scale*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), & + 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) @@ -596,11 +624,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u ! 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=GV%H_to_m*US%s_to_T) + 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=US%s_to_T) + ', 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 @@ -613,7 +641,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u ! 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', & + 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 @@ -707,7 +736,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 @@ -867,10 +897,12 @@ subroutine tracer_array_chkinv(mesg, G, GV, h, Tr, ntr) 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)%conc_scale*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 + 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 @@ -899,10 +931,12 @@ subroutine tracer_Reg_chkinv(mesg, G, GV, h, Reg) 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)) + 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", Reg%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 tracer_Reg_chkinv diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90 index 6809c865ee..5bc7c7eda3 100644 --- a/src/tracer/MOM_tracer_types.F90 +++ b/src/tracer/MOM_tracer_types.F90 @@ -68,7 +68,7 @@ module MOM_tracer_types 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 [conc CU ~> 1] + !! 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 @@ -99,6 +99,7 @@ module MOM_tracer_types ! 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 diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 2cc4654691..c1146e19f9 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -24,6 +24,7 @@ module regional_dyes 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_advect_schemes, only : set_tracer_advect_scheme, TracerAdvectionSchemeDoc implicit none ; private @@ -63,7 +64,7 @@ module regional_dyes 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 @@ -85,11 +86,15 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) character(len=40) :: mdl = "regional_dyes" ! This module's name. character(len=48) :: var_name ! The variable's name. character(len=48) :: desc_name ! The variable's descriptor. + 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 @@ -156,11 +161,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) @@ -173,7 +186,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 @@ -420,5 +434,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 0d04936c26..4490c711f8 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -13,12 +13,17 @@ 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_open_boundary, only : OBC_segment_type, register_segment_tracer +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 @@ -36,6 +41,9 @@ module dyed_obc_tracer 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 [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. @@ -69,6 +77,10 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) 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 @@ -79,9 +91,21 @@ function register_dyed_obc_tracer(HI, GV, 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, "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)) @@ -97,10 +121,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" @@ -109,11 +144,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 @@ -158,24 +196,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 @@ -264,5 +302,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/nw2_tracers.F90 b/src/tracer/nw2_tracers.F90 index b4e652a58a..f93c6d4c69 100644 --- a/src/tracer/nw2_tracers.F90 +++ b/src/tracer/nw2_tracers.F90 @@ -270,7 +270,7 @@ 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 diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 858ca32f93..e608dbd1c2 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -49,10 +49,11 @@ subroutine DOME_initialize_topography(D, G, param_file, max_depth, US) 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 [km] - real :: inflow_lon ! The edge longitude of the DOME inflow [km] - real :: inflow_width ! The longitudinal width of the DOME inflow channel [km] - real :: km_to_L ! The conversion factor from the units of latitude to L [L km-1 ~> 1e3] + 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. @@ -60,7 +61,16 @@ 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 - km_to_L = 1.0e3*US%m_to_L + 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) @@ -75,15 +85,16 @@ subroutine DOME_initialize_topography(D, G, param_file, max_depth, US) 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") + 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) + "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) + "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) < shelf_edge_lat) then - D(i,j) = min(shelf_depth - slope * (G%geoLatT(i,j)-shelf_edge_lat)*km_to_L, max_depth) + 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) > inflow_lon) .AND. (G%geoLonT(i,j) < inflow_lon+inflow_width)) then D(i,j) = shelf_depth @@ -177,7 +188,6 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) 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 [T-1 ~> s-1] real :: peak_damping ! The maximum sponge damping rates as the edges [T-1 ~> s-1] - real :: km_to_L ! The conversion factor from the units of longitude to L [L km-1 ~> 1e3] 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. @@ -186,7 +196,8 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) 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 - km_to_L = 1.0e3*US%m_to_L + 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, & @@ -196,7 +207,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) 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 the DOME sponges.", & - default=200.0, units="km", scale=km_to_L) + 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 @@ -204,7 +215,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) 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) * km_to_L + 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 @@ -213,7 +224,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)) * km_to_L + 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 @@ -328,10 +339,12 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) ! 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 [L ~> m] - real :: inflow_lon ! The edge longitude of the DOME inflow [km] + 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] + 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. 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 @@ -343,6 +356,17 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, 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 + 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) @@ -362,7 +386,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) "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) + "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.) @@ -383,7 +407,9 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) 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*Def_Rad) + 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.) diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index d03a07e313..4bf7931856 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -59,7 +59,6 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) 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] - real :: km_to_L ! The conversion factor from the axis units to L [L km-1 ~> 1e3] logical :: is_2D ! If true, use a 2D setup ! This include declares and sets the variable "version". # include "version_variable.h" @@ -93,7 +92,8 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) "Characteristic width of the side walls of the channel in the ISOMIP configuration.", & units="m", default=4.0e3, scale=US%m_to_L) - km_to_L = 1.0e3*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 @@ -101,8 +101,8 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) if (is_2D) then do j=js,je ; do i=is,ie ! For the 2D setup take a slice through the middle of the domain - xtil = G%geoLonT(i,j)*km_to_L / xbar - !xtil = 450.*km_to_L / xbar + 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 = 2.0 * dc / (1.0 + exp(2.0*wc / fc)) @@ -117,17 +117,17 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) ! 3D setup ! ===== TEST ===== !if (G%geoLonT(i,j)<500.) then - ! xtil = 500.*km_to_L / xbar + ! xtil = 500.0e3*US%m_to_L / xbar !else - ! xtil = G%geoLonT(i,j)*km_to_L / xbar + ! xtil = G%geoLonT(i,j)*G%grid_unit_to_L / xbar !endif ! ===== TEST ===== - xtil = G%geoLonT(i,j)*km_to_L / 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.0 + exp(-2.*(G%geoLatT(i,j)*km_to_L - 0.5*ly - wc) / fc))) + & - (dc / (1.0 + exp(2.*(G%geoLatT(i,j)*km_to_L - 0.5*ly + 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 diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index b96b363e3a..d9d46f7d6e 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -14,9 +14,7 @@ module Idealized_hurricane ! 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 -! +! 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 @@ -37,8 +35,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 @@ -55,7 +51,7 @@ module Idealized_hurricane 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 @@ -317,7 +313,7 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) 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_m2s_to_RZ_T*US%m_s_to_L_T, do_not_log=.true.) + 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.") @@ -353,7 +349,6 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) real :: fbench !< The benchmark 'f' value [T-1 ~> s-1] real :: fbench_fac !< A factor that is set to 0 to use the !! benchmark 'f' value [nondim] - real :: km_to_L !< The conversion factor from the units of latitude to L [L km-1 ~> 1e3] real :: rel_tau_fac !< A factor that is set to 0 to disable !! current relative stress calculation [nondim] @@ -363,7 +358,8 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - km_to_L = 1.0e3*US%m_to_L + 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., tau_mag=.true.) @@ -380,7 +376,6 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) YC = CS%Hurr_cen_Y0 + (time_type_to_real(day)*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 = CS%f_column @@ -407,8 +402,8 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) YY = CS%dy_from_center - YC XX = -XC else - YY = G%geoLatCu(I,j)*km_to_L - YC - XX = G%geoLonCu(I,j)*km_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 @@ -431,8 +426,8 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) YY = CS%dy_from_center - YC XX = -XC else - YY = G%geoLatCv(i,J)*km_to_L - YC - XX = G%geoLonCv(i,J)*km_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 @@ -442,16 +437,16 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) !> Get Ustar 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(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)) + 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 L Z T-2 ~> Pa] + !> 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 + & - 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 * 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 end subroutine idealized_hurricane_wind_forcing @@ -656,196 +651,6 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx 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 :: 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 ! The radius of the maximum winds raised to the power given by B, used in the - ! wind profile expression, in [km^B] - real :: B ! A power used in the wind profile expression [nondim] - real :: C ! A temporary variable in units of the square root of a specific volume [sqrt(m3 kg-1)] - real :: rad ! The distance from the hurricane center [L ~> m] - real :: radius10 ! The distance from the hurricane center to its edge [L ~> m] - real :: rkm ! The distance from the hurricane center, sometimes scaled to km [L ~> m] or [1000 L ~> km] - real :: f_local ! The local Coriolis parameter [T-1 ~> s-1] - real :: xx ! x-position [L ~> m] - real :: t0 ! Time at which the eye crosses the origin [T ~> s] - real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] - real :: rB ! The distance from the center raised to the power given by B, in [m^B] - ! or [km^B] if BR_Bench is true. - real :: Cd ! Air-sea drag coefficient [nondim] - real :: Uocn, Vocn ! Surface ocean velocity components [L T-1 ~> m s-1] - real :: dU, dV ! Air-sea differential motion [L T-1 ~> m s-1] - ! Wind angle variables - real :: Alph ! The wind inflow angle (positive outward) [radians] - real :: Rstr ! A function of the position normalized by the radius of maximum winds [nondim] - real :: A0 ! The axisymmetric inflow angle [degrees] - real :: A1 ! The inflow angle asymmetry [degrees] - real :: P1 ! The angle difference between the translation direction and the inflow direction [radians] - real :: Adir ! The angle of the direction from the center to a point [radians] - real :: transdir ! Translation direction [radians] - real :: V_TS, U_TS ! Components of the translation speed [L T-1 ~> m s-1] - - ! 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., tau_mag=.true.) - - ! Implementing Holland (1980) parameteric wind profile - !------------------------------------------------------------| - t0 = 129600.*US%s_to_T ! TC 'eye' crosses (0,0) at 36 hours | - transdir = CS%pi ! translation direction (-x) | - !------------------------------------------------------------| - dP = CS%pressure_ambient - CS%pressure_central - if (CS%answer_date < 20190101) then - C = CS%max_windspeed / sqrt( US%R_to_kg_m3*dP ) - B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) - if (CS%BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test - B = C**2 * 1.2 * exp(1.0) - endif - else - B = (CS%max_windspeed**2 / dP ) * CS%rho_a * exp(1.0) - endif - - if (CS%BR_Bench) then - A = (US%L_to_m*CS%rad_max_wind / 1000.)**B - else - A = (US%L_to_m*CS%rad_max_wind)**B - endif - ! f_local = f(x,y), but in the SCM it is constant - if (CS%BR_Bench) then ! (CS%SCM_mode) then - f_local = CS%f_column - else - f_local = G%CoriolisBu(is,js) - endif - - ! Calculate x position relative to hurricane center as a function of time. - xx = (t0 - time_type_to_real(day)*US%s_to_T) * CS%hurr_translation_spd * cos(transdir) - rad = sqrt((xx**2) + (CS%dy_from_center**2)) - - ! 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 (CS%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 - - ! Calculate U10 in the interior (inside of the hurricane edge radius), - ! while adjusting U10 to 0 outside of the ambient wind radius. - if (rad > 0.001*CS%rad_max_wind .AND. rad < CS%rad_edge*CS%rad_max_wind) then - U10 = sqrt( A*B*dP*exp(-A/rB)/(CS%rho_a*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local - elseif (rad > CS%rad_edge*CS%rad_max_wind .AND. rad < CS%rad_ambient*CS%rad_max_wind) then - radius10 = CS%rad_max_wind*CS%rad_edge - if (CS%BR_Bench) then - rkm = radius10/1000. - rB = (US%L_to_m*rkm)**B - else - rkm = radius10 - rB = (US%L_to_m*radius10)**B - endif - if (CS%edge_taper_bug) rad = radius10 - U10 = ( sqrt( A*B*dP*exp(-A/rB)/(CS%rho_a*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & - * (CS%rad_ambient - rad/CS%rad_max_wind)/(CS%rad_ambient - CS%rad_edge) - else - U10 = 0. - endif - Adir = atan2(CS%dy_from_center,xx) - - ! Wind angle model following Zhang and Ulhorn (2012) - ! ALPH is inflow angle positive outward. - RSTR = min(CS%rad_edge, rad / CS%rad_max_wind) - A0 = CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed + CS%A0_0 - A1 = -A0*(CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd + CS%A1_0) - P1 = (CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd + CS%P1_0) * CS%pi/180. - ALPH = A0 - A1*cos( (TRANSDIR - ADIR ) - P1) - if (rad > CS%rad_edge*CS%rad_max_wind .AND. rad < CS%rad_ambient*CS%rad_max_wind) then - ALPH = ALPH* (CS%rad_ambient - rad/CS%rad_max_wind) / (CS%rad_ambient - CS%rad_edge) - elseif (rad > CS%rad_ambient*CS%rad_max_wind) then - ALPH = 0.0 - endif - ALPH = ALPH * CS%Deg2Rad - - ! 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 - ! 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)) ) - ! 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 - CS%pi - Alph) - Uocn + U_TS - dV = U10*cos(Adir - Alph) - Vocn + V_TS - !/----------------------------------------------------| - ! Add a simple drag coefficient as a function of U10 | - !/----------------------------------------------------| - du10 = sqrt((du**2) + (dv**2)) - Cd = simple_wind_scaled_Cd(u10, du10, CS) - - forces%taux(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCu(I,j) * Cd*du10*dU - enddo ; enddo - - ! 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 - CS%pi - Alph) - Uocn + U_TS - dV = U10*cos(Adir-Alph) - Vocn + V_TS - du10 = sqrt((du**2) + (dv**2)) - Cd = simple_wind_scaled_Cd(u10, du10, CS) - forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV - enddo ; enddo - - ! Set the surface friction velocity [Z T-1 ~> m s-1]. ustar 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(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 ; endif - - !> Set magnitude of the wind stress [R L Z 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 + & - 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 - -end subroutine SCM_idealized_hurricane_wind_forcing - !> This function returns the air-sea drag coefficient using a simple function of the air-sea velocity difference. function simple_wind_scaled_Cd(u10, du10, CS) result(Cd) real, intent(in) :: U10 !< The 10 m wind speed [L T-1 ~> m s-1] diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 1fc8a2f564..a18c5bd136 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -45,6 +45,9 @@ module Kelvin_initialization 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. end type Kelvin_OBC_CS ! This include declares and sets the variable "version". @@ -114,10 +117,21 @@ function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) "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/(0.3*86400.), scale=US%s_to_T) + !### Change the default nudging timescale to -1. or another value? + ! 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. @@ -193,12 +207,12 @@ 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 ! 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] 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] @@ -215,10 +229,11 @@ 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) PI = 4.0*atan(1.0) - km_to_L_scale = 1000.0*US%m_to_L do j=jsd,jed ; do i=isd,ied depth_tot(i,j) = 0.0 @@ -232,11 +247,14 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) omega = 2.0 * PI / CS%wave_period val1 = sin(omega * time_sec) else - mag_int = CS%inflow_amp**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 sina = sin(CS%coast_angle) @@ -248,17 +266,17 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) 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 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 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) + x1 = G%grid_unit_to_L * G%geoLonCu(I,j) + y1 = G%grid_unit_to_L * G%geoLatCu(I,j) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = -(x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then @@ -278,18 +296,26 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo endif else - ! Baroclinic, not rotated yet + ! Baroclinic, not rotated yet (and apparently not working as intended yet). segment%SSH(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 + ! 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(omega * time_sec) + ! 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(omega * time_sec) + ! 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 * & + segment%nudged_normal_vel(I,j,k) = mag_int * & exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & cos(omega * time_sec) enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & + segment%normal_vel(I,j,k) = mag_int * & 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) @@ -299,8 +325,8 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) 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) + 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+1,j) ) @@ -316,8 +342,8 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do J=JsdB,JedB ; do i=isd,ied - x1 = km_to_L_scale * G%geoLonCv(i,J) - y1 = km_to_L_scale * G%geoLatCv(i,J) + x1 = G%grid_unit_to_L * G%geoLonCv(i,J) + y1 = G%grid_unit_to_L * G%geoLatCv(i,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then @@ -336,17 +362,17 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo endif else - ! Not rotated yet + ! 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) = mag_int * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & + segment%normal_vel(i,J,k) = 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) enddo @@ -355,8 +381,8 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) 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) + 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) ) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index be9399ef01..dc34768182 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -315,7 +315,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) 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 @@ -798,8 +798,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) MidPoint = 0.0 do k = 1,GV%ke Top = Bottom - 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)) + 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 @@ -810,8 +810,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) MidPoint = 0.0 do k = 1,GV%ke Top = Bottom - 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)) + 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 @@ -837,7 +837,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) bottom = 0.0 do k = 1,GV%ke Top = Bottom - level_thick = 0.5*(dz(I,j,k)+dz(I-1,j,k)) + level_thick = 0.5*(dz(i,j,k)+dz(i+1,j,k)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick @@ -894,7 +894,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) bottom = 0.0 do k = 1,GV%ke Top = Bottom - level_thick = 0.5*(dz(i,J,k)+dz(i,J-1,k)) + level_thick = 0.5*(dz(i,j,k)+dz(i,j+1,k)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick @@ -947,8 +947,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) bottom = 0.0 do k = 1,GV%ke Top = Bottom - 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)) + 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 @@ -964,8 +964,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) Bottom = 0.0 do k = 1,GV%ke Top = Bottom - 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)) + 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 @@ -1033,7 +1033,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) 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 ! A rational fraction [nondim] @@ -1045,7 +1045,7 @@ real function one_minus_exp_x(x) endif end function one_minus_exp_x -!> Return the value of (1 - exp(-x)), using an accurate expression for small values of x. +!> 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] @@ -1688,8 +1688,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 @@ -1698,8 +1698,8 @@ 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 diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 98eca06d6b..ba8263ca1c 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -82,7 +82,7 @@ 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 !< Position in arbitrary units [A] real , intent(in) :: L !< Width in arbitrary units [A] @@ -92,7 +92,7 @@ real function cosbell(x, L) 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 !< Position in arbitrary units [A] @@ -104,7 +104,7 @@ real function spike(x, L) 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) @@ -117,7 +117,7 @@ real function cone(x, x0, L, clip) 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 !< Coordinate in arbitrary units [A] real, intent(in) :: x0 !< position of peak in arbitrary units [A] @@ -130,7 +130,7 @@ end function scurve ! None of the following 7 functions appear to be used. -!> Returns a "coastal" profile. +!> Returns a "coastal" profile [nondim]. real function cstprof(x, x0, L, lf, bf, sf, sh) real, intent(in) :: x !< Coordinate in arbitrary units [A] real, intent(in) :: x0 !< position of peak in arbitrary units [A] @@ -145,7 +145,7 @@ real function cstprof(x, x0, L, lf, bf, sf, sh) 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 !< X-coordinate in arbitrary units [A] real, intent(in) :: y !< Y-coordinate in arbitrary units [A] @@ -160,7 +160,7 @@ real function dist_line_fixed_x(x, y, x0, y0, y1) 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 !< X-coordinate in arbitrary units [A] real, intent(in) :: y !< Y-coordinate in arbitrary units [A] @@ -171,7 +171,7 @@ real function dist_line_fixed_y(x, y, x0, x1, y0) 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] @@ -186,7 +186,7 @@ real function NS_coast(lon, lat, lon0, lat0, lat1, dlon, sh) 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] @@ -201,7 +201,7 @@ real function EW_coast(lon, lat, lon0, lon1, lat0, dlat, sh) 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] @@ -217,7 +217,7 @@ real function NS_ridge(lon, lat, lon0, lat0, lat1, dlon, rh) 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] diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index e0d2cafeae..4a115031e1 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -50,11 +50,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 @@ -63,6 +66,17 @@ 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) @@ -70,12 +84,12 @@ subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, ju "The fractional depth where the stratification is centered.", & 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, & @@ -139,61 +153,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 @@ -203,10 +272,10 @@ 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 @@ -240,12 +309,15 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) 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 [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 [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. @@ -255,6 +327,17 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) 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 @@ -268,12 +351,11 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) 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, & @@ -294,7 +376,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) @@ -351,8 +432,7 @@ 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 diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 33c7641a00..05a223cfb9 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -221,7 +221,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just 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 :: 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 @@ -250,6 +250,8 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just 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 @@ -335,18 +337,16 @@ end function Hml 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 [C ~> degC] - real, intent(in) :: lat !< Latitude in [km] + 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 ! 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] - real :: km_to_L ! Horizontal axis unit conversion factor when AXIS_UNITS = 'k' (1000 m) [L km-1 ~> 1000] PI = 4.0 * atan(1.0) - km_to_L = 1.0e3*US%m_to_L dHML = 0.5 * ( HMLmax - HMLmin ) * G%max_depth - dHdy = dHML * ( PI / ( frontFractionalWidth * G%len_lat * km_to_L ) ) * 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 46cf6423d4..def4c59568 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -202,7 +202,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 ! The magnitude of the wind stress [R L Z T-2 ~> Pa] + 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 @@ -217,9 +217,9 @@ 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 diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index c9faa0739c..721b0b33cc 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -157,7 +157,7 @@ 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) @@ -170,7 +170,7 @@ real function cone(x, x0, L, clip) 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 !< Coordinate in arbitrary units [A] real, intent(in) :: x0 !< position of peak in arbitrary units [A] @@ -181,7 +181,7 @@ real function scurve(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 !< Coordinate in arbitrary units [A] real, intent(in) :: x0 !< position of peak in arbitrary units [A] @@ -196,7 +196,7 @@ real function cstprof(x, x0, L, lf, bf, sf, sh) 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 !< X-coordinate in arbitrary units [A] real, intent(in) :: y !< Y-coordinate in arbitrary units [A] @@ -211,7 +211,7 @@ real function dist_line_fixed_x(x, y, x0, y0, y1) 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 !< X-coordinate in arbitrary units [A] real, intent(in) :: y !< Y-coordinate in arbitrary units [A] @@ -222,7 +222,7 @@ real function dist_line_fixed_y(x, y, x0, x1, y0) 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] @@ -238,7 +238,7 @@ real function angled_coast(lon, lat, lon_eq, lat_mer, dr, sh) 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] @@ -253,7 +253,7 @@ real function NS_coast(lon, lat, lonC, lat0, lat1, dlon, sh) 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] @@ -268,7 +268,7 @@ real function EW_coast(lon, lat, latC, lon0, lon1, dlat, sh) 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] @@ -283,7 +283,7 @@ real function NS_conic_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) 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] @@ -298,7 +298,7 @@ real function NS_scurve_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) 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] @@ -316,7 +316,7 @@ real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness 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] diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 7d1c0635f9..ffa217e0b5 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -1,4 +1,4 @@ -!> Dyed open boundary conditions +!> Dyed open boundary conditions; OBC_USER_CONFIG="dyed_obcs" module dyed_obcs_initialization ! This file is part of MOM6. See LICENSE.md for the license. @@ -23,6 +23,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,11 +37,13 @@ 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 :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz, ntr_id integer :: IsdB, IedB, JsdB, JedB + integer :: n_dye ! Number of regionsl dye tracers real :: dye ! Inflow dye concentration [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() @@ -50,10 +53,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") @@ -63,13 +81,13 @@ 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, 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 diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index 722a41b7e5..a734574995 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -79,10 +79,12 @@ subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US, param_file, jus 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 = US%m_to_L / L_eq + scale_pos = G%grid_unit_to_L / L_eq I_nz = 1.0 / real(nz) x0 = 2.0*G%len_lon/3.0 @@ -150,10 +152,12 @@ subroutine soliton_initialize_velocity(u, v, G, GV, US, param_file, just_read) 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 = US%m_to_L / L_eq + scale_pos = G%grid_unit_to_L / L_eq x0 = 2.0*G%len_lon/3.0 y0 = 0.0 diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index c2ca2565ce..5b300a4d05 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -78,8 +78,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] real :: total_area ! The total face area of the OBCs [L Z ~> m2] real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] - 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] + real, allocatable :: my_area(:,:) ! The total OBC inflow area [L Z ~> m2] 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() @@ -94,8 +93,6 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) allocate(my_area(1:1,js:je)) - flux_scale = GV%H_to_m*US%L_to_m - time_sec = US%s_to_T*time_type_to_real(Time) cff_eta = CS%tide_ssh_amp * sin(2.0*PI*time_sec / CS%tide_period) my_area = 0.0 @@ -105,12 +102,11 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB if (OBC%segnum_u(I,j) /= OBC_NONE) then do k=1,nz - ! 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) + 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 - total_area = US%m_to_Z*US%m_to_L * reproducing_sum(my_area) + 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) do n = 1, OBC%number_of_segments diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 9a56c12b9c..1a1881a42b 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -230,14 +230,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="degrees_N", 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.", &