diff --git a/.github/actions/testing-setup/action.yml b/.github/actions/testing-setup/action.yml deleted file mode 100644 index 60499d4be1..0000000000 --- a/.github/actions/testing-setup/action.yml +++ /dev/null @@ -1,45 +0,0 @@ -name: 'Build-.testing-prerequisites' -description: 'Build pre-requisites for .testing including FMS and a symmetric MOM6 executable' -inputs: - build_symmetric: - description: 'If true, will build the symmetric MOM6 executable' - required: false - default: 'true' -runs: - using: 'composite' - steps: - - name: Git info - shell: bash - run: | - echo "::group::Git commit info" - echo "git log:" - git log | head -60 - echo "::endgroup::" - - - name: Env - shell: bash - run: | - echo "::group::Environment" - env - echo "::endgroup::" - - - name: Compile FMS library - shell: bash - run: | - echo "::group::Compile FMS library" - cd .testing - REPORT_ERROR_LOGS=true make build/deps/lib/libFMS.a -s -j - echo "::endgroup::" - - - name: Compile MOM6 in symmetric memory mode - shell: bash - run: | - echo "::group::Compile MOM6 in symmetric memory mode" - cd .testing - test ${{ inputs.build_symmetric }} == true && make build/symmetric/MOM6 -j - echo "::endgroup::" - - - name: Set flags - shell: bash - run: | - echo "TIMEFORMAT=... completed in %lR (user: %lU, sys: %lS)" >> $GITHUB_ENV diff --git a/.github/workflows/verify-linux.yml b/.github/workflows/verify-linux.yml index c15daee448..4c2817f4ee 100644 --- a/.github/workflows/verify-linux.yml +++ b/.github/workflows/verify-linux.yml @@ -2,8 +2,13 @@ name: Linux verification on: [push, pull_request] +env: + MOM_TARGET_SLUG: ${{ github.repository }} + MOM_TARGET_LOCAL_BRANCH: ${{ github.base_ref }} + jobs: # Documentation + check-style-and-docstrings: runs-on: ubuntu-latest @@ -38,34 +43,10 @@ jobs: 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 @@ -74,25 +55,23 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - name: Compile MOM6 with symmetric indexing - run: | - make -C .testing build/symmetric/MOM6 -j \ - -o build/deps/lib/libFMS.a + run: make -C .testing -j build/symmetric/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-symmetric.tar .testing/build/symmetric/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-symmetric-artifact - path: .testing/build/symmetric/MOM6 + path: mom6-symmetric.tar retention-days: 1 build-asymmetric: runs-on: ubuntu-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -101,25 +80,23 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - name: Compile MOM6 with asymmetric indexing - run: | - make -C .testing build/asymmetric/MOM6 -j \ - -o build/deps/lib/libFMS.a + run: make -C .testing -j build/asymmetric/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-asymmetric.tar .testing/build/asymmetric/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-asymmetric-artifact - path: .testing/build/asymmetric/MOM6 + path: mom6-asymmetric.tar retention-days: 1 build-repro: runs-on: ubuntu-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -128,25 +105,23 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - - name: Compile repro - run: | - make -C .testing build/repro/MOM6 -j \ - -o build/deps/lib/libFMS.a + - name: Compile MOM6 with bit-reproducible optimization + run: make -C .testing -j build/repro/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-repro.tar .testing/build/repro/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-repro-artifact - path: .testing/build/repro/MOM6 + path: mom6-repro.tar retention-days: 1 build-openmp: runs-on: ubuntu-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -155,24 +130,24 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - name: Compile MOM6 supporting OpenMP - run: make -C .testing build/openmp/MOM6 -j -o build/deps/lib/libFMS.a + run: make -C .testing -j build/openmp/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-openmp.tar .testing/build/openmp/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-openmp-artifact - path: .testing/build/openmp/MOM6 + path: mom6-openmp.tar retention-days: 1 build-target: if: github.event_name == 'pull_request' runs-on: ubuntu-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -181,29 +156,31 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile target FMS + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + build/target_codebase + make -C .testing/build/target_codebase/.testing -j \ + build/deps/lib/libFMS.a - name: Compile target MOM6 run: | - make -C .testing 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 + make -C .testing -j \ + DO_REGRESSION_TESTS=1 \ + build/target/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-target.tar .testing/build/target/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-target-artifact - path: .testing/build/target/MOM6 + path: mom6-target.tar retention-days: 1 build-opt: - if: github.event_name == 'pull_request' runs-on: ubuntu-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -212,39 +189,31 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - - name: Compile optimized model - run: | - make -C .testing build/opt/MOM6 -j \ - -o build/deps/lib/libFMS.a + - name: Compile MOM6 with aggressive optimization + run: make -C .testing -j build/opt/MOM6 - - uses: actions/upload-artifact@v4 - with: - name: mom6-opt-artifact - path: .testing/build/opt/MOM6 - retention-days: 1 + - name: Compile timing tests + run: make -C .testing build.timing - - name: Compile unit tests + - name: Prepare artifact run: | - make -C .testing build.timing -j \ - -o build/deps/lib/libFMS.a + tar -cf mom6-opt.tar \ + --exclude='.testing/build/timing/time_*.o' \ + .testing/build/opt/MOM6 \ + .testing/build/timing/time_* - uses: actions/upload-artifact@v4 with: - name: mom6-unit-artifact - path: | - .testing/build/timing/time_MOM_EOS - .testing/build/timing/time_MOM_remapping + name: mom6-opt-artifact + path: mom6-opt.tar retention-days: 1 build-opt-target: if: github.event_name == 'pull_request' runs-on: ubuntu-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -253,45 +222,41 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile target FMS + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + build/target_codebase + make -C .testing/build/target_codebase/.testing -j \ + build/deps/lib/libFMS.a - name: Compile target MOM6 run: | - make -C .testing 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 + make -C .testing -j \ + DO_REGRESSION_TESTS=1 \ + build/opt_target/MOM6 - - uses: actions/upload-artifact@v4 - with: - name: mom6-opt-target-artifact - path: .testing/build/opt_target/MOM6 - retention-days: 1 + - name: Compile target timing tests + run: | + make -C .testing/build/target_codebase/.testing \ + DO_REGRESSION_TESTS=1 \ + build.timing - - name: Compile target unit tests + - name: Prepare artifact 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 + tar -cf mom6-opt-target.tar \ + --exclude='.testing/build/target_codebase/.testing/build/timing/time_*.o' \ + .testing/build/opt_target/MOM6 \ + .testing/build/target_codebase/.testing/build/timing/time_* - # 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 + name: mom6-opt-target-artifact + path: mom6-opt-target.tar retention-days: 1 build-coverage: runs-on: ubuntu-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -300,39 +265,34 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - name: Compile MOM6 with code coverage - run: make -C .testing build/cov/MOM6 -j -o build/deps/lib/libFMS.a + run: make -C .testing -j build/cov/MOM6 - 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 + make -C .testing -j build/unit/test_MOM_file_parser + make -C .testing -j build.unit + + - name: Prepare artifact + run: | + tar -cf mom6-coverage.tar \ + --exclude='.testing/build/unit/test_*.o' \ + .testing/build/cov/MOM6 \ + .testing/build/cov/*.gcno \ + .testing/build/unit/test_* \ + .testing/build/unit/*.gcno - uses: actions/upload-artifact@v4 with: name: mom6-coverage-artifact - path: | - .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 + path: mom6-coverage.tar retention-days: 1 build-coupled-api: runs-on: ubuntu-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -341,17 +301,13 @@ jobs: - uses: ./.github/actions/ubuntu-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - name: Compile MOM6 for the GFDL coupled driver - run: | - make -C .testing check_mom6_api_coupled -j \ - -o build/deps/lib/libFMS.a + run: make -C .testing -j check_mom6_api_coupled - #--- + # Tests test-grid: runs-on: ubuntu-latest @@ -370,19 +326,23 @@ jobs: 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 + - name: Unpack artifacts 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 + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-asymmetric.tar + + - name: Run grid verification test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/asymmetric/MOM6 \ + test.grid test-layout: runs-on: ubuntu-latest @@ -399,12 +359,15 @@ jobs: uses: actions/download-artifact@v4 with: name: mom6-symmetric-artifact - path: .testing/build/symmetric/ - - name: Verify processor domain layout + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run layout test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing test.layout -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.layout test-rotate: runs-on: ubuntu-latest @@ -421,36 +384,17 @@ jobs: 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: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar - - name: Verify restart invariance + - name: Run rotation test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing test.restart -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.rotate - test-nan: + test-restart: runs-on: ubuntu-latest needs: build-symmetric @@ -465,36 +409,17 @@ jobs: 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: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar - - name: Verify time dimensional invariance + - name: Run restart test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing test.dim.t -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.restart - test-dim-l: + test-nan: runs-on: ubuntu-latest needs: build-symmetric @@ -509,60 +434,29 @@ jobs: 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: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar - - name: Download Artifacts - uses: actions/download-artifact@v4 - with: - name: mom6-symmetric-artifact - path: .testing/build/symmetric/ - - - name: Verify vertical thickness dimensional invariance + - name: Run NaN initialization test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing test.dim.h -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.nan - test-dim-z: + test-dim: 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 + strategy: + matrix: + dim: + - {id: t, desc: "time"} + - {id: l, desc: "horizontal length"} + - {id: h, desc: "vertical thickness"} + - {id: z, desc: "vertical coordinate"} + - {id: q, desc: "enthalpy"} + - {id: r, desc: "density"} steps: - uses: actions/checkout@v4 @@ -571,38 +465,19 @@ jobs: - uses: ./.github/actions/ubuntu-setup - - name: Download Artifacts + - name: Download symmetric MOM6 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: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar - - name: Verify density dimensional invariance + - name: Run ${{ matrix.dim.desc }} dimension test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing test.dim.r -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.dim.${{ matrix.dim.id }} test-openmp: runs-on: ubuntu-latest @@ -621,19 +496,23 @@ jobs: 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 + - name: Unpack artifacts 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 + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-openmp.tar + + - name: Run OpenMP test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/openmp/MOM6 \ + test.openmp test-repro: runs-on: ubuntu-latest @@ -652,21 +531,23 @@ jobs: 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: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-repro.tar - name: Verify REPRO equivalence run: | - chmod u+rx .testing/build/symmetric/MOM6 - chmod u+rx .testing/build/repro/MOM6 - make -C .testing test.repro \ + make -C .testing -j \ -o build/symmetric/MOM6 \ - -o build/repro/MOM6 + -o build/repro/MOM6 \ + test.repro test-regression: if: github.event_name == 'pull_request' @@ -686,22 +567,24 @@ jobs: 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: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-target.tar - name: Check for regressions run: | - chmod u+rx .testing/build/symmetric/MOM6 - chmod u+rx .testing/build/target/MOM6 - make -C .testing test.regression \ + make -C .testing -j \ -o build/symmetric/MOM6 \ -o build/target/MOM6 \ - DO_REGRESSION_TESTS=true + DO_REGRESSION_TESTS=1 \ + test.regression run-coverage: runs-on: ubuntu-latest @@ -718,46 +601,67 @@ jobs: uses: actions/download-artifact@v4 with: name: mom6-coverage-artifact - path: .testing/build/ + + - name: Unpack artifacts + run: | + tar -xpvf mom6-coverage.tar + find .testing/build/cov -name "*.gcno" -exec touch {} \; + find .testing/build/unit -name "*.gcno" -exec touch {} \; - name: Generate MOM6 coverage run: | - chmod u+rx .testing/build/cov/MOM6 - make -C .testing -j run.cov \ - -o build/cov/MOM6 + make -C .testing -j \ + -o build/cov/MOM6 \ + run.cov - 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 + cd .testing && make -j \ + $(for f in build/unit/test_*; do echo "-o $f"; done) \ + run.cov.unit - 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 + cd .testing && make \ + -o build/cov/MOM6 \ + $(for f in build/unit/test_*; do echo "-o $f"; done) \ + report.cov report.cov.unit env: CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} # These are most likely nonsense on a GitHub node, but someday it could work. run-timings: + if: github.event_name != 'pull_request' + runs-on: ubuntu-latest + needs: + - build-opt + + steps: + - uses: actions/checkout@v4 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - name: Download timing tests + uses: actions/download-artifact@v4 + with: + name: mom6-opt-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-opt.tar + + - name: Run unit test timings + run: | + cd .testing && make -j \ + $(for f in build/timing/time_*; do echo "-o $f"; done) \ + run.timing + + - name: Show timing results + run: make -C .testing show.timing + + # These are most likely nonsense on a GitHub node, but someday it could work. + compare-timings: if: github.event_name == 'pull_request' runs-on: ubuntu-latest needs: @@ -771,77 +675,71 @@ jobs: - uses: ./.github/actions/ubuntu-setup + # NOTE: This needs to occur before the artifacts are unpacked, because + # our rule for setting up `target_codebase` depends on its presence, + # rather than its contents. + # If we can improve this rule, then this can be moved after unpacking. + - name: Re-clone target directory + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + build/target_codebase + - name: Download optimized MOM6 uses: actions/download-artifact@v4 with: name: mom6-opt-artifact - 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: Unpack artifacts + run: | + tar -xpvf mom6-opt.tar + tar -xpvf mom6-opt-target.tar + + - name: Install preprocessor dependency + run: pip install f90nml + - name: Profile with FMS clocks run: | - pip install f90nml - chmod u+rx .testing/build/opt/MOM6 - chmod u+rx .testing/build/opt_target/MOM6 - make -C .testing profile -j \ + make -C .testing -j \ -o build/opt/MOM6 \ -o build/opt_target/MOM6 \ - DO_REGRESSION_TESTS=true + profile - name: Profile with perf run: | sudo sysctl -w kernel.perf_event_paranoid=2 - make -C .testing perf -j \ + make -C .testing -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 + perf - 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 + cd .testing && make -j \ + $(for f in build/timing/time_*; do echo "-o $f"; done) \ + run.timing - name: Show timing results + run: make -C .testing DO_REGRESSION_TESTS=1 show.timing + + - name: Run target timing tests run: | - make -C .testing show.timing \ - DO_REGRESSION_TESTS=true + cd .testing/build/target_codebase/.testing && make -j \ + $(for f in build/timing/time_*; do echo "-o $f"; done) \ + run.timing - name: Compare unit test timings run: | - make -C .testing compare.timing \ - DO_REGRESSION_TESTS=true + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + compare.timing + + # Cleanup cleanup-common: runs-on: ubuntu-latest @@ -857,7 +755,6 @@ jobs: - uses: geekyeggo/delete-artifact@v5 with: name: | - fms-artifact mom6-asymmetric-artifact mom6-openmp-artifact mom6-repro-artifact @@ -876,22 +773,18 @@ jobs: - 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-dim - test-grid - test-openmp - test-repro - - run-coverage + - run-timings steps: - uses: geekyeggo/delete-artifact@v5 with: name: | mom6-symmetric-artifact + mom6-opt-artifact cleanup-pr: if: github.event_name == 'pull_request' @@ -903,18 +796,12 @@ jobs: - 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-dim - test-grid - test-openmp - test-repro - - run-coverage - test-regression - - run-timings + - compare-timings steps: - uses: geekyeggo/delete-artifact@v5 @@ -924,5 +811,3 @@ jobs: 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 index 790cac3e52..d058336053 100644 --- a/.github/workflows/verify-macos.yml +++ b/.github/workflows/verify-macos.yml @@ -5,33 +5,14 @@ on: [push, pull_request] env: CC: gcc FC: gfortran + MOM_TARGET_SLUG: ${{ github.repository }} + MOM_TARGET_LOCAL_BRANCH: ${{ github.base_ref }} 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 + # Executables build-symmetric: runs-on: macOS-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -40,24 +21,23 @@ jobs: - uses: ./.github/actions/macos-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - - name: Compile symmetric index layout - run: | - make -C .testing build/symmetric/MOM6 -j -o build/deps/lib/libFMS.a + - name: Compile MOM6 with symmetric indexing + run: make -C .testing -j build/symmetric/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-symmetric.tar .testing/build/symmetric/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-symmetric-artifact - path: .testing/build/symmetric/MOM6 + path: mom6-symmetric.tar retention-days: 1 build-asymmetric: runs-on: macOS-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -66,24 +46,23 @@ jobs: - uses: ./.github/actions/macos-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - - name: Compile asymmetric index layout - run: | - make -C .testing build/asymmetric/MOM6 -j -o build/deps/lib/libFMS.a + - name: Compile MOM6 with asymmetric indexing + run: make -C .testing -j build/asymmetric/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-asymmetric.tar .testing/build/asymmetric/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-asymmetric-artifact - path: .testing/build/asymmetric/MOM6 + path: mom6-asymmetric.tar retention-days: 1 build-repro: runs-on: macOS-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -92,23 +71,23 @@ jobs: - uses: ./.github/actions/macos-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a + + - name: Compile MOM6 with bit-reproducible optimization + run: make -C .testing -j build/repro/MOM6 - - name: Compile repro - run: make -C .testing build/repro/MOM6 -j -o build/deps/lib/libFMS.a + - name: Prepare artifact + run: tar -cf mom6-repro.tar .testing/build/repro/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-repro-artifact - path: .testing/build/repro/MOM6 + path: mom6-repro.tar retention-days: 1 build-openmp: runs-on: macOS-latest - needs: build-fms steps: - uses: actions/checkout@v4 @@ -117,24 +96,24 @@ jobs: - uses: ./.github/actions/macos-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile FMS + run: make -C .testing -j build/deps/lib/libFMS.a - name: Compile MOM6 supporting OpenMP - run: make -C .testing build/openmp/MOM6 -j -o build/symmetric/Makefile + run: make -C .testing -j build/openmp/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-openmp.tar .testing/build/openmp/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-openmp-artifact - path: .testing/build/openmp/MOM6 + path: mom6-openmp.tar retention-days: 1 build-target: if: github.event_name == 'pull_request' - runs-on: macos-latest - needs: build-fms + runs-on: macOS-latest steps: - uses: actions/checkout@v4 @@ -143,26 +122,30 @@ jobs: - uses: ./.github/actions/macos-setup/ - - uses: actions/download-artifact@v4 - with: - name: fms-artifact - path: .testing/build/deps/ + - name: Compile target FMS + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + build/target_codebase + make -C .testing/build/target_codebase/.testing -j \ + build/deps/lib/libFMS.a - name: Compile target MOM6 run: | - make -C .testing 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 + make -C .testing -j \ + DO_REGRESSION_TESTS=1 \ + build/target/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-target.tar .testing/build/target/MOM6 - uses: actions/upload-artifact@v4 with: name: mom6-target-artifact - path: .testing/build/target/MOM6 + path: mom6-target.tar retention-days: 1 - #--- + # Tests test-grid: runs-on: macOS-latest @@ -181,21 +164,23 @@ jobs: 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 + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-asymmetric.tar + + - name: Run grid verification test run: | - chmod u+rx .testing/build/symmetric/MOM6 - chmod u+rx .testing/build/asymmetric/MOM6 - make -C .testing -k test.grid \ + make -C .testing -j \ -o build/symmetric/MOM6 \ - -o build/asymmetric/MOM6 + -o build/asymmetric/MOM6 \ + test.grid test-layout: runs-on: macOS-latest @@ -212,13 +197,15 @@ jobs: uses: actions/download-artifact@v4 with: name: mom6-symmetric-artifact - path: .testing/build/symmetric/ - - name: Verify processor domain layout + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run layout test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing -k test.layout \ - -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.layout test-rotate: runs-on: macOS-latest @@ -235,12 +222,15 @@ jobs: uses: actions/download-artifact@v4 with: name: mom6-symmetric-artifact - path: .testing/build/symmetric/ - - name: Verify rotational invariance + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run rotation test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing -k test.rotate -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.rotate test-restart: runs-on: macOS-latest @@ -257,12 +247,15 @@ jobs: uses: actions/download-artifact@v4 with: name: mom6-symmetric-artifact - path: .testing/build/symmetric/ - - name: Verify restart invariance + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run restart test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing -k test.restart -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.restart test-nan: runs-on: macOS-latest @@ -279,104 +272,29 @@ jobs: 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: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar - - name: Verify vertical thickness dimensional invariance + - name: Run NaN initialization test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing test.dim.h -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.nan - test-dim-z: - runs-on: macos-latest + test-dim: + 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 + strategy: + matrix: + dim: + - {id: t, desc: "time"} + - {id: l, desc: "horizontal length"} + - {id: h, desc: "vertical thickness"} + - {id: z, desc: "vertical coordinate"} + - {id: q, desc: "enthalpy"} + - {id: r, desc: "density"} steps: - uses: actions/checkout@v4 @@ -385,38 +303,19 @@ jobs: - uses: ./.github/actions/macos-setup - - name: Download Artifacts + - name: Download symmetric MOM6 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 + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar - 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 + - name: Run ${{ matrix.dim.desc }} dimension test run: | - chmod u+rx .testing/build/symmetric/MOM6 - make -C .testing test.dim.r -o build/symmetric/MOM6 + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.dim.${{ matrix.dim.id }} test-openmp: runs-on: macOS-latest @@ -435,19 +334,23 @@ jobs: 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 + - name: Unpack artifacts 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 + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-openmp.tar + + - name: Run OpenMP test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/openmp/MOM6 \ + test.openmp test-repro: runs-on: macOS-latest @@ -466,19 +369,23 @@ jobs: 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 + - name: Unpack artifacts 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 + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-repro.tar + + - name: Verify REPRO equivalence + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/repro/MOM6 \ + test.repro test-regression: if: github.event_name == 'pull_request' @@ -498,45 +405,91 @@ jobs: 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: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-target.tar - name: Check for regressions run: | - chmod u+rx .testing/build/symmetric/MOM6 - chmod u+rx .testing/build/target/MOM6 - make -C .testing test.regression \ + make -C .testing -j \ -o build/symmetric/MOM6 \ -o build/target/MOM6 \ - DO_REGRESSION_TESTS=true + DO_REGRESSION_TESTS=1 \ + test.regression + + # Cleanup + + cleanup-common: + runs-on: macOS-latest + permissions: + id-token: write + needs: + - test-grid + - test-openmp + - test-repro + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-asymmetric-artifact + mom6-openmp-artifact + mom6-repro-artifact + mom6-coverage-artifact + + # NOTE: There is no way to conditionally define the elements in `needs`. + # For now, we must create separate rules for each case. - cleanup: - runs-on: macos-latest + cleanup-push: + if: github.event_name != 'pull_request' + runs-on: macOS-latest permissions: id-token: write needs: + - test-layout + - test-rotate + - test-restart + - test-nan + - test-dim - test-grid + - test-openmp + - test-repro + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-symmetric-artifact + mom6-opt-artifact + + cleanup-pr: + if: github.event_name == 'pull_request' + runs-on: macOS-latest + permissions: + id-token: write + needs: - test-layout - test-rotate - test-restart - test-nan - - test-dim-t - - test-dim-l - - test-dim-h - - test-dim-z - - test-dim-q - - test-dim-r + - test-dim + - test-grid - test-openmp - test-repro + - test-regression steps: - uses: geekyeggo/delete-artifact@v5 with: name: | - fms-artifact - mom6-*-artifact + mom6-symmetric-artifact + mom6-target-artifact + mom6-opt-artifact + mom6-opt-target-artifact diff --git a/.testing/Makefile b/.testing/Makefile index ec6e5d1075..71d5b464f0 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -77,7 +77,7 @@ AC_SRCDIR := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))../ac -include config.mk # Set the FMS library -FMS_COMMIT ?= 2023.03 +FMS_COMMIT ?= 2025.02.01 FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git export FMS_COMMIT export FMS_URL @@ -213,10 +213,8 @@ endif ## Rules -.PHONY: all build.regressions build.prof +.PHONY: all all: $(foreach b,$(EXECS),$(BUILD)/$(b)) -build.regressions: $(foreach b,symmetric target,$(BUILD)/$(b)/MOM6) -build.prof: $(foreach b,opt opt_target,$(BUILD)/$(b)/MOM6) # Executable .PRECIOUS: $(foreach b,$(EXECS),$(BUILD)/$(b)) @@ -230,7 +228,7 @@ LDFLAGS_DEPS = -L$(abspath $(DEPS)/lib) PATH_DEPS = PATH="${PATH}:$(abspath $(DEPS)/bin)" -# Define the build targets in terms of the traditional DEBUG/REPRO/etc labels +# Compiler flags SYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" ASYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" REPRO_FCFLAGS := FCFLAGS="$(FCFLAGS_REPRO) $(FCFLAGS_DEPS)" @@ -239,10 +237,10 @@ OPENMP_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" TARGET_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" COV_FCFLAGS := FCFLAGS="$(FCFLAGS_COVERAGE) $(FCFLAGS_DEPS)" +# Linker flags MOM_LDFLAGS := LDFLAGS="$(LDFLAGS_DEPS) $(LDFLAGS_USER)" COV_LDFLAGS := LDFLAGS="$(LDFLAGS_COVERAGE) $(LDFLAGS_DEPS) $(LDFLAGS_USER)" - # Environment variable configuration MOM_ENV := $(PATH_FMS) $(BUILD)/symmetric/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) @@ -271,12 +269,16 @@ $(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests .NOTPARALLEL:$(foreach e,$(UNIT_EXECS),$(BUILD)/unit/$(e)) $(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -$(BUILD)/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) + +$(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) -$(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) + +$(BUILD)/timing/Makefile: \ + $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) $(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) @@ -294,7 +296,7 @@ $(BUILD)/opt_target/MOM6: $(BUILD)/opt_target FORCE | $(TARGET_CODEBASE) $(BUILD)/opt_target: | $(TARGET_CODEBASE) ln -s $(abspath $(TARGET_CODEBASE))/.testing/build/opt $@ -FORCE: +.PHONY: FORCE ## Use autoconf to construct the Makefile for each target @@ -330,10 +332,12 @@ ALL_EXECS = symmetric asymmetric repro openmp opt opt_target coupled nuopc \ $(foreach b,$(ALL_EXECS),$(BUILD)/$(b)/): mkdir -p $@ +ifdef DO_REGRESSION_TESTS # Fetch the regression target codebase $(TARGET_CODEBASE): git clone --recursive $(MOM_TARGET_URL) $@ cd $@ && git checkout --recurse-submodules $(MOM_TARGET_BRANCH) +endif ## FMS @@ -362,6 +366,7 @@ $(DEPS)/m4: ../ac/deps/m4 | $(DEPS) $(DEPS): mkdir -p $(DEPS) + #--- # Verify that the coupled model drivers can be compiled. This does not verify # that they can be run, since it would require external submodels. @@ -608,7 +613,6 @@ $(eval $(call STAT_RULE,dim.h,symmetric,,H_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.q,symmetric,,Q_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.r,symmetric,,R_RESCALE_POWER=11,,1)) - $(eval $(call STAT_RULE,cov,cov,true,,,1)) # Generate the half-period input namelist as follows: @@ -667,33 +671,50 @@ test.summary: run.cov.unit: $(foreach t,$(UNIT_EXECS),$(BUILD)/unit/$(t).F90.gcov) .PHONY: build.unit +.NOTPARALLEL: build.unit build.unit: $(foreach f, $(UNIT_EXECS), $(BUILD)/unit/$(f)) + .PHONY: run.unit run.unit: $(foreach f, $(UNIT_EXECS), work/unit/$(f).out) + .PHONY: build.timing +.NOTPARALLEL: build.timing build.timing: $(foreach f, $(TIMING_EXECS), $(BUILD)/timing/$(f)) + .PHONY: run.timing run.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).out) + .PHONY: show.timing show.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).show) + $(WORK)/timing/%.show: ./tools/disp_timing.py $(@:.show=.out) -# Invoke the above unit/timing rules for a "target" code -# Invoke with appropriate macros defines, i.e. -# make build.timing_target MOM_TARGET_URL=... MOM_TARGET_BRANCH=... TARGET_CODEBASE=$(BUILD)/target_codebase -# make run.timing_target TARGET_CODEBASE=$(BUILD)/target_codebase +# Invoke the above unit/timing rules for a "target" code, e.g. +# make \ +# MOM_TARGET_URL=... \ +# MOM_TARGET_BRANCH=... \ +# TARGET_CODEBASE=$(BUILD)/target_codebase \ +# build.timing_target +# make TARGET_CODEBASE=$(BUILD)/target_codebase run.timing_target -TIMING_TARGET_EXECS ?= $(basename $(notdir $(wildcard $(TARGET_CODEBASE)/config_src/drivers/timing_tests/*.F90) ) ) +TIMING_TARGET_EXECS ?= \ + $(basename $(notdir $(wildcard $(TARGET_CODEBASE)/config_src/drivers/timing_tests/*.F90))) .PHONY: build.timing_target -build.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/$(BUILD)/timing/$(f)) +build.timing_target: \ + $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/$(BUILD)/timing/$(f)) + .PHONY: run.timing_target -run.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/work/timing/$(f).out) +run.timing_target: \ + $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/work/timing/$(f).out) + .PHONY: compare.timing -compare.timing: $(foreach f, $(filter $(TIMING_EXECS),$(TIMING_TARGET_EXECS)), work/timing/$(f).compare) -$(WORK)/timing/%.compare: $(TARGET_CODEBASE) +compare.timing: \ + $(foreach f, $(filter $(TIMING_EXECS),$(TIMING_TARGET_EXECS)), work/timing/$(f).compare) +$(WORK)/timing/%.compare: \ + $(TARGET_CODEBASE) ./tools/disp_timing.py -r $(TARGET_CODEBASE)/.testing/$(@:.compare=.out) $(@:.compare=.out) $(TARGET_CODEBASE)/.testing/%: | $(TARGET_CODEBASE) cd $(TARGET_CODEBASE)/.testing && make $* diff --git a/.testing/tools/disp_timing.py b/.testing/tools/disp_timing.py index ac90ef2b55..0b3163625a 100755 --- a/.testing/tools/disp_timing.py +++ b/.testing/tools/disp_timing.py @@ -12,11 +12,15 @@ def display_timing_file(file, show_all): """Parse a JSON file of timing results and pretty-print the results""" - with open(file) as json_file: - timing_dict = json.load(json_file) + try: + with open(file, 'r') as json_file: + timing_dict = json.load(json_file) + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Min time Module & function") + except: + stream_fms_tail_file(file) + timing_dict = {} - print("(Times measured in %5.0e seconds)" % (1./scale)) - print(" Min time Module & function") for sub in timing_dict.keys(): tmin = timing_dict[sub]['min'] * scale print("%10.4e %s" % (tmin, sub)) @@ -34,18 +38,27 @@ def display_timing_file(file, show_all): "std = %8.2e, " % (tstd) + "# = %d)" % (nsamp)) - def compare_timing_files(file, ref, show_all, significance_threshold): """Read and compare two JSON files of timing results""" - with open(file) as json_file: - timing_dict = json.load(json_file) - - with open(ref) as json_file: - ref_dict = json.load(json_file) + try: + with open(file) as json_file: + timing_dict = json.load(json_file) + except: + print("This timing tail sheet:") + stream_fms_tail_file(file) + timing_dict = {} + + try: + with open(ref) as json_file: + ref_dict = json.load(json_file) + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Delta (%) Module & function") + except: + print("Reference timing tail sheet:") + stream_fms_tail_file(ref) + ref_dict = {} - print("(Times measured in %5.0e seconds)" % (1./scale)) - print(" Delta (%) Module & function") for sub in {**ref_dict, **timing_dict}.keys(): T1 = ref_dict.get(sub) T2 = timing_dict.get(sub) @@ -101,6 +114,18 @@ def compare_timing_files(file, ref, show_all, significance_threshold): "std=%8.2e, " % (tstd1) + "# = %d)" % (n1)) +# Rudimentatry dump of tail sheet produced by FMS. +# This should really be handled by the parse_fms_clocks.py script +def stream_fms_tail_file(file): + silent = True + with open(file, 'r') as fms_tail_file: + for line in fms_tail_file.readlines(): + if "tfrac grain pemin pemax" in line: + silent=False + elif "high water mark" in line: + silent=True + if not silent: + print(line) # Parse arguments parser = argparse.ArgumentParser( diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index 753269116a..bc95633af8 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -43,6 +43,7 @@ program Shelf_main use MOM_io, only : APPEND_FILE, READONLY_FILE, SINGLE_FILE use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : save_restart + use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_string_functions,only : uppercase use MOM_time_manager, only : time_type, set_date, get_date use MOM_time_manager, only : real_to_time, time_type_to_real @@ -268,7 +269,10 @@ program Shelf_main call clone_MOM_domain(ocn_grid%Domain, dG%Domain) ! Initialize the ocean grid and topography. - call MOM_initialize_fixed(dG, US, OBC, param_file, .true., dirs%output_directory) + call MOM_initialize_fixed(dG, US, OBC, param_file) + ! Write out all of the grid data used by this run. + call write_ocean_geometry_file(dG, param_file, dirs%output_directory, US=US) + call MOM_grid_init(ocn_grid, param_file, US, HI) call copy_dyngrid_to_MOM_grid(dG, ocn_grid, US) call destroy_dyn_horgrid(dG) diff --git a/config_src/drivers/timing_tests/time_reproducing_sum.F90 b/config_src/drivers/timing_tests/time_reproducing_sum.F90 new file mode 100644 index 0000000000..de9a3ef63f --- /dev/null +++ b/config_src/drivers/timing_tests/time_reproducing_sum.F90 @@ -0,0 +1,135 @@ +program time_reproducing_sum + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : PE_here, root_PE, num_PEs, reproducing_sum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_domains, only : MOM_domain_type, create_MOM_domain, MOM_infra_init, MOM_infra_end +use MOM_domains, only : MOM_define_layout +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, MOM_set_verbosity +use MOM_hor_index, only : hor_index_type, hor_index_init + + implicit none + + type(MOM_domain_type), pointer :: Domain => NULL() ! Ocean model domain + type(hor_index_type) :: HI ! A hor_index_type for array extents + real, allocatable, dimension(:) :: depth_tot_R, depth_tot_std, depth_tot_fastR ! Various sums of depths [m] + real, allocatable :: array(:,:) ! An array with values to sum over [m] + character(len=200) :: mesg ! String for messages + integer :: num_sums ! Number of times to repeat the sum call + integer :: n ! Loop counter + integer :: io_unit ! i/o unit for creating input.nml (sigh) + integer :: reproClock, fastreproClock, stdClock, initClock ! Clocks for each sum + integer :: n_global(2) ! Global i-, j- dimensions of domain (h-points) + integer :: layout(2) ! PE count in i-, j- directions + integer :: PEs_used ! Number of PEs available to executable + + ! FMS requires the file "input.nml" to exist ... + open(newunit=io_unit, file="input.nml", status="replace", action="write") + close(io_unit) ! ... but an empty input.nml is sufficient + + call MOM_infra_init() + + ! These clocks are on the global pelist. + initClock = cpu_clock_id( 'Initialization' ) + stdClock = cpu_clock_id( 'Standard Sums' ) + reproClock = cpu_clock_id( 'Reproducing Sums' ) + fastreproClock = cpu_clock_id( 'Fast Reproducing Sums' ) + num_sums = 100 + + call cpu_clock_begin(initClock) + ! Optionally use command-line to change size of the problem + ! Usage: ./executable [tile-size] [number-of-calls] + n = command_argument_count() + if (n==2) then + call get_command_argument(1, mesg) + read(mesg,*) n_global(1) + n_global(2) = n_global(1) + call get_command_argument(2, mesg) + read(mesg,*) num_sums + elseif (n==1) then + call get_command_argument(1, mesg) + read(mesg,*) n_global(1) + n_global(2) = n_global(1) + else + n_global = (/500, 300/) ! Fallback value if no argument provided + endif + + call MOM_mesg('======== Unit test being driven by MOM_sum_driver ========', 2) + call MOM_set_verbosity(2) + + ! Setup distributed domain + PEs_used = num_PEs() + call MOM_define_layout(n_global, PEs_used, layout) + call create_MOM_domain(Domain, n_global, (/2,2/), (/.false.,.false./), .false., layout) + call hor_index_init(Domain, HI) + + allocate( array(HI%isd:HI%ied,HI%jsd:HI%jed), source=0. ) + allocate( depth_tot_std(num_sums), source=0. ) + allocate( depth_tot_R(num_sums), source=0. ) + allocate( depth_tot_fastR(num_sums), source=0. ) + + ! Set up an array of values to sum + call generate_array_of_values(array, HI, n_global) + + call cpu_clock_end(initClock) !end initialization + call MOM_mesg("Done with initialization.", 5) + + call MOM_mesg('==== Standard Non-reproducing Sum ===', 2) + do n=1,num_sums + call cpu_clock_begin(stdClock) + depth_tot_std(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, reproducing=.false.) + call cpu_clock_end(stdClock) + enddo + + call MOM_mesg('==== Reproducing Fixed Point Sum ===', 2) + do n=1,num_sums + call cpu_clock_begin(reproClock) + depth_tot_R(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + call cpu_clock_end(reproClock) + enddo + + call MOM_mesg('==== No Error Handling Reproducing Fixed Point Sum ===', 2) + do n=1,num_sums + call cpu_clock_begin(fastreproClock) + depth_tot_fastR(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, overflow_check=.false.) + call cpu_clock_end(fastreproClock) + enddo + + ! Cleanup the "input.nml" file created to boot FMS + if (PE_here() == root_PE()) then ! Can only delete the file once (i.e. on root PE) + open(newunit=io_unit, file="input.nml", status="replace", action="write") + close(io_unit, status="delete") ! we could leave this in place but that would be untidy + endif + + call MOM_infra_end + +contains + +!> Generate some "spatial" data, reminiscent of benchmark topography +subroutine generate_array_of_values(D, HI, n_global) + type(hor_index_type), intent(in) :: HI !< The horizontal index type + real, intent(out) :: D(HI%isd:HI%ied,HI%jsd:HI%jed) !< Ocean bottom depth in [m] + integer, intent(in) :: n_global(2) !< Global i-, j- dimensions of domain (h-points) + ! Local variables + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: x ! A fractional position in the x-direction [nondim] + real :: y ! A fractional position in the y-direction [nondim] + integer :: i, j ! Loop indices + + PI = 4.0*atan(1.0) + + ! Calculate the depth of the bottom. + do concurrent( j=HI%jsc:HI%jec, i=HI%isc:HI%iec ) + x = real( i + HI%idg_offset ) / real( n_global(1) ) + y = real( j + HI%idg_offset ) / real( n_global(2) ) + D(i,j) = -3000.0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & + + 0.75*exp(-6.0*y) & + + 0.05*cos(10.0*PI*x) - 0.7 ) + if (D(i,j) > 3000.0) D(i,j) = 3000.0 + if (D(i,j) < 1.) D(i,j) = 0. + enddo + +end subroutine generate_array_of_values + +end program time_reproducing_sum diff --git a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 deleted file mode 100644 index 7a1ba82843..0000000000 --- a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 +++ /dev/null @@ -1,219 +0,0 @@ -program MOM_sum_driver - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* The Modular Ocean Model * -!* MOM * -!* * -!* By Robert Hallberg * -!* * -!* This file is a simple driver for unit testing the distributed * -!* sums code. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - - use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, reproducing_sum - use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_to_real, real_to_EFP - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end - use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_domains, only : MOM_domain_type, MOM_domains_init, MOM_infra_init, MOM_infra_end - use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid - use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe - use MOM_error_handler, only : MOM_set_verbosity - use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type - use MOM_file_parser, only : open_param_file, close_param_file - use MOM_grid_initialize, only : set_grid_metrics - use MOM_hor_index, only : hor_index_type, hor_index_init - use MOM_io, only : MOM_io_init, file_exists, open_file, close_file - use MOM_io, only : check_nml_error, io_infra_init, io_infra_end - use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_unit_scaling, only : unit_scale_type, unit_no_scaling_init, unit_scaling_end - - implicit none - -#include - - type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain - type(dyn_horgrid_type), pointer :: grid => NULL() ! A structure containing metrics and grid info - type(hor_index_type) :: HI ! A hor_index_type for array extents - type(param_file_type) :: param_file ! The structure indicating the file(s) - ! containing all run-time parameters. - type(unit_scale_type), pointer :: US => NULL() !< A structure containing various unit - ! conversion factors, but in this case all are 1. - real :: max_depth ! The maximum ocean depth [m] - integer :: verbosity - integer :: num_sums - integer :: n, i, j, is, ie, js, je, isd, ied, jsd, jed - - integer :: unit, io_status, ierr - logical :: unit_in_use - - real, allocatable, dimension(:) :: & - depth_tot_R, depth_tot_std, depth_tot_fastR ! Various sums of the depths [m] - integer :: reproClock, fastreproClock, stdClock, initClock - - !----------------------------------------------------------------------- - - character(len=4), parameter :: vers_num = 'v2.0' - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "MOM_main (MOM_sum_driver)" ! This module's name. - character(len=200) :: mesg - - !======================================================================= - - call MOM_infra_init() ; call io_infra_init() - - ! These clocks are on the global pelist. - initClock = cpu_clock_id( 'Initialization' ) - reproClock = cpu_clock_id( 'Reproducing Sums' ) - fastreproClock = cpu_clock_id( 'Fast Reproducing Sums' ) - stdClock = cpu_clock_id( 'Standard Sums' ) - - call cpu_clock_begin(initClock) - - call MOM_mesg('======== Unit test being driven by MOM_sum_driver ========', 2) - - call open_param_file("./MOM_input", param_file) - - verbosity = 2 ; call read_param(param_file, "VERBOSITY", verbosity) - call MOM_set_verbosity(verbosity) - - call MOM_domains_init(Domain, param_file) - - call MOM_io_init(param_file) -! call diag_mediator_init(param_file) - call hor_index_init(Domain, HI, param_file) - call create_dyn_horgrid(grid, HI) - grid%Domain => Domain - - is = HI%isc ; ie = HI%iec ; js = HI%jsc ; je = HI%jec - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, "MOM", version, "") - call get_param(param_file, "MOM", "VERBOSITY", verbosity, & - "Integer controlling level of messaging\n" // & - "\t0 = Only FATAL messages\n" // & - "\t2 = Only FATAL, WARNING, NOTE [default]\n" // & - "\t9 = All)", default=2) - call get_param(param_file, "MOM", "NUMBER_OF_SUMS", num_sums, & - "The number of times to do the global sums.", default=1) - - allocate(depth_tot_R(num_sums)) ; depth_tot_R(:) = 0.0 - allocate(depth_tot_std(num_sums)) ; depth_tot_std(:) = 0.0 - allocate(depth_tot_fastR(num_sums)) ; depth_tot_fastR(:) = 0.0 - -! Set up the parameters of the physical grid - call unit_no_scaling_init(US) - call set_grid_metrics(grid, param_file, US) - -! Set up the bottom depth, grid%bathyT either analytically or from file - call get_param(param_file, "MOM", "MAXIMUM_DEPTH", max_depth, & - "The maximum depth of the ocean.", units="m", default=4000.0) - call benchmark_init_topog_local(grid%bathyT, grid, param_file, max_depth) - - ! Close the param_file. No further parsing of input is possible after this. - call close_param_file(param_file) - - call cpu_clock_end(initClock) !end initialization - call MOM_mesg("Done with initialization.", 5) - - call MOM_mesg('==== Reproducing Fixed Point Sum ===', 2) - - call cpu_clock_begin(reproClock) - do n=1,num_sums - depth_tot_R(n) = reproducing_sum(grid%bathyT, is, ie, js, je) - enddo - call cpu_clock_end(reproClock) - - call MOM_mesg('==== Standard Non-reproducing Sum ===', 2) - - call cpu_clock_begin(stdClock) -! do n=1,num_sums -! do j=js,je ; do i=is,ie -! depth_tot_std(n) = depth_tot_std(n) + grid%bathyT(i,j) -! enddo ; enddo -! call sum_across_PEs(depth_tot_std(n:),1) -! enddo - do n=1,num_sums - depth_tot_fastR(n) = reproducing_sum(grid%bathyT, is, ie, js, je, reproducing=.false.) - enddo - call cpu_clock_end(stdClock) - - call MOM_mesg('==== No Error Handling Reproducing Fixed Point Sum ===', 2) - - call cpu_clock_begin(fastreproClock) - do n=1,num_sums - depth_tot_fastR(n) = reproducing_sum(grid%bathyT, is, ie, js, je, overflow_check=.false.) - enddo - call cpu_clock_end(fastreproClock) - - do n=1,num_sums - if ((depth_tot_std(n) - depth_tot_R(n)) > 1e-15*depth_tot_R(n)) then - write(mesg,'("Mismatch between standard and reproducing sum.",2ES13.5)') & - depth_tot_std(n) - depth_tot_R(n), depth_tot_R(n) - call MOM_mesg(mesg) ; exit - endif - if ((depth_tot_fastR(n) - depth_tot_R(n)) > 1e-15*depth_tot_R(n)) then - write(mesg,'("Mismatch between reproducing and fast reproducing sums.",2ES13.5)') & - depth_tot_fastR(n) - depth_tot_R(n), depth_tot_R(n) - call MOM_mesg(mesg) ; exit -! call MOM_mesg("Mismatch between reproducing and fast reproducing sums.") - endif - enddo - - call destroy_dyn_horgrid(grid) - call unit_scaling_end(US) - call io_infra_end ; call MOM_infra_end - -contains - -!> This subroutine sets up the benchmark test case topography for debugging -subroutine benchmark_init_topog_local(D, G, param_file, max_depth) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type - real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in [m] - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real, intent(in) :: max_depth !< The maximum ocean depth [m] - - real :: min_depth ! The minimum ocean depth in [m]. - real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] - real :: D0 ! A constant to make the maximum - ! basin depth MAXIMUM_DEPTH [m] - real :: m_to_Z ! A dimensional rescaling factor [Z m-1 ~> 1] - real :: x ! A fractional position in the x-direction [nondim] - real :: y ! A fractional position in the y-direction [nondim] - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "benchmark_init_topog_local" ! This subroutine's name. - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - m_to_Z = 1.0 ! ; if (present(US)) m_to_Z = US%m_to_Z - - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0, scale=m_to_Z) - - PI = 4.0*atan(1.0) - D0 = max_depth / 0.5 - -! Calculate the depth of the bottom. - do i=is,ie ; do j=js,je - x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon - y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat -! This sets topography that has a reentrant channel to the south. - D(i,j) = -D0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & - + 0.75*exp(-6.0*y) & - + 0.05*cos(10.0*PI*x) - 0.7 ) - if (D(i,j) > max_depth) D(i,j) = max_depth - if (D(i,j) < min_depth) D(i,j) = 0. - enddo ; enddo - -end subroutine benchmark_init_topog_local - -end program MOM_sum_driver diff --git a/config_src/drivers/unit_tests/test_numerical_testing_type.F90 b/config_src/drivers/unit_tests/test_numerical_testing_type.F90 index 374c83f0c7..77216219fa 100644 --- a/config_src/drivers/unit_tests/test_numerical_testing_type.F90 +++ b/config_src/drivers/unit_tests/test_numerical_testing_type.F90 @@ -1,7 +1,7 @@ program test_numerical_testing_type -use numerical_testing_type, only : testing_type_unit_test +use numerical_testing_type, only : numerical_testing_type_unit_tests -if (testing_type_unit_test(.true.)) stop 1 +if (numerical_testing_type_unit_tests(.true.)) stop 1 end program test_numerical_testing_type diff --git a/config_src/drivers/unit_tests/test_reproducing_sum.F90 b/config_src/drivers/unit_tests/test_reproducing_sum.F90 new file mode 100644 index 0000000000..0afd138138 --- /dev/null +++ b/config_src/drivers/unit_tests/test_reproducing_sum.F90 @@ -0,0 +1,209 @@ +program test_reproducing_sum + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : PE_here, root_PE, num_PEs, reproducing_sum +use MOM_coms, only : sum_across_PEs, max_across_PEs, max_count_prec +use MOM_domains, only : MOM_domain_type, create_MOM_domain, MOM_infra_init, MOM_infra_end +use MOM_domains, only : MOM_define_layout +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, MOM_set_verbosity +use MOM_hor_index, only : hor_index_type, hor_index_init + + implicit none + + type(MOM_domain_type), pointer :: Domain => NULL() ! Ocean model domain + type(hor_index_type) :: HI ! A hor_index_type for array extents + real, allocatable :: array(:,:) ! An array with values to sum over [A] + real :: tot_R, tot_std, tot_fastR ! Sums via different methods [A] + real :: error_bound, likely_error ! Errors via different methods [A] + character(len=200) :: mesg ! String for messages + integer :: n_repeat ! Number of times to repeat the sum call + integer :: n ! Loop counter + integer :: io_unit ! i/o unit for creating input.nml (sigh) + integer :: n_global(2) ! Global i-, j- dimensions of domain (h-points) + integer :: layout(2) ! PE count in i-, j- directions + integer :: PEs_used ! Number of PEs available to executable + logical :: tests_failed ! True if a fail is encountered + integer :: i, j, ig, jg ! Spatial indices + + ! FMS requires the file "input.nml" to exist ... + open(newunit=io_unit, file="input.nml", status="replace", action="write") + close(io_unit) ! ... but an empty input.nml is sufficient + + call MOM_infra_init() + + n_repeat = 100 + + ! Optionally use command-line to change size of the problem + ! Usage: ./executable [tile-size] [number-of-calls] + n = command_argument_count() + if (n==2) then + call get_command_argument(1, mesg) + read(mesg,*) n_global(1) + n_global(2) = n_global(1) + call get_command_argument(2, mesg) + read(mesg,*) n_repeat + elseif (n==1) then + call get_command_argument(1, mesg) + read(mesg,*) n_global(1) + n_global(2) = n_global(1) + else + n_global = (/200, 300/) ! Fallback value if no argument provided + endif + + tests_failed = .false. + call MOM_set_verbosity(2) + + ! Setup distributed domain + PEs_used = num_PEs() + call MOM_define_layout(n_global, PEs_used, layout) + call create_MOM_domain(Domain, n_global, (/2,2/), (/.false.,.false./), .false., layout) + call hor_index_init(Domain, HI) + + allocate( array(HI%isd:HI%ied,HI%jsd:HI%jed), source=0. ) + + ! Set up an array of values to sum + call generate_array_of_values(array, HI, n_global) + + ! This estimates the maximum possible accumulated round off error, and likely error + ! from a random walk of round off errors + error_bound = 0. + tot_std = 0. + do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec + ! Actual round off error for adding tot_std + array(i,j) + error_bound = error_bound + max( abs(tot_std), abs(array(i,j)) ) * epsilon(error_bound) + tot_std = tot_std + array(i,j) + enddo ; enddo + call sum_across_PEs( error_bound ) + call sum_across_PEs( tot_std ) + N = n_global(1) * n_global(2) + likely_error = tot_std * epsilon(tot_std) * sqrt( real( N ) ) + if (likely_error > error_bound) call MOM_error(FATAL, 'Something went wrong in error estimate!') + + tot_std = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, reproducing=.false.) + tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + tot_fastR = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, overflow_check=.false.) + + ! tot_std and tot_R should differ only by round off, if at all + if (abs(tot_std - tot_R) > likely_error) then + write(mesg,'("Mismatch between standard and reproducing sum.",4ES13.5)') & + tot_std, tot_R, tot_std - tot_R, ( tot_std - tot_R ) / tot_R + call MOM_mesg(mesg) + tests_failed = tests_failed .or. .true. + endif + ! tot_fastR and tot_R should be identical unless too many values are summed + if (abs(tot_fastR - tot_R) > 0.) then + if (n < max_count_prec) then + write(mesg,'("Mismatch between reproducing and fast reproducing sums.",4ES13.5)') & + tot_fastR, tot_R, tot_fastR - tot_R, ( tot_fastR - tot_R ) / tot_R + tests_failed = tests_failed .or. .true. + else + write(mesg,'("Too many values were summed for the fast reproducing sum to work.")') + endif + call MOM_mesg(mesg) + endif + + ! Now check the reproducing sums give the exact answer for known sets of values + + ! Fill array with values 1, 2, ..., Ni*Nj whose sum is N ( N + 1 ) / 2 where N + Ni*Nj + do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec + jg = j + HI%jdg_offset - 1 ! 0 .. Nj-1 + ig = i + HI%idg_offset - 1 ! 0 .. Ni-1 + array(i,j) = 1 + ig + n_global(1) * jg + enddo ; enddo + tot_std = 0.5 * real(N) * real(N + 1) ! tot_std will contain analytic solution + tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + if (abs(tot_R - tot_std) > 0.) then + write(mesg,'("Sum_k=1^N k != N(N+1)/2",2ES13.5)') tot_R, tot_std + call MOM_mesg(mesg) + tests_failed = tests_failed .or. .true. + endif + + ! Change the order of values in the arrya to check the sum is truly order invariant + do i = 1, n_repeat + call randomly_swap_elements(HI, array) + tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + if (abs(tot_R - tot_std) > 0.) then + write(mesg,'("Reordered list changed sum",2ES13.5)') tot_R, tot_std + call MOM_mesg(mesg) + tests_failed = tests_failed .or. .true. + endif + enddo + + call random_number( array ) ! This will also fill the halos but they will be ignored + tot_std = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) ! Use this as the true value + ! Change the order of values in the arrya to check the sum is truly order invariant + do i = 1, n_repeat + call randomly_swap_elements(HI, array) + tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + if (abs(tot_R - tot_std) > 0.) then + write(mesg,'("Reordered list of random numbers changed sum",2ES13.5)') tot_R, tot_std + call MOM_mesg(mesg) + tests_failed = tests_failed .or. .true. + endif + enddo + + ! Cleanup the "input.nml" file created to boot FMS + if (PE_here() == root_PE()) then ! Can only delete the file once (i.e. on root PE) + open(newunit=io_unit, file="input.nml", status="replace", action="write") + close(io_unit, status="delete") ! we could leave this in place but that would be untidy + endif + + call MOM_infra_end + if (tests_failed) stop 1 + +contains + +!> Randomly swap elements within the computational domain of an array +subroutine randomly_swap_elements(HI, array) + type(hor_index_type), intent(in) :: HI !< The horizontal index type + real, intent(inout) :: array(HI%isd:HI%ied,HI%jsd:HI%jed) !< Array of values to play with [A] + ! Local variables + integer :: n_swaps !< Number of swaps to perform + integer :: i0, j0, i1, j1, iter ! Indices and counter + real :: r(4) ! Random numbers [nondim] + real :: v ! Value being swapped + + n_swaps = ( HI%iec - HI%isc ) * ( HI%jec - HI%jsc ) + do iter = 1, n_swaps + do + call random_number( r ) ! Random numbers 0..1 + i0 = HI%isc + int( r(1) * real( HI%iec - HI%isc ) ) + j0 = HI%jsc + int( r(2) * real( HI%jec - HI%jsc ) ) + i1 = HI%isc + int( r(3) * real( HI%iec - HI%isc ) ) + j1 = HI%jsc + int( r(4) * real( HI%jec - HI%jsc ) ) + if (i0 /= i1 .and. j0 /= j1) exit ! Repeat dice roll if points are the same + enddo + v = array(i0,j0) + array(i0,j0) = array(i1,j1) + array(i1,j1) = v + enddo +end subroutine randomly_swap_elements + +!> Generate some "spatial" data, reminiscent of benchmark topography +subroutine generate_array_of_values(D, HI, n_global) + type(hor_index_type), intent(in) :: HI !< The horizontal index type + real, intent(out) :: D(HI%isd:HI%ied,HI%jsd:HI%jed) !< Ocean bottom depth in [m] + integer, intent(in) :: n_global(2) !< Global i-, j- dimensions of domain (h-points) + ! Local variables + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: x ! A fractional position in the x-direction [nondim] + real :: y ! A fractional position in the y-direction [nondim] + integer :: i, j ! Loop indices + + PI = 4.0*atan(1.0) + + ! Calculate the depth of the bottom. + do concurrent( j=HI%jsc:HI%jec, i=HI%isc:HI%iec ) + x = real( i + HI%idg_offset ) / real( n_global(1) ) + y = real( j + HI%idg_offset ) / real( n_global(2) ) + D(i,j) = -3000.0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & + + 0.75*exp(-6.0*y) & + + 0.05*cos(10.0*PI*x) - 0.7 ) + if (D(i,j) > 3000.0) D(i,j) = 3000.0 + if (D(i,j) < 1.) D(i,j) = 0. + enddo + +end subroutine generate_array_of_values + +end program test_reproducing_sum diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 deleted file mode 100644 index 5d78e0d501..0000000000 --- a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 +++ /dev/null @@ -1,45 +0,0 @@ -module FMS_coupler_util - -use coupler_types_mod, only : coupler_2d_bc_type - -implicit none ; private - -public :: extract_coupler_values, set_coupler_values - -contains - -!> Get element and index of a boundary condition -subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb, jlb, & - is, ie, js, je, conversion) - integer, intent(in) :: ilb !< Lower bounds - integer, intent(in) :: jlb !< Lower bounds - real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values - type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted - integer, intent(in) :: BC_index !< The boundary condition number being extracted - integer, intent(in) :: BC_element !< The element of the boundary condition being extracted - integer, optional, intent(in) :: is !< The i- limits of array_out to be filled - integer, optional, intent(in) :: ie !< The i- limits of array_out to be filled - integer, optional, intent(in) :: js !< The j- limits of array_out to be filled - integer, optional, intent(in) :: je !< The j- limits of array_out to be filled - real, optional, intent(in) :: conversion !< A number that every element is multiplied by - - array_out(:,:) = -1. -end subroutine extract_coupler_values - -!> Set element and index of a boundary condition -subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb,& - is, ie, js, je, conversion) - integer, intent(in) :: ilb !< Lower bounds - integer, intent(in) :: jlb !< Lower bounds - real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC - type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type into which the data is being loaded - integer, intent(in) :: BC_index !< The boundary condition number being set - integer, intent(in) :: BC_element !< The element of the boundary condition being set - integer, optional, intent(in) :: is !< The i- limits of array_out to be filled - integer, optional, intent(in) :: ie !< The i- limits of array_out to be filled - integer, optional, intent(in) :: js !< The j- limits of array_out to be filled - integer, optional, intent(in) :: je !< The j- limits of array_out to be filled - real, optional, intent(in) :: conversion !< A number that every element is multiplied by -end subroutine set_coupler_values - -end module FMS_coupler_util diff --git a/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 index 6b10d15e2f..80d209fa6e 100644 --- a/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 +++ b/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 @@ -13,918 +13,271 @@ module MOM_generic_tracer #define _ALLOCATED allocated #endif - ! ### These imports should not reach into FMS directly ### - use field_manager_mod, only: fm_string_len - - use generic_tracer, only: generic_tracer_register, generic_tracer_get_diag_list - use generic_tracer, only: generic_tracer_init, generic_tracer_source, generic_tracer_register_diag - use generic_tracer, only: generic_tracer_coupler_get, generic_tracer_coupler_set - use generic_tracer, only: generic_tracer_end, generic_tracer_get_list, do_generic_tracer - use generic_tracer, only: generic_tracer_update_from_bottom,generic_tracer_vertdiff_G - use generic_tracer, only: generic_tracer_coupler_accumulate - - use g_tracer_utils, only: g_tracer_get_name,g_tracer_set_values,g_tracer_set_common,g_tracer_get_common - use g_tracer_utils, only: g_tracer_get_next,g_tracer_type,g_tracer_is_prog,g_tracer_flux_init - use g_tracer_utils, only: g_tracer_send_diag,g_tracer_get_values - use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_tracer_set_csdiag - use g_tracer_utils, only: g_tracer_get_obc_segment_props - - use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS - use MOM_coms, only : EFP_type, max_across_PEs, min_across_PEs, PE_here - use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr - use MOM_diag_mediator, only : diag_ctrl, get_diag_time_end - use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe - use MOM_file_parser, only : get_param, log_param, log_version, param_file_type - use MOM_forcing_type, only : forcing, optics_type - use MOM_grid, only : ocean_grid_type - use MOM_hor_index, only : hor_index_type - use MOM_interface_heights, only : thickness_to_dz - use MOM_io, only : file_exists, MOM_read_data, slasher - use MOM_open_boundary, only : ocean_OBC_type - use MOM_open_boundary, only : register_obgc_segments, fill_obgc_segments - use MOM_open_boundary, only : set_obgc_segments_props - use MOM_restart, only : register_restart_field, query_initialized, set_initialized, MOM_restart_CS - use MOM_spatial_means, only : global_area_mean, global_mass_int_EFP, array_global_min_max - use MOM_sponge, only : set_up_sponge_field, sponge_CS - use MOM_time_manager, only : time_type, set_time - use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut - use MOM_tracer_registry, only : register_tracer, tracer_registry_type - use MOM_tracer_Z_init, only : tracer_Z_init - use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z - use MOM_unit_scaling, only : unit_scale_type - use MOM_variables, only : surface, thermo_var_ptrs - use MOM_verticalGrid, only : verticalGrid_type - - - implicit none ; private - - !> A state hidden in module data that is very much not allowed in MOM6 - ! ### This needs to be fixed - logical :: g_registered = .false. - - public register_MOM_generic_tracer, initialize_MOM_generic_tracer - public MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state - public end_MOM_generic_tracer, MOM_generic_tracer_get - public MOM_generic_tracer_stock - public MOM_generic_flux_init - public MOM_generic_tracer_min_max - public MOM_generic_tracer_fluxes_accumulate - public register_MOM_generic_tracer_segments - - !> Control structure for generic tracers - type, public :: MOM_generic_tracer_CS ; private - character(len = 200) :: IC_file !< The file in which the generic tracer initial values can - !! be found, or an empty string for internal initialization. - logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. - real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers, in - !! concentration units [conc] - real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out, in - !! concentration units [conc] - logical :: tracers_may_reinit !< If true, tracers may go through the - !! initialization code if they are not found in the restart files. - - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to - !! regulate the timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure - type(ocean_OBC_type), pointer :: OBC => NULL() ! Pointer to the first element of the linked list of generic tracers. - type(g_tracer_type), pointer :: g_tracer_list => NULL() - - end type MOM_generic_tracer_CS +! ### These imports should not reach into FMS directly ### + +use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_coms, only : EFP_type +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : param_file_type +use MOM_forcing_type, only : forcing, optics_type +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_sponge, only : sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +!> A state hidden in module data that is very much not allowed in MOM6 +! ### This needs to be fixed +logical :: g_registered = .false. + +public register_MOM_generic_tracer, initialize_MOM_generic_tracer +public MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state +public end_MOM_generic_tracer, MOM_generic_tracer_get +public MOM_generic_tracer_stock +public MOM_generic_flux_init +public MOM_generic_tracer_min_max +public MOM_generic_tracer_fluxes_accumulate +public register_MOM_generic_tracer_segments + +!> Control structure for generic tracers +type, public :: MOM_generic_tracer_CS ; private + character(len = 200) :: IC_file !< The file in which the generic tracer initial values can + !! be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. + real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers, in + !! concentration units [conc] + real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out, in + !! concentration units [conc] + logical :: tracers_may_reinit !< If true, tracers may go through the + !! initialization code if they are not found in the restart files. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure + type(ocean_OBC_type), pointer :: OBC => NULL() ! Pointer to the first element of the linked list of generic tracers. + !type(g_tracer_type), pointer :: g_tracer_list => NULL() + +end type MOM_generic_tracer_CS contains - !> Initializes the generic tracer packages and adds their tracers to the list - !! Adds the tracers in the list of generic tracers to the set of MOM tracers (i.e., MOM-register them) - !! Register these tracers for restart - function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< Horizontal index ranges - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module - type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer - !! advection and diffusion module. - type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct - - ! Local variables - logical :: register_MOM_generic_tracer - logical :: obc_has - ! This include declares and sets the variable "version". -# include "version_variable.h" - - character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer' - character(len=200) :: inputdir ! The directory where NetCDF input files are. - ! These can be overridden later in via the field manager? - - integer :: ntau, axes(3) - type(g_tracer_type), pointer :: g_tracer, g_tracer_next - character(len=fm_string_len) :: g_tracer_name, longname,units - character(len=fm_string_len) :: obc_src_file_name, obc_src_field_name - real :: lfac_in ! Multiplicative factor used in setting the tracer-specific inverse length - ! scales associated with inflowing tracer reservoirs at OBCs [nondim] - real :: lfac_out ! Multiplicative factor used in setting the tracer-specific inverse length - ! scales associated with outflowing tracer reservoirs at OBCs [nondim] - real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] - real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] - real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)) :: grid_tmask ! A 3-d copy of G%mask2dT [nondim] - integer, dimension(SZI_(HI),SZJ_(HI)) :: grid_kmt ! A 2-d array of nk - - register_MOM_generic_tracer = .false. - if (associated(CS)) then - call MOM_error(FATAL, "register_MOM_generic_tracer called with an "// & - "associated control structure.") - endif - allocate(CS) - - - !Register all the generic tracers used and create the list of them. - !This can be called by ALL PE's. No array fields allocated. - if (.not. g_registered) then - call generic_tracer_register() - g_registered = .true. - endif - - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, sub_name, version, "") - call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE", CS%IC_file, & - "The file in which the generic tracer initial values can "//& - "be found, or an empty string for internal initialization.", & - default=" ") - if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then - ! Add the directory if CS%IC_file is not already a complete path. - call get_param(param_file, sub_name, "INPUTDIR", inputdir, default=".") - CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) - call log_param(param_file, sub_name, "INPUTDIR/GENERIC_TRACER_IC_FILE", CS%IC_file) - endif - call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE_IS_Z", CS%Z_IC_file, & - "If true, GENERIC_TRACER_IC_FILE is in depth space, not "//& - "layer space.",default=.false.) - call get_param(param_file, sub_name, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code "//& - "if they are not found in the restart files. Otherwise "//& - "it is a fatal error if tracers are not found in the "//& - "restart files of a restarted run.", default=.false.) - - CS%restart_CSp => restart_CS - - ntau=1 ! MOM needs the fields at only one time step - - - ! At this point G%mask2dT and CS%diag%axesTL are not allocated. - ! postpone diag_registeration to initialize_MOM_generic_tracer - - !Fields cannot be diag registered as they are allocated and have to registered later. - grid_tmask(:,:,:) = 0.0 - grid_kmt(:,:) = 0 - axes(:) = -1 - - ! - ! Initialize all generic tracers - ! - call generic_tracer_init(HI%isc,HI%iec,HI%jsc,HI%jec,HI%isd,HI%ied,HI%jsd,HI%jed,& - GV%ke,ntau,axes,grid_tmask,grid_kmt,set_time(0,0)) - - - ! - ! MOM-register the generic tracers - ! - - !Get the tracer list - call generic_tracer_get_list(CS%g_tracer_list) - if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& - ": No tracer in the list.") - ! For each tracer name get its T_prog index and get its fields - - g_tracer=>CS%g_tracer_list - do - call g_tracer_get_alias(g_tracer,g_tracer_name) - - call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) - call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) - call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) - - !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? - tr_ptr => tr_field(:,:,:,1) - ! Register prognostic tracer for horizontal advection, diffusion, and restarts. - if (g_tracer_is_prog(g_tracer)) then - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & - name=g_tracer_name, longname=longname, units=units, & - registry_diags=.false., & !### CHANGE TO TRUE? - restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) - else - call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & - restart_CS, longname=longname, units=units) - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - - enddo - - register_MOM_generic_tracer = .true. - end function register_MOM_generic_tracer - - !> Register OBC segments for generic tracers - subroutine register_MOM_generic_tracer_segments(CS, GV, OBC, tr_Reg, param_file) - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, - !! where, and what open boundary conditions are used. - type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer - !! advection and diffusion module. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - - ! Local variables - logical :: obc_has - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer_segments' - type(g_tracer_type), pointer :: g_tracer,g_tracer_next - character(len=fm_string_len) :: g_tracer_name - character(len=fm_string_len) :: obc_src_file_name, obc_src_field_name - real :: lfac_in ! Multiplicative factor used in setting the tracer-specific inverse length - ! scales associated with inflowing tracer reservoirs at OBCs [nondim] - real :: lfac_out ! Multiplicative factor used in setting the tracer-specific inverse length - ! scales associated with outflowing tracer reservoirs at OBCs [nondim] - - if (.NOT. associated(OBC)) return - !Get the tracer list - call generic_tracer_get_list(CS%g_tracer_list) - if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& - ": No tracer in the list.") - - g_tracer=>CS%g_tracer_list - do - call g_tracer_get_alias(g_tracer,g_tracer_name) - if (g_tracer_is_prog(g_tracer)) then - call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ,& - obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) - if (obc_has) then - call set_obgc_segments_props(OBC,g_tracer_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) - call register_obgc_segments(GV, OBC, tr_Reg, param_file, g_tracer_name) - endif - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - - enddo - - end subroutine register_MOM_generic_tracer_segments - - !> Initialize phase II: Initialize required variables for generic tracers - !! There are some steps of initialization that cannot be done in register_MOM_generic_tracer - !! This is the place and time to do them: - !! Set the grid mask and initial time for all generic tracers. - !! Diag_register them. - !! Z_diag_register them. - !! - !! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) - !! and it sets up the tracer output. - subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_file, diag, OBC, & - CS, sponge_CSp, ALE_sponge_CSp) - logical, intent(in) :: restart !< .true. if the fields have already been - !! read from a restart file. - type(time_type), target, intent(in) :: day !< Time of the start of the run. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic - !! variables - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< Regulates diagnostic output. - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, - !! where, and what open boundary conditions are used. - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. - type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the - !! ALE sponges. - - character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' - logical :: OK,obc_has - integer :: i, j, k, isc, iec, jsc, jec, nk - type(g_tracer_type), pointer :: g_tracer,g_tracer_next - character(len=fm_string_len) :: g_tracer_name - real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] - real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Layer vertical extent [Z ~> m] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: grid_tmask ! A 3-d copy of G%mask2dT [nondim] - integer, dimension(SZI_(G),SZJ_(G)) :: grid_kmt ! A 2-d array of nk - - !! 2010/02/04 Add code to re-initialize Generic Tracers if needed during a model simulation - !! By default, restart cpio should not contain a Generic Tracer IC file and step below will be skipped. - !! Ideally, the generic tracer IC file should have the tracers on Z levels. - - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke - - CS%diag=>diag - !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& - ": No tracer in the list.") - !For each tracer name get its fields - g_tracer=>CS%g_tracer_list - - call thickness_to_dz(h, tv, dz, G, GV, US) - - do - if (INDEX(CS%IC_file, '_NULL_') /= 0) then - call MOM_error(WARNING, "The name of the IC_file "//trim(CS%IC_file)//& - " indicates no MOM initialization was asked for the generic tracers."//& - "Bypassing the MOM initialization of ALL generic tracers!") - exit - endif - call g_tracer_get_alias(g_tracer,g_tracer_name) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) - tr_ptr => tr_field(:,:,:,1) - - if (.not.restart .or. (CS%tracers_may_reinit .and. & - .not.query_initialized(tr_ptr, g_tracer_name, CS%restart_CSp))) then - - if (g_tracer%requires_src_info ) then - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initializing generic tracer "//trim(g_tracer_name)//& - " using MOM_initialize_tracer_from_Z ") - - call MOM_initialize_tracer_from_Z(dz, tr_ptr, G, GV, US, param_file, & - src_file=g_tracer%src_file, src_var_nam=g_tracer%src_var_name, & - src_var_unit_conversion=g_tracer%src_var_unit_conversion, & - src_var_record=g_tracer%src_var_record, src_var_gridspec=g_tracer%src_var_gridspec, & - h_in_Z_units=.true.) - - !Check/apply the bounds for each g_tracer - do k=1,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min - !Jasmin does not want to apply the maximum for now - !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max - endif - enddo ; enddo ; enddo - - !jgj: Reset CASED to 0 below K=1 - if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then - do k=2,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - tr_ptr(i,j,k) = 0.0 - endif - enddo ; enddo ; enddo - endif - elseif(.not. g_tracer%requires_restart) then - !Do nothing for this tracer, it is initialized by the tracer package - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "skip initialization of generic tracer "//trim(g_tracer_name)) - else !Do it old way if the tracer is not registered to start from a specific source file. - !This path should be deprecated if all generic tracers are required to start from specified sources. - if (len_trim(CS%IC_file) > 0) then - ! Read the tracer concentrations from a netcdf file. - if (.not.file_exists(CS%IC_file)) call MOM_error(FATAL, & - "initialize_MOM_Generic_tracer: Unable to open "//CS%IC_file) - if (CS%Z_IC_file) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, GV, US) - if (.not.OK) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, GV, US) - if (.not.OK) call MOM_error(FATAL,"initialize_MOM_Generic_tracer: "//& - "Unable to read "//trim(g_tracer_name)//" from "//& - trim(CS%IC_file)//".") - endif - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initialized generic tracer "//trim(g_tracer_name)//& - " using Generic Tracer File on Z: "//CS%IC_file) - else - ! native grid - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "Using Generic Tracer IC file on native grid "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - call MOM_read_data(CS%IC_file, trim(g_tracer_name), tr_ptr, G%Domain) - endif - else - call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& - "check Generic Tracer IC filename "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - endif - - endif - - call set_initialized(tr_ptr, g_tracer_name, CS%restart_CSp) - endif - - call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ) - if(obc_has .and. g_tracer_is_prog(g_tracer) .and. .not.restart) & - call fill_obgc_segments(G, GV, OBC, tr_ptr, g_tracer_name) - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - enddo - !! end section to re-initialize generic tracers - - - !Now we can reset the grid mask, axes and time to their true values - !Note that grid_tmask must be set correctly on the data domain boundary - !so that coast mask can be deduced from it. - grid_tmask(:,:,:) = 0.0 - grid_kmt(:,:) = 0 - do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) > 0.0) then - grid_tmask(i,j,:) = 1.0 - grid_kmt(i,j) = GV%ke ! Tell the code that a layer thicker than 1m is the bottom layer. - endif - enddo ; enddo - call g_tracer_set_common(G%isc,G%iec,G%jsc,G%jec,G%isd,G%ied,G%jsd,G%jed,& - GV%ke,1,CS%diag%axesTL%handles,grid_tmask,grid_kmt,day) - - ! Register generic tracer modules diagnostics - -#ifdef _USE_MOM6_DIAG - call g_tracer_set_csdiag(CS%diag) -#endif - call generic_tracer_register_diag() -#ifdef _USE_MOM6_DIAG - call g_tracer_set_csdiag(CS%diag) -#endif - - end subroutine initialize_MOM_generic_tracer - - !> Column physics for generic tracers. - !! Get the coupler values for generic tracers that exchange with atmosphere - !! Update generic tracer concentration fields from sources and sinks. - !! Vertically diffuse generic tracer concentration fields. - !! Update generic tracers from bottom and their bottom reservoir. - !! - !! This subroutine applies diapycnal diffusion and any other column - !! tracer physics or chemistry to the tracers from this file. - !! CFCs are relatively simple, as they are passive tracers. with only a surface - !! flux as a source. - subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, CS, tv, optics, & - evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: ea !< The amount of fluid entrained from the layer - !! above during this call [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: eb !< The amount of fluid entrained from the layer - !! below during this call [H ~> m or kg m-2]. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic - !! and tracer forcing fields. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] - real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - type(optics_type), intent(in) :: optics !< The structure containing optical properties. - real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can - !! be fluxed out of the top layer in a timestep [nondim] - ! Stored previously in diabatic CS. - real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied [H ~> m or kg m-2] - ! Stored previously in diabatic CS. - ! The arguments to this subroutine are redundant in that - ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) - - ! Local variables - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_column_physics' - - type(g_tracer_type), pointer :: g_tracer, g_tracer_next - character(len=fm_string_len) :: g_tracer_name - real, dimension(:,:), pointer :: stf_array ! The surface flux of the tracer [conc kg m-2 s-1] - real, dimension(:,:), pointer :: trunoff_array ! The tracer concentration in the river runoff [conc] - real, dimension(:,:), pointer :: runoff_tracer_flux_array ! The runoff tracer flux [conc kg m-2 s-1] - - real :: surface_field(SZI_(G),SZJ_(G)) ! The surface value of some field, here only used for salinity [S ~> ppt] - real :: dz_ml(SZI_(G),SZJ_(G)) ! The mixed layer depth in the MKS units used for generic tracers [m] - real :: sosga ! The global mean surface salinity [ppt] - - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: rho_dzt ! Layer mass per unit area [kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dzt ! Layer vertical extents [m] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! A work array of thicknesses [H ~> m or kg m-2] - integer :: i, j, k, isc, iec, jsc, jec, nk - - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke - - !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL,& - trim(sub_name)//": No tracer in the list.") - -#ifdef _USE_MOM6_DIAG - call g_tracer_set_csdiag(CS%diag) -#endif - - ! - !Extract the tracer surface fields from coupler and update tracer fields from sources - ! - !call generic_tracer_coupler_get(fluxes%tr_fluxes) - !Niki: This is moved out to ocean_model_MOM.F90 because if dt_therm>dt_cpld we need to average - ! the fluxes without coming into this subroutine. - ! MOM5 has to modified to conform. - - ! - !Add contribution of river to surface flux - ! - g_tracer=>CS%g_tracer_list - do - if (_ALLOCATED(g_tracer%trunoff) .and. (.NOT. g_tracer%runoff_added_to_stf)) then - call g_tracer_get_alias(g_tracer,g_tracer_name) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) - !nnz: Why is fluxes%river = 0? - runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & - US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) - stf_array = stf_array + runoff_tracer_flux_array - g_tracer%runoff_added_to_stf = .true. - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer => g_tracer_next - - enddo - - ! - !Prepare input arrays for source update - ! - - rho_dzt(:,:,:) = GV%H_to_kg_m2 * GV%Angstrom_H - do k=1,nk ; do j=jsc,jec ; do i=isc,iec - rho_dzt(i,j,k) = GV%H_to_kg_m2 * h_old(i,j,k) - enddo ; enddo ; enddo - - dzt(:,:,:) = 1.0 - call thickness_to_dz(h_old, tv, dzt, G, GV, US) - do k=1,nk ; do j=jsc,jec ; do i=isc,iec - dzt(i,j,k) = US%Z_to_m * dzt(i,j,k) - enddo ; enddo ; enddo - dz_ml(:,:) = 0.0 - do j=jsc,jec ; do i=isc,iec - surface_field(i,j) = tv%S(i,j,1) - dz_ml(i,j) = US%Z_to_m * Hml(i,j) - enddo ; enddo - sosga = global_area_mean(surface_field, G, unscale=US%S_to_ppt) - - ! - !Calculate tendencies (i.e., field changes at dt) from the sources / sinks - ! - if ((G%US%L_to_m == 1.0) .and. (G%US%s_to_T == 1.0) .and. (G%US%Z_to_m == 1.0) .and. & - (G%US%Q_to_J_kg == 1.0) .and. (G%US%RZ_to_kg_m2 == 1.0) .and. & - (US%C_to_degC == 1.0) .and. (US%S_to_ppt == 1.0)) then - ! Avoid unnecessary copies when no unit conversion is needed. - call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & - G%areaT, get_diag_time_end(CS%diag), & - optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & - internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) - else - ! tv%internal_heat is a null pointer unless DO_GEOTHERMAL = True, - ! so we have to check and only do the scaling if it is associated. - if(associated(tv%internal_heat)) then - call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & - G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & - optics%nbands, optics%max_wavelength_band, & - sw_pen_band=G%US%QRZ_T_to_W_m2*optics%sw_pen_band(:,:,:), & - opacity_band=G%US%m_to_Z*optics%opacity_band(:,:,:,:), & - internal_heat=G%US%RZ_to_kg_m2*US%C_to_degC*tv%internal_heat(:,:), & - frunoff=G%US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) - else - call generic_tracer_source(US%C_to_degC*tv%T, US%S_to_ppt*tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & - G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & - optics%nbands, optics%max_wavelength_band, & - sw_pen_band=G%US%QRZ_T_to_W_m2*optics%sw_pen_band(:,:,:), & - opacity_band=G%US%m_to_Z*optics%opacity_band(:,:,:,:), & - frunoff=G%US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) - endif - endif - - ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes - ! usually in ALE mode - if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - g_tracer=>CS%g_tracer_list - do - if (g_tracer_is_prog(g_tracer)) then - do k=1,nk ;do j=jsc,jec ; do i=isc,iec - h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), dt, & - fluxes, h_work, evap_CFL_limit, minimum_forcing_depth) - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - enddo - endif - - ! - !Update Tr(n)%field from explicit vertical diffusion - ! - ! Use a tridiagonal solver to determine the concentrations after the - ! surface source is applied and diapycnal advection and diffusion occurs. - if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - ! Last arg is tau which is always 1 for MOM6 - call generic_tracer_vertdiff_G(h_work, ea, eb, US%T_to_s*dt, GV%kg_m2_to_H, GV%m_to_H, 1) - else - ! Last arg is tau which is always 1 for MOM6 - call generic_tracer_vertdiff_G(h_old, ea, eb, US%T_to_s*dt, GV%kg_m2_to_H, GV%m_to_H, 1) - endif - - ! Update bottom fields after vertical processes - - ! Second arg is tau which is always 1 for MOM6 - call generic_tracer_update_from_bottom(US%T_to_s*dt, 1, get_diag_time_end(CS%diag)) - - !Output diagnostics via diag_manager for all generic tracers and their fluxes - call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) -#ifdef _USE_MOM6_DIAG - call g_tracer_set_csdiag(CS%diag) -#endif - - end subroutine MOM_generic_tracer_column_physics - - !> This subroutine calculates mass-weighted integral on the PE either - !! of all available tracer concentrations, or of a tracer that is - !! being requested specifically, returning the number of stocks it has - !! calculated. If the stock_index is present, only the stock corresponding - !! to that coded index is returned. - function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc] - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. - character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. - integer, optional, intent(in) :: stock_index !< The coded index of a specific stock - !! being sought. - integer :: MOM_generic_tracer_stock !< Return value, the - !! number of stocks calculated here. - - ! Local variables - type(g_tracer_type), pointer :: g_tracer, g_tracer_next - real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] - real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' - - integer :: m - - MOM_generic_tracer_stock = 0 - if (.not.associated(CS)) return - - if (present(stock_index)) then ; if (stock_index > 0) then - ! Check whether this stock is available from this routine. - - ! No stocks from this routine are being checked yet. Return 0. - return - endif ; endif - - if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - - m=1 ; g_tracer=>CS%g_tracer_list - do - call g_tracer_get_alias(g_tracer,names(m)) - call g_tracer_get_values(g_tracer,names(m),'units',units(m)) - units(m) = trim(units(m))//" kg" - call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) - - tr_ptr => tr_field(:,:,:,1) - stocks(m) = global_mass_int_EFP(h, G, GV, tr_ptr, on_PE_only=.true.) - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - m = m+1 - enddo - - MOM_generic_tracer_stock = m - - end function MOM_generic_tracer_stock - - !> This subroutine finds the global min and max of either of all available - !! tracer concentrations, or of a tracer that is being requested specifically, - !! returning the number of tracers it has evaluated. - !! It also optionally returns the locations of the extrema. - function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, G, CS, names, units, & - xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) - integer, intent(in) :: ind_start !< The index of the tracer to start with - logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and - !! max are found for each tracer - real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer [conc] - real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer [conc] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. - character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. - real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the - !! units of G%geoLonT, often [degrees_E] or [km] or [m] - real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the - !! units of G%geoLatT, often [degrees_N] or [km] or [m] - real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] - real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the - !! units of G%geoLonT, often [degrees_E] or [km] or [m] - real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the - !! units of G%geoLatT, often [degrees_N] or [km] or [m] - real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] - integer :: MOM_generic_tracer_min_max !< Return value, the - !! number of tracers done here. - - ! Local variables - type(g_tracer_type), pointer :: g_tracer, g_tracer_next - real, dimension(:,:,:,:), pointer :: tr_field ! The tracer array whose extrema are being sought [conc] - real, dimension(:,:,:), pointer :: tr_ptr ! The tracer array whose extrema are being sought [conc] - real :: x_min ! The x-position of the global minimum in the units of G%geoLonT, often [degrees_E] or [km] or [m] - real :: y_min ! The y-position of the global minimum in the units of G%geoLatT, often [degrees_N] or [km] or [m] - real :: z_min ! The z-position of the global minimum [layer] - real :: x_max ! The x-position of the global maximum in the units of G%geoLonT, often [degrees_E] or [km] or [m] - real :: y_max ! The y-position of the global maximum in the units of G%geoLatT, often [degrees_N] or [km] or [m] - real :: z_max ! The z-position of the global maximum [layer] - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' - - logical :: find_location - integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, nk, ntau - integer :: k, is, ie, js, je, m - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - MOM_generic_tracer_min_max = 0 - if (.not.associated(CS)) return - - if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - - call g_tracer_get_common(isc, iec, jsc, jec, isd, ied, jsd, jed, nk, ntau) - find_location = present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & - present(xgmax) .or. present(ygmax) .or. present(zgmax) - - m=ind_start ; g_tracer=>CS%g_tracer_list - do - call g_tracer_get_alias(g_tracer,names(m)) - call g_tracer_get_values(g_tracer,names(m),'units',units(m)) - call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) - - gmin(m) = -1.0 - gmax(m) = -1.0 - - tr_ptr => tr_field(:,:,:,1) - - if (find_location) then - call array_global_min_max(tr_ptr, G, nk, gmin(m), gmax(m), & - x_min, y_min, z_min, x_max, y_max, z_max) - if (present(xgmin)) xgmin(m) = x_min - if (present(ygmin)) ygmin(m) = y_min - if (present(zgmin)) zgmin(m) = z_min - if (present(xgmax)) xgmax(m) = x_max - if (present(ygmax)) ygmax(m) = y_max - if (present(zgmax)) zgmax(m) = z_max - else - call array_global_min_max(tr_ptr, G, nk, gmin(m), gmax(m)) - endif - - got_minmax(m) = .true. - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - m = m+1 - enddo - - MOM_generic_tracer_min_max = m - - end function MOM_generic_tracer_min_max - - !> This subroutine calculates the surface state and sets coupler values for - !! those generic tracers that have flux exchange with atmosphere. - !! - !! This subroutine sets up the fields that the coupler needs to calculate the - !! CFC fluxes between the ocean and atmosphere. - subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - - ! Local variables - real :: sosga ! The global mean surface salinity [ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV),1) :: rho0 ! An unused array of densities [kg m-3] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dzt ! Layer vertical extents [m] - - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' - - !Set coupler values - !nnz: fake rho0 - rho0(:,:,:,:) = 1.0 - - dzt(:,:,:) = GV%H_to_m * h(:,:,:) - - sosga = global_area_mean(sfc_state%SSS, G, unscale=G%US%S_to_ppt) - - if ((G%US%C_to_degC == 1.0) .and. (G%US%S_to_ppt == 1.0)) then - call generic_tracer_coupler_set(sfc_state%tr_fields, & - ST=sfc_state%SST, SS=sfc_state%SSS, & - rho=rho0, & !nnz: required for MOM5 and previous versions. - ilb=G%isd, jlb=G%jsd, & - dzt=dzt,& !This is needed for the Mocsy method of carbonate system vars - tau=1, sosga=sosga, model_time=get_diag_time_end(CS%diag)) - else - call generic_tracer_coupler_set(sfc_state%tr_fields, & - ST=G%US%C_to_degC*sfc_state%SST, SS=G%US%S_to_ppt*sfc_state%SSS, & - rho=rho0, & !nnz: required for MOM5 and previous versions. - ilb=G%isd, jlb=G%jsd, & - dzt=dzt,& !This is needed for the Mocsy method of carbonate system vars - tau=1, sosga=sosga, model_time=get_diag_time_end(CS%diag)) - endif - - !Output diagnostics via diag_manager for all tracers in this module -! if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& -! "No tracer in the list.") -! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) - !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld - ! hence if dt_therm > dt_cpld we get output (and contribution to the mean) at times that tracers - ! had not been updated. - ! Moving this to the end of column physics subroutine fixes this issue. - - end subroutine MOM_generic_tracer_surface_state +!> Initializes the generic tracer packages and adds their tracers to the list +!! Adds the tracers in the list of generic tracers to the set of MOM tracers (i.e., MOM-register them) +!! Register these tracers for restart +function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) +!subroutine register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< Horizontal index ranges + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer + !! advection and diffusion module. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + logical :: register_MOM_generic_tracer + + register_MOM_generic_tracer = .false. + + call MOM_error(FATAL, "register_MOM_generic_tracer should not be called with the stub code "// & + "in MOM6/config_src/external, as it does nothing. Recompile using the full MOM_generic_tracer package.") + +end function register_MOM_generic_tracer + +!> Register OBC segments for generic tracers +subroutine register_MOM_generic_tracer_segments(CS, GV, OBC, tr_Reg, param_file) + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. + type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer + !! advection and diffusion module. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + +end subroutine register_MOM_generic_tracer_segments + +!> Initialize phase II: Initialize required variables for generic tracers +!! There are some steps of initialization that cannot be done in register_MOM_generic_tracer +!! This is the place and time to do them: +!! Set the grid mask and initial time for all generic tracers. +!! Diag_register them. +!! Z_diag_register them. +!! +!! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) +!! and it sets up the tracer output. +subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_file, diag, OBC, & + CS, sponge_CSp, ALE_sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already been + !! read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic + !! variables + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< Regulates diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the + !! ALE sponges. + +end subroutine initialize_MOM_generic_tracer + +!> Column physics for generic tracers. +!! Get the coupler values for generic tracers that exchange with atmosphere +!! Update generic tracer concentration fields from sources and sinks. +!! Vertically diffuse generic tracer concentration fields. +!! Update generic tracers from bottom and their bottom reservoir. +!! +!! This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +!! CFCs are relatively simple, as they are passive tracers. with only a surface +!! flux as a source. +subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, CS, tv, optics, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< The amount of fluid entrained from the layer + !! above during this call [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< The amount of fluid entrained from the layer + !! below during this call [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(optics_type), intent(in) :: optics !< The structure containing optical properties. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + ! Stored previously in diabatic CS. + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes + !! can be applied [H ~> m or kg m-2] + ! Stored previously in diabatic CS. + +end subroutine MOM_generic_tracer_column_physics + +!> This subroutine calculates mass-weighted integral on the PE either +!! of all available tracer concentrations, or of a tracer that is +!! being requested specifically, returning the number of stocks it has +!! calculated. If the stock_index is present, only the stock corresponding +!! to that coded index is returned. +function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: MOM_generic_tracer_stock !< Return value, the + !! number of stocks calculated here. + + MOM_generic_tracer_stock = 0 + +end function MOM_generic_tracer_stock + +!> This subroutine finds the global min and max of either of all available +!! tracer concentrations, or of a tracer that is being requested specifically, +!! returning the number of tracers it has evaluated. +!! It also optionally returns the locations of the extrema. +function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, G, CS, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) + integer, intent(in) :: ind_start !< The index of the tracer to start with + logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer [conc] + real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer [conc] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] + integer :: MOM_generic_tracer_min_max !< Return value, the + !! number of tracers done here. + + MOM_generic_tracer_min_max = 0 + +end function MOM_generic_tracer_min_max + +!> This subroutine calculates the surface state and sets coupler values for +!! those generic tracers that have flux exchange with atmosphere. +!! +!! This subroutine sets up the fields that the coupler needs to calculate the +!! CFC fluxes between the ocean and atmosphere. +subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + +end subroutine MOM_generic_tracer_surface_state !ALL PE subroutine on Ocean! Due to otpm design the fluxes should be initialized like this on ALL PE's! - subroutine MOM_generic_flux_init(verbosity) - integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. - - character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' - type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next - - if (.not. g_registered) then - call generic_tracer_register() - g_registered = .true. - endif - - call generic_tracer_get_list(g_tracer_list) - if (.NOT. associated(g_tracer_list)) then - call MOM_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") - return - endif - - g_tracer=>g_tracer_list - do - - call g_tracer_flux_init(g_tracer, verbosity=verbosity) - - ! traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - - enddo - - end subroutine MOM_generic_flux_init - - subroutine MOM_generic_tracer_fluxes_accumulate(flux_tmp, weight) - type(forcing), intent(in) :: flux_tmp !< A structure containing pointers to - !! thermodynamic and tracer forcing fields. - real, intent(in) :: weight !< A weight for accumulating this flux [nondim] - - call generic_tracer_coupler_accumulate(flux_tmp%tr_fluxes, weight) +subroutine MOM_generic_flux_init(verbosity) + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. - end subroutine MOM_generic_tracer_fluxes_accumulate +end subroutine MOM_generic_flux_init - !> Copy the requested tracer into an array. - subroutine MOM_generic_tracer_get(name,member,array, CS) - character(len=*), intent(in) :: name !< Name of requested tracer. - character(len=*), intent(in) :: member !< The tracer element to return. - real, dimension(:,:,:), intent(out) :: array !< Array filled by this routine, in arbitrary units [A] - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. +subroutine MOM_generic_tracer_fluxes_accumulate(flux_tmp, weight) + type(forcing), intent(in) :: flux_tmp !< A structure containing pointers to + !! thermodynamic and tracer forcing fields. + real, intent(in) :: weight !< A weight for accumulating this flux [nondim] - ! Local variables - real, dimension(:,:,:), pointer :: array_ptr ! The tracer in the generic tracer structures, in - ! arbitrary units [A] - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' +end subroutine MOM_generic_tracer_fluxes_accumulate - call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) - array(:,:,:) = array_ptr(:,:,:) +!> Copy the requested tracer into an array. +subroutine MOM_generic_tracer_get(name,member,array, CS) + character(len=*), intent(in) :: name !< Name of requested tracer. + character(len=*), intent(in) :: member !< The tracer element to return. + real, dimension(:,:,:), intent(out) :: array !< Array filled by this routine, in arbitrary units [A] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - end subroutine MOM_generic_tracer_get + ! Local variables + real, dimension(:,:,:), pointer :: array_ptr ! The tracer in the generic tracer structures, in + ! arbitrary units [A] + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' - !> This subroutine deallocates the memory owned by this module. - subroutine end_MOM_generic_tracer(CS) - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. +end subroutine MOM_generic_tracer_get - call generic_tracer_end() +!> This subroutine deallocates the memory owned by this module. +subroutine end_MOM_generic_tracer(CS) + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - if (associated(CS)) then - deallocate(CS) - endif - end subroutine end_MOM_generic_tracer +end subroutine end_MOM_generic_tracer !---------------------------------------------------------------- ! Niki Zadeh diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 deleted file mode 100644 index 42c386497a..0000000000 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 +++ /dev/null @@ -1,149 +0,0 @@ -!> A non-functioning template of the GFDL ocean BGC -module generic_tracer - - use time_manager_mod, only : time_type - use coupler_types_mod, only : coupler_2d_bc_type - - use g_tracer_utils, only : g_tracer_type, g_diag_type - - implicit none ; private - - public generic_tracer_register - public generic_tracer_init - public generic_tracer_register_diag - public generic_tracer_source - public generic_tracer_update_from_bottom - public generic_tracer_coupler_get - public generic_tracer_coupler_set - public generic_tracer_end - public generic_tracer_get_list - public do_generic_tracer - public generic_tracer_vertdiff_G - public generic_tracer_get_diag_list - public generic_tracer_coupler_accumulate - - !> Turn on generic tracers (note dangerous use of module data) - logical :: do_generic_tracer = .true. - -contains - - !> Unknown - subroutine generic_tracer_register - end subroutine generic_tracer_register - - !> Initialize generic tracers - subroutine generic_tracer_init(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) - integer, intent(in) :: isc !< Computation start index in i direction - integer, intent(in) :: iec !< Computation end index in i direction - integer, intent(in) :: jsc !< Computation start index in j direction - integer, intent(in) :: jec !< Computation end index in j direction - integer, intent(in) :: isd !< Data start index in i direction - integer, intent(in) :: ied !< Data end index in i direction - integer, intent(in) :: jsd !< Data start index in j direction - integer, intent(in) :: jed !< Data end index in j direction - integer, intent(in) :: nk !< Number of levels in k direction - integer, intent(in) :: ntau !< The number of tracer time levels (always 1 for MOM6) - integer, intent(in) :: axes(3) !< Domain axes? - type(time_type), intent(in) :: init_time !< Time - real, dimension(:,:,:),target, intent(in) :: grid_tmask !< Mask - integer, dimension(:,:) , intent(in) :: grid_kmt !< Number of wet cells in column - end subroutine generic_tracer_init - - !> Unknown - subroutine generic_tracer_register_diag - end subroutine generic_tracer_register_diag - - !> Get coupler values - subroutine generic_tracer_coupler_get(IOB_struc) - type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure - end subroutine generic_tracer_coupler_get - - !> Unknown - subroutine generic_tracer_coupler_accumulate(IOB_struc, weight, model_time) - type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure - real, intent(in) :: weight !< A weight for accumulating these fluxes - type(time_type), optional,intent(in) :: model_time !< Time - end subroutine generic_tracer_coupler_accumulate - - !> Calls the corresponding generic_X_update_from_source routine for each package X - subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& - grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& - frunoff,grid_ht, current_wave_stress, sosga) - integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain - integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain - real, dimension(ilb:,jlb:,:), intent(in) :: Temp !< Potential temperature [deg C] - real, dimension(ilb:,jlb:,:), intent(in) :: Salt !< Salinity [psu] - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt !< Mass per unit area of each layer [kg m-2] - real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] - real, dimension(ilb:,jlb:), intent(in) :: hblt_depth !< Boundary layer depth [m] - integer, intent(in) :: tau !< Time step index of %field - real, intent(in) :: dtts !< The time step for this call [s] - real, dimension(ilb:,jlb:), intent(in) :: grid_dat !< Grid cell areas [m2] - type(time_type), intent(in) :: model_time !< Time - integer, intent(in) :: nbands !< The number of bands of penetrating shortwave radiation - real, dimension(:), intent(in) :: max_wavelength_band !< The maximum wavelength in each band - !! of penetrating shortwave radiation [nm] - real, dimension(:,ilb:,jlb:), intent(in) :: sw_pen_band !< Penetrating shortwave radiation per band [W m-2]. - !! The wavelength or angular direction band is the first index. - real, dimension(:,ilb:,jlb:,:), intent(in) :: opacity_band !< Opacity of seawater averaged over each band [m-1]. - !! The wavelength or angular direction band is the first index. - real, dimension(ilb:,jlb:),optional, intent(in) :: internal_heat !< Any internal or geothermal heat - !! sources that are applied to the ocean integrated - !! over this timestep [degC kg m-2] - real, dimension(ilb:,jlb:),optional, intent(in) :: frunoff !< Rate of iceberg calving [kg m-2 s-1] - real, dimension(ilb:,jlb:),optional, intent(in) :: grid_ht !< Unknown, and presently unused by MOM6 - real, dimension(ilb:,jlb:),optional , intent(in) :: current_wave_stress !< Unknown, and presently unused by MOM6 - real, optional , intent(in) :: sosga !< Global average sea surface salinity [ppt] - end subroutine generic_tracer_source - - !> Update the tracers from bottom fluxes - subroutine generic_tracer_update_from_bottom(dt, tau, model_time) - real, intent(in) :: dt !< Time step increment [s] - integer, intent(in) :: tau !< Time step index used for the concentration field - type(time_type), intent(in) :: model_time !< Time - end subroutine generic_tracer_update_from_bottom - - !> Vertically diffuse all generic tracers for GOLD ocean - subroutine generic_tracer_vertdiff_G(h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau) - real, dimension(:,:,:), intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: ea !< The amount of fluid entrained from the layer - !! above during this call [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: eb !< The amount of fluid entrained from the layer - !! below during this call [H ~> m or kg m-2] - real, intent(in) :: dt !< The amount of time covered by this call [s] - real, intent(in) :: kg_m2_to_H !< A unit conversion factor from mass per unit - !! area to thickness units [H m2 kg-1 ~> m3 kg-1 or 1] - real, intent(in) :: m_to_H !< A unit conversion factor from heights to - !! thickness units [H m-1 ~> 1 or kg m-3] - integer, intent(in) :: tau !< The time level to work on (always 1 for MOM6) - end subroutine generic_tracer_vertdiff_G - - !> Set the coupler values for each generic tracer - subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sosga,model_time) - type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure - integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain - integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain - integer, intent(in) :: tau !< Time step index of %field - real, dimension(ilb:,jlb:), intent(in) :: ST !< Sea surface temperature [degC] - real, dimension(ilb:,jlb:), intent(in) :: SS !< Sea surface salinity [ppt] - real, dimension(ilb:,jlb:,:,:), intent(in) :: rho !< Ocean density [kg m-3] - real, dimension(ilb:,jlb:,:), optional, intent(in) :: dzt !< Layer thickness [m] - real, optional, intent(in) :: sosga !< Global mean sea surface salinity [ppt] - type(time_type),optional, intent(in) :: model_time !< Time - end subroutine generic_tracer_coupler_set - - !> End this module by calling the corresponding generic_X_end for each package X - subroutine generic_tracer_end - end subroutine generic_tracer_end - - !> Get a pointer to the head of the generic tracers list - subroutine generic_tracer_get_list(list) - type(g_tracer_type), pointer :: list !< Pointer to head of the linked list - end subroutine generic_tracer_get_list - - !> Unknown - subroutine generic_tracer_get_diag_list(list) - type(g_diag_type), pointer :: list !< Pointer to head of the linked list - end subroutine generic_tracer_get_diag_list - -end module generic_tracer diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 deleted file mode 100644 index 5c87c37e70..0000000000 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ /dev/null @@ -1,355 +0,0 @@ -!> g_tracer_utils module consists of core utility subroutines to be used by -!! all generic tracer modules. These include the lowest level functions -!! for adding, allocating memory, and record keeping of individual generic -!! tracers irrespective of their physical/chemical nature. -module g_tracer_utils - - use coupler_types_mod, only: coupler_2d_bc_type - use time_manager_mod, only : time_type - use field_manager_mod, only: fm_string_len - use MOM_diag_mediator, only : g_diag_ctrl=>diag_ctrl - -implicit none ; private - - !> Each generic tracer node is an instant of a FORTRAN type with the following member variables. - !! These member fields are supposed to uniquely define an individual tracer. - !! One such type shall be instantiated for EACH individual tracer. - type g_tracer_type - !> Tracer concentration field in space (and time) - !! MOM keeps the prognostic tracer fields at 3 time levels, hence 4D. - real, pointer, dimension(:,:,:,:) :: field => NULL() - !> Tracer concentration in river runoff - real, allocatable, dimension(:,:) :: trunoff - logical :: requires_restart = .true. !< Unknown - character(len=fm_string_len) :: src_file !< Tracer source filename - character(len=fm_string_len) :: src_var_name !< Tracer source variable name - character(len=fm_string_len) :: src_var_unit !< Tracer source variable units - character(len=fm_string_len) :: src_var_gridspec !< Tracer source grid file name - character(len=fm_string_len) :: obc_src_file_name !< Boundary condition tracer source filename - character(len=fm_string_len) :: obc_src_field_name !< Boundary condition tracer source fieldname - integer :: src_var_record !< Unknown - logical :: runoff_added_to_stf = .false. !< Has flux in from runoff been added to stf? - logical :: requires_src_info = .false. !< Unknown - real :: src_var_unit_conversion = 1.0 !< This factor depends on the tracer. Ask Jasmin - real :: src_var_valid_min = 0.0 !< Unknown - end type g_tracer_type - - !> Unknown - type g_diag_type - integer :: dummy !< A dummy member, not part of the API - end type g_diag_type - - !> The following type fields are common to ALL generic tracers and hence has to be instantiated only once - type g_tracer_common -! type(g_diag_ctrl) :: diag_CS !< Unknown - !> Domain extents - integer :: isd !< Start index of the data domain in the i-direction - integer :: jsd !< Start index of the data domain in the j-direction - end type g_tracer_common - - !> Unknown dangerous module data! - type(g_tracer_common), target, save :: g_tracer_com - - public :: g_tracer_type - public :: g_tracer_flux_init - public :: g_tracer_set_values - public :: g_tracer_get_values - public :: g_tracer_get_pointer - public :: g_tracer_get_common - public :: g_tracer_set_common - public :: g_tracer_set_csdiag - public :: g_tracer_send_diag - public :: g_tracer_get_name - public :: g_tracer_get_alias - public :: g_tracer_get_next - public :: g_tracer_is_prog - public :: g_diag_type - public :: g_tracer_get_obc_segment_props - - !> Set the values of various (array) members of the tracer node g_tracer_type - !! - !! This function is overloaded to set the values of the following member variables - interface g_tracer_set_values - module procedure g_tracer_set_real - module procedure g_tracer_set_2D - module procedure g_tracer_set_3D - module procedure g_tracer_set_4D - end interface - - !> Reverse of interface g_tracer_set_values for getting the tracer member arrays in the argument value - !! - !! This means "get the values of array %field_name for tracer tracer_name and put them in argument array_out" - interface g_tracer_get_values - module procedure g_tracer_get_4D_val - module procedure g_tracer_get_3D_val - module procedure g_tracer_get_2D_val - module procedure g_tracer_get_real - module procedure g_tracer_get_string - end interface - - !> Return the pointer to the requested field of a particular tracer - !! - !! This means "get the pointer of array %field_name for tracer tracer_name in argument array_ptr" - interface g_tracer_get_pointer - module procedure g_tracer_get_4D - module procedure g_tracer_get_3D - module procedure g_tracer_get_2D - end interface - -contains - - !> Unknown - subroutine g_tracer_flux_init(g_tracer, verbosity) - type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node - integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity - end subroutine g_tracer_flux_init - - !> Unknown - subroutine g_tracer_set_csdiag(diag_CS) - type(g_diag_ctrl), target,intent(in) :: diag_CS !< Unknown - end subroutine g_tracer_set_csdiag - - subroutine g_tracer_set_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) - integer, intent(in) :: isc !< Computation start index in i direction - integer, intent(in) :: iec !< Computation end index in i direction - integer, intent(in) :: jsc !< Computation start index in j direction - integer, intent(in) :: jec !< Computation end index in j direction - integer, intent(in) :: isd !< Data start index in i direction - integer, intent(in) :: ied !< Data end index in i direction - integer, intent(in) :: jsd !< Data start index in j direction - integer, intent(in) :: jed !< Data end index in j direction - integer, intent(in) :: nk !< Number of levels in k direction - integer, intent(in) :: ntau !< Unknown - integer, intent(in) :: axes(3) !< Domain axes? - real, dimension(isd:,jsd:,:),intent(in) :: grid_tmask !< Unknown - integer,dimension(isd:,jsd:),intent(in) :: grid_kmt !< Unknown - type(time_type), intent(in) :: init_time !< Unknown - end subroutine g_tracer_set_common - - subroutine g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,& - axes,grid_tmask,grid_mask_coast,grid_kmt,init_time,diag_CS) - integer, intent(out) :: isc !< Computation start index in i direction - integer, intent(out) :: iec !< Computation end index in i direction - integer, intent(out) :: jsc !< Computation start index in j direction - integer, intent(out) :: jec !< Computation end index in j direction - integer, intent(out) :: isd !< Data start index in i direction - integer, intent(out) :: ied !< Data end index in i direction - integer, intent(out) :: jsd !< Data start index in j direction - integer, intent(out) :: jed !< Data end index in j direction - integer, intent(out) :: nk !< Number of levels in k direction - integer, intent(out) :: ntau !< Unknown - integer, optional, intent(out) :: axes(3) !< Unknown - type(time_type), optional, intent(out) :: init_time !< Unknown - real, optional, dimension(:,:,:), pointer :: grid_tmask !< Unknown - integer, optional, dimension(:,:), pointer :: grid_mask_coast !< Unknown - integer, optional, dimension(:,:), pointer :: grid_kmt !< Unknown - type(g_diag_ctrl), optional, pointer :: diag_CS !< Unknown - - isc = -1 - iec = -1 - jsc = -1 - jec = -1 - isd = -1 - ied = -1 - jsd = -1 - jed = -1 - nk = -1 - ntau = -1 - end subroutine g_tracer_get_common - - !> Unknown - subroutine g_tracer_get_4D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, dimension(:,:,:,:), pointer :: array_ptr !< Unknown - end subroutine g_tracer_get_4D - - !> Unknown - subroutine g_tracer_get_3D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, dimension(:,:,:), pointer :: array_ptr !< Unknown - end subroutine g_tracer_get_3D - - !> Unknown - subroutine g_tracer_get_2D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, dimension(:,:), pointer :: array_ptr !< Unknown - end subroutine g_tracer_get_2D - - !> Unknown - subroutine g_tracer_get_4D_val(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - real, dimension(isd:,jsd:,:,:), intent(out):: array !< Unknown - - array(:,:,:,:) = -1. - end subroutine g_tracer_get_4D_val - - !> Unknown - subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,positive) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - integer, optional, intent(in) :: ntau !< Unknown - logical, optional, intent(in) :: positive !< Unknown - real, dimension(isd:,jsd:,:), intent(out):: array !< Unknown - character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' - - array(:,:,:) = -1. - end subroutine g_tracer_get_3D_val - - !> Unknown - subroutine g_tracer_get_2D_val(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - real, dimension(isd:,jsd:), intent(out):: array !< Unknown - - array(:,:) = -1. - end subroutine g_tracer_get_2D_val - - !> Unknown - subroutine g_tracer_get_real(g_tracer_list,name,member,value) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, intent(out):: value !< Unknown - - value = -1 - end subroutine g_tracer_get_real - - !> Unknown - subroutine g_tracer_get_string(g_tracer_list,name,member,string) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - character(len=fm_string_len), intent(out) :: string !< Unknown - - string = "" - end subroutine g_tracer_get_string - - !> Unknown - subroutine g_tracer_set_2D(g_tracer_list,name,member,array,isd,jsd,weight) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - real, dimension(isd:,jsd:),intent(in) :: array !< Unknown - real, optional ,intent(in) :: weight !< Unknown - end subroutine g_tracer_set_2D - - !> Unknown - subroutine g_tracer_set_3D(g_tracer_list,name,member,array,isd,jsd,ntau) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - integer, optional, intent(in) :: ntau !< Unknown - real, dimension(isd:,jsd:,:), intent(in) :: array !< Unknown - end subroutine g_tracer_set_3D - - !> Unknown - subroutine g_tracer_set_4D(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - real, dimension(isd:,jsd:,:,:), intent(in) :: array !< Unknown - end subroutine g_tracer_set_4D - - !> Unknown - subroutine g_tracer_set_real(g_tracer_list,name,member,value) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, intent(in) :: value !< Unknown - end subroutine g_tracer_set_real - - subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) - type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list - type(time_type), intent(in) :: model_time !< Time - integer, intent(in) :: tau !< The time step for the %field 4D field to be reported - end subroutine g_tracer_send_diag - - !> Unknown - subroutine g_tracer_get_name(g_tracer,string) - type(g_tracer_type), pointer :: g_tracer !< Unknown - character(len=*), intent(out) :: string !< Unknown - - string = "" - end subroutine g_tracer_get_name - - !> Unknown - subroutine g_tracer_get_alias(g_tracer,string) - type(g_tracer_type), pointer :: g_tracer !< Unknown - character(len=*), intent(out) :: string !< Unknown - - string = "" - end subroutine g_tracer_get_alias - - !> Is the tracer prognostic? - function g_tracer_is_prog(g_tracer) - logical :: g_tracer_is_prog - type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node - - g_tracer_is_prog = .false. - end function g_tracer_is_prog - - !> get the next tracer in the list - subroutine g_tracer_get_next(g_tracer,g_tracer_next) - type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node - type(g_tracer_type), pointer :: g_tracer_next !< Pointer to the next tracer node in the list - end subroutine g_tracer_get_next - - !> get obc segment properties for each tracer - subroutine g_tracer_get_obc_segment_props(g_tracer_list, name, obc_has, src_file, src_var_name,lfac_in,lfac_out) - type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list - character(len=*), intent(in) :: name !< tracer name - logical, intent(out):: obc_has !< .true. if This tracer has OBC - real, optional,intent(out):: lfac_in !< OBC reservoir inverse lengthscale factor - real, optional,intent(out):: lfac_out !< OBC reservoir inverse lengthscale factor - character(len=*),optional,intent(out):: src_file !< OBC source file - character(len=*),optional,intent(out):: src_var_name !< OBC source variable in file - - obc_has = .false. - end subroutine g_tracer_get_obc_segment_props - - !>Vertical Diffusion of a tracer node - !! - !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field - !! for a tracer node.This is ported from GOLD (vertdiff) and simplified - !! Since the surface flux from the atmosphere (%stf) has the units of mol/m^2/sec the resulting - !! tracer concentration has units of mol/Kg - subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau, mom) - type(g_tracer_type), pointer :: g_tracer !< Unknown - !> Layer thickness before entrainment, in m or kg m-2. - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: h_old - !> The amount of fluid entrained from the layer above, in H. - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: ea - !> The amount of fluid entrained from the layer below, in H. - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: eb - real, intent(in) :: dt !< The amount of time covered by this call, in s. - real, intent(in) :: kg_m2_to_H !< A conversion factor that translates kg m-2 into - !! the units of h_old (H) - real, intent(in) :: m_to_H !< A conversion factor that translates m into the units - !! of h_old (H). - integer, intent(in) :: tau !< Unknown - logical, intent(in), optional :: mom !< Unknown - end subroutine g_tracer_vertdiff_G - -end module g_tracer_utils diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 13c05de9c4..fdffef9d60 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -1389,8 +1389,10 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l "TRIPOLAR_N and REENTRANT_Y may not be used together.") endif - MOM_dom%nonblocking_updates = nonblocking - MOM_dom%thin_halo_updates = thin_halos + MOM_dom%nonblocking_updates = .false. + if (present(nonblocking)) MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = .false. + if (present(thin_halos)) MOM_dom%thin_halo_updates = thin_halos MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 258b164e51..91c62f7d08 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -1390,8 +1390,10 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l "TRIPOLAR_N and REENTRANT_Y may not be used together.") endif - MOM_dom%nonblocking_updates = nonblocking - MOM_dom%thin_halo_updates = thin_halos + MOM_dom%nonblocking_updates = .false. + if (present(nonblocking)) MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = .false. + if (present(thin_halos)) MOM_dom%thin_halo_updates = thin_halos MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 252a8e9a60..93c4d35faa 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1038,30 +1038,46 @@ subroutine ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) type(ocean_OBC_type), pointer :: OBC !< Open boundary structure ! Local variables - integer :: i, j, k, nz + integer :: i, j, k, nz, is_OBC, ie_OBC, js_OBC, je_OBC if (.not.associated(OBC)) return nz = GV%ke - ! Take open boundary conditions into account. + ! Take open boundary conditions into account. + if (OBC%u_E_OBCs_on_PE) then + js_OBC = max(G%jsc, OBC%js_u_E_obc) ; je_OBC = min(G%jec, OBC%je_u_E_obc) + Is_OBC = max(G%IscB, OBC%Is_u_E_obc) ; Ie_OBC = min(G%IecB, OBC%Ie_u_E_obc) !$OMP parallel do default(shared) - do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (OBC%segnum_u(I,j) /= 0) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do k=1,nz ; h_u(I,j,k) = h_new(i,j,k) ; enddo - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - do k=1,nz ; h_u(I,j,k) = h_new(i+1,j,k) ; enddo - endif + do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC ; if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E + do k=1,nz ; h_u(I,j,k) = h_new(i,j,k) ; enddo + endif ; enddo ; enddo + endif + if (OBC%u_W_OBCs_on_PE) then + js_OBC = max(G%jsc, OBC%js_u_W_obc) ; je_OBC = min(G%jec, OBC%je_u_W_obc) + Is_OBC = max(G%IscB, OBC%Is_u_W_obc) ; Ie_OBC = min(G%IecB, OBC%Ie_u_W_obc) + !$OMP parallel do default(shared) + do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC ; if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W + do k=1,nz ; h_u(I,j,k) = h_new(i+1,j,k) ; enddo endif ; enddo ; enddo + endif + if (OBC%v_N_OBCs_on_PE) then + Js_OBC = max(G%JscB, OBC%Js_v_N_obc) ; Je_OBC = min(G%JecB, OBC%Je_v_N_obc) + is_OBC = max(G%isc, OBC%is_v_N_obc) ; ie_OBC = min(G%iec, OBC%ie_v_N_obc) !$OMP parallel do default(shared) - do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (OBC%segnum_v(i,J) /= 0) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do k=1,nz ; h_v(i,J,k) = h_new(i,j,k) ; enddo - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - do k=1,nz ; h_v(i,J,k) = h_new(i,j+1,k) ; enddo - endif + do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC ; if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N + do k=1,nz ; h_v(i,J,k) = h_new(i,j,k) ; enddo + endif ; enddo ; enddo + endif + if (OBC%v_S_OBCs_on_PE) then + Js_OBC = max(G%JscB, OBC%Js_v_S_obc) ; Je_OBC = min(G%JecB, OBC%Je_v_S_obc) + is_OBC = max(G%isc, OBC%is_v_S_obc) ; ie_OBC = min(G%iec, OBC%ie_v_S_obc) + !$OMP parallel do default(shared) + do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC ; if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S + do k=1,nz ; h_v(i,J,k) = h_new(i,j+1,k) ; enddo endif ; enddo ; enddo + endif end subroutine ALE_remap_set_h_vel_OBC diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 156a397ff6..6e5a4b43d4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -103,6 +103,7 @@ module MOM use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end use MOM_interface_filter, only : interface_filter_CS use MOM_internal_tides, only : int_tide_CS +use MOM_kappa_shear, only : kappa_shear_at_vertex use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS use MOM_MEKE, only : MEKE_alloc_register_restart, step_forward_MEKE @@ -111,11 +112,13 @@ module MOM use MOM_mixed_layer_restrat, only : mixedlayer_restrat, mixedlayer_restrat_init, mixedlayer_restrat_CS use MOM_mixed_layer_restrat, only : mixedlayer_restrat_register_restarts use MOM_obsolete_diagnostics, only : register_obsolete_diagnostics -use MOM_open_boundary, only : ocean_OBC_type, OBC_registry_type +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_end use MOM_open_boundary, only : register_temp_salt_segments, update_segment_tracer_reservoirs +use MOM_open_boundary, only : setup_OBC_tracer_reservoirs use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields -use MOM_open_boundary, only : open_boundary_setup_vert -use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init +use MOM_open_boundary, only : initialize_segment_data, rotate_OBC_config +use MOM_open_boundary, only : update_OBC_segment_data, open_boundary_halo_update +use MOM_open_boundary, only : write_OBC_info, chksum_OBC_segments use MOM_porous_barriers, only : porous_widths_layer, porous_widths_interface, porous_barriers_init use MOM_porous_barriers, only : porous_barrier_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS @@ -123,7 +126,7 @@ module MOM use MOM_set_visc, only : set_visc_init, set_visc_end use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_sponge, only : init_sponge_diags, sponge_CS -use MOM_state_initialization, only : MOM_initialize_state +use MOM_state_initialization, only : MOM_initialize_state, MOM_initialize_OBCs use MOM_stoch_eos, only : MOM_stoch_eos_init, MOM_stoch_eos_run, MOM_stoch_eos_CS use MOM_stoch_eos, only : stoch_EOS_register_restarts, post_stoch_EOS_diags, mom_calc_varT use MOM_sum_output, only : write_energy, accumulate_net_input @@ -227,6 +230,7 @@ module MOM logical :: rotate_index = .false. !< True if index map is rotated logical :: homogenize_forcings = .false. !< True if all inputs are homogenized logical :: update_ustar = .false. !< True to update ustar from homogenized tau + logical :: vertex_shear = .false. !< True if vertex shear is on type(verticalGrid_type), pointer :: & GV => NULL() !< structure containing vertical grid info @@ -286,6 +290,7 @@ module MOM logical :: count_calls = .false. !< If true, count the calls to step_MOM, rather than the !! number of dynamics steps in nstep_tot logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_OBCs !< If true, write verbose OBC values for debugging purposes. integer :: ntrunc !< number u,v truncations since last call to write_energy integer :: cont_stencil !< The stencil for thickness from the continuity solver. @@ -670,6 +675,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (do_dyn) then n_max = 1 if (time_interval > CS%dt) n_max = ceiling(time_interval/CS%dt - 0.001) + ntstep = 1 ! initialization dt = time_interval / real(n_max) thermo_does_span_coupling = (CS%thermo_spans_coupling .and. & (CS%dt_therm > 1.5*cycle_time)) @@ -764,7 +770,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (therm_reset) then CS%time_in_thermo_cycle = 0.0 - if (associated(CS%tv%frazil)) CS%tv%frazil(:,:) = 0.0 + if (associated(CS%tv%frazil)) then + CS%tv%frazil(:,:) = 0.0 + CS%tv%frazil_was_reset = .true. + endif if (associated(CS%tv%salt_deficit)) CS%tv%salt_deficit(:,:) = 0.0 if (associated(CS%tv%TempxPmE)) CS%tv%TempxPmE(:,:) = 0.0 if (associated(CS%tv%internal_heat)) CS%tv%internal_heat(:,:) = 0.0 @@ -776,7 +785,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%VarMix%use_variable_mixing) then call enable_averages(cycle_time, Time_start + real_to_time(US%T_to_s*cycle_time), CS%diag) - call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt) + call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, CS%OBC, dt) call calc_depth_function(G, CS%VarMix) call disable_averaging(CS%diag) endif @@ -958,10 +967,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !=========================================================================== ! This is the start of the tracer advection part of the algorithm. - 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. + do_advection = ((CS%t_dyn_rel_adv + 0.5*dt > dt_tr_adv) .or. & + (CS%t_dyn_rel_thermo + 0.5*dt > dt_therm)) else do_advection = ((MOD(n,ntastep) == 0) .or. (n==n_max)) endif @@ -976,15 +984,12 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !=========================================================================== ! This is the second place where the diabatic processes and remapping could occur. - if (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 + if (thermo_does_span_coupling .or. .not.do_dyn) then + do_diabatic = (do_thermo .and. (CS%t_dyn_rel_thermo + 0.5*dt > dt_therm)) + else + do_diabatic = (do_thermo .and. ((MOD(n,ntstep) == 0) .or. (n==n_max))) endif - if ((CS%t_dyn_rel_adv==0.0) .and. do_thermo .and. (.not.CS%diabatic_first) .and. do_diabatic) then + if ((CS%t_dyn_rel_adv==0.0) .and. (.not.CS%diabatic_first) .and. do_diabatic) then dtdia = CS%t_dyn_rel_thermo ! If the MOM6 dynamic and thermodynamic time stepping is being orchestrated @@ -1283,6 +1288,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & endif endif endif + ! if (CS%debug_OBCs .and. associated(CS%OBC)) call chksum_OBC_segments(CS%OBC, G, GV, US, 3) if (CS%do_dynamics .and. CS%split) then !--------------------------- start SPLIT ! This section uses a split time stepping scheme for the dynamic equations, @@ -1960,6 +1966,9 @@ subroutine post_diabatic_halo_updates(CS, G, GV, US, u, v, h, tv) call create_group_pass(pass_uv_T_S_h, h, G%Domain, halo=dynamics_stencil) call do_group_pass(pass_uv_T_S_h, G%Domain, clock=id_clock_pass) + if (associated(tv%frazil) .and. (.not.tv%frazil_was_reset) .and. CS%vertex_shear) & + call pass_var(tv%frazil, G%Domain, halo=1) + ! Update derived thermodynamic quantities. if (allocated(tv%SpV_avg)) then call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) @@ -2065,7 +2074,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (.not. skip_diffusion) then if (CS%VarMix%use_variable_mixing) then call pass_var(CS%h, G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt_offline) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, CS%OBC, dt_offline) call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif @@ -2092,7 +2101,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (.not. skip_diffusion) then if (CS%VarMix%use_variable_mixing) then call pass_var(CS%h, G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt_offline) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, CS%OBC, dt_offline) call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif @@ -2314,12 +2323,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the ! calculation. + logical :: enable_bugs ! If true, the defaults for certain recently added bug-fix flags are + ! set to recreate the bugs so that the code can be moved forward + ! without changing answers for existing configurations. When this is + ! false, bugs are only used if they are actively selected. logical :: non_Bous ! If true, this run is fully non-Boussinesq logical :: Boussinesq ! If true, this run is fully Boussinesq logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq logical :: use_KPP ! If true, diabatic is using KPP vertical mixing logical :: MLE_use_PBL_MLD ! If true, use stored boundary layer depths for submesoscale restratification. - integer :: nkml, nkbl, verbosity, write_geom + logical :: OBC_reservoir_init_bug + integer :: nkml, nkbl, verbosity, write_geom, number_of_OBC_segments integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. real :: salin_underflow ! A tiny value of salinity below which the it is set to 0 [S ~> ppt] @@ -2500,6 +2514,20 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "DEBUG_TRUNCATIONS", debug_truncations, & "If true, calculate all diagnostics that are useful for "//& "debugging truncations.", default=.false., debuggingParam=.true.) + call get_param(param_file, "MOM", "OBC_NUMBER_OF_SEGMENTS", number_of_OBC_segments, & + default=0, do_not_log=.true.) + call get_param(param_file, "MOM", "DEBUG_OBCS", CS%debug_OBCs, & + "If true, write out verbose debugging data about OBCs.", & + default=.false., debuggingParam=.true., do_not_log=(number_of_OBC_segments<=0)) + call get_param(param_file, "MOM", "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + "If true, the defaults for certain recently added bug-fix flags are set to "//& + "recreate the bugs so that the code can be moved forward without changing "//& + "answers for existing configurations. The defaults for groups of bug-fix "//& + "flags are periodcially changed to correct the bugs, at which point this "//& + "parameter will no longer be used to set their default. Setting this to false "//& + "means that bugs are only used if they are actively selected, but it also "//& + "means that answers may change when code is updated due to newly found bugs.", & + default=.true.) call get_param(param_file, "MOM", "DT", CS%dt, & "The (baroclinic) dynamics time step. The time-step that "//& @@ -2845,7 +2873,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) ! Allocate initialize time-invariant MOM variables. - call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, .false., dirs%output_directory) + call MOM_initialize_fixed(dG_in, US, OBC_in, param_file) ! Copy the grid metrics and bathymetry to the ocean_grid_type call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) @@ -2864,8 +2892,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z - ! Finish OBC configuration that depend on the vertical grid - call open_boundary_setup_vert(GV, US, OBC_in) + if (associated(OBC_in)) then + ! This call allocates the arrays on the segments for open boundary data and initializes the + ! relevant vertical remapping structures. It can only occur after the vertical grid has been + ! initialized. + call initialize_segment_data(G_in, GV, US, OBC_in, param_file) + endif ! Shift from using the temporary dynamic grid type to using the final (potentially static) ! and properly rotated ocean-specific grid type and horizontal index type. @@ -2882,9 +2914,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call copy_dyngrid_to_MOM_grid(dG, G, US) if (associated(OBC_in)) then - ! TODO: General OBC index rotations is not yet supported. - if (modulo(turns, 4) /= 1) & - call MOM_error(FATAL, "OBC index rotation of 180 and 270 degrees is not yet supported.") allocate(CS%OBC) call rotate_OBC_config(OBC_in, dG_in, CS%OBC, dG, turns) endif @@ -2965,7 +2994,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (use_p_surf_in_EOS) allocate(CS%tv%p_surf(isd:ied,jsd:jed), source=0.0) - if (use_frazil) allocate(CS%tv%frazil(isd:ied,jsd:jed), source=0.0) + if (use_frazil) then + allocate(CS%tv%frazil(isd:ied,jsd:jed), source=0.0) + CS%tv%frazil_was_reset = .true. + endif if (bound_salinity) allocate(CS%tv%salt_deficit(isd:ied,jsd:jed), source=0.0) allocate(CS%Hml(isd:ied,jsd:jed), source=0.0) @@ -3024,7 +3056,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! initialization routine for tv. if (use_EOS) then allocate(CS%tv%eqn_of_state) - call EOS_init(param_file, CS%tv%eqn_of_state, US) + call EOS_init(param_file, CS%tv%eqn_of_state, US, use_conT_absS) endif if (use_temperature) then allocate(CS%tv%TempxPmE(isd:ied,jsd:jed), source=0.0) @@ -3064,24 +3096,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call mixedlayer_restrat_register_restarts(HI, GV, US, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) - if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then - ! NOTE: register_temp_salt_segments includes allocation of tracer fields - ! along segments. Bit reproducibility requires that MOM_initialize_state - ! be called on the input index map, so we must setup both OBC and OBC_in. - ! - ! XXX: This call on OBC_in allocates the tracer fields on the unrotated - ! grid, but also incorrectly stores a pointer to a tracer_type for the - ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg. - ! - ! While incorrect and potentially dangerous, it does not seem that this - ! pointer is used during initialization, so we leave it for now. - call register_temp_salt_segments(GV, US, OBC_in, CS%tracer_Reg, param_file) - endif - if (associated(CS%OBC)) then ! Set up remaining information about open boundary conditions that is needed for OBCs. + ! Package specific changes to OBCs occur here. call call_OBC_register(G, GV, US, param_file, CS%update_OBC_CSp, CS%OBC, CS%tracer_Reg) - !### Package specific changes to OBCs need to go here? ! This is the equivalent to 2 calls to register_segment_tracer (per segment), which ! could occur with the call to update_OBC_data or after the main initialization. @@ -3094,8 +3112,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! reservoirs are used. call open_boundary_register_restarts(HI, GV, US, CS%OBC, CS%tracer_Reg, & param_file, restart_CSp, use_temperature) + + if (CS%debug_OBCs) call write_OBC_info(CS%OBC, G, GV, US) endif + if (present(waves_CSp)) then call waves_register_restarts(waves_CSp, HI, GV, US, param_file, restart_CSp) endif @@ -3120,7 +3141,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & local_indexing=.not.global_indexing) call create_dyn_horgrid(dG_unmasked_in, HI_in_unmasked, bathymetry_at_vel=bathy_at_vel) call clone_MOM_domain(MOM_dom_unmasked, dG_unmasked_in%Domain) - call MOM_initialize_fixed(dG_unmasked_in, US, OBC_in, param_file, .false., dirs%output_directory) + call MOM_initialize_fixed(dG_unmasked_in, US, OBC_in, param_file) call write_ocean_geometry_file(dG_unmasked_in, param_file, dirs%output_directory, US=US, geom_file=geom_file) call deallocate_MOM_domain(MOM_dom_unmasked) call destroy_dyn_horgrid(dG_unmasked_in) @@ -3176,6 +3197,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%tv%T => T_in CS%tv%S => S_in + + if (associated(OBC_in)) then + ! Log this parameter in MOM_initialize_state + call get_param(param_file, "MOM", "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, & + "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& + "interior tracer concentrations regardless of properties that may be explicitly "//& + "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.) + if (OBC_reservoir_init_bug .and. (allocated(CS%OBC%tres_x) .or. allocated(CS%OBC%tres_y))) & + call MOM_error(FATAL, "OBC_RESERVOIR_INIT_BUG can not be set to true with grid rotation.") + endif endif if (use_ice_shelf) then @@ -3228,9 +3259,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call update_ALE_sponge_field(CS%ALE_sponge_CSp, S_in, G, GV, CS%S) endif - if (associated(OBC_in)) & - call rotate_OBC_init(OBC_in, G, GV, US, param_file, CS%tv, restart_CSp, CS%OBC) - + ! Deallocate the unrotated arrays and types that are no longer needed. deallocate(u_in) deallocate(v_in) deallocate(h_in) @@ -3238,9 +3267,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & deallocate(T_in) deallocate(S_in) endif - if (use_ice_shelf) & - deallocate(frac_shelf_in,mass_shelf_in) - else + if (use_ice_shelf) deallocate(frac_shelf_in, mass_shelf_in) + if (associated(OBC_in)) call open_boundary_end(OBC_in) + + else ! The model is being run without grid rotation. This is true of all production runs. if (use_ice_shelf) then call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, & dirs%output_directory, calve_ice_shelf_bergs=point_calving) @@ -3271,6 +3301,19 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%tv%valid_SpV_halo = -1 ! This array does not yet have any valid data. endif + if (associated(CS%OBC)) then + call MOM_initialize_OBCs(CS%h, CS%tv, CS%OBC, Time, G, GV, US, param_file, restart_CSp, CS%tracer_Reg) + + if (use_temperature) then + call pass_var(CS%tv%T, G%Domain, complete=.false.) + call pass_var(CS%tv%S, G%Domain, complete=.true.) + endif + call calc_derived_thermo(CS%tv, CS%h, G, GV, US) + + ! Call this during initialization to fill boundary arrays from fixed values + call update_OBC_segment_data(G, GV, US, CS%OBC, CS%tv, CS%h, Time) + endif + if (use_ice_shelf .and. CS%debug) then call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0) call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) @@ -3309,8 +3352,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (ALE_remap_init_conds(CS%ALE_CSp) .and. .not. query_initialized(CS%h,"h",restart_CSp)) then ! This block is controlled by the ALE parameter REMAP_AFTER_INITIALIZATION. - ! \todo This block exists for legacy reasons and we should phase it out of - ! all examples. !### + ! \todo This block exists for legacy reasons and we should phase it out of all examples. !### if (CS%debug) then call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, unscale=GV%H_to_MKS) @@ -3503,14 +3545,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif endif elseif (CS%use_RK2) then - call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, Time, G, GV, US, & - param_file, diag, CS%dyn_unsplit_RK2_CSp, & + call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, & + US, param_file, diag, CS%dyn_unsplit_RK2_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, & CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & CS%ntrunc, cont_stencil=CS%cont_stencil) else - call initialize_dyn_unsplit(CS%u, CS%v, CS%h, Time, G, GV, US, & - param_file, diag, CS%dyn_unsplit_CSp, & + call initialize_dyn_unsplit(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, & + US, param_file, diag, CS%dyn_unsplit_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, & CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & CS%ntrunc, cont_stencil=CS%cont_stencil) @@ -3561,6 +3603,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%int_tide_CSp) endif + CS%vertex_shear = kappa_shear_at_vertex(param_file) + ! GMM, the following is needed to get BLDs into the dynamics module if (CS%split .and. fpmix) then call init_dyn_split_RK2_diabatic(CS%diabatic_CSp, CS%dyn_split_RK2_CSp) @@ -3623,6 +3667,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp, GV, US) endif + if (associated(CS%OBC)) then + ! At this point any information related to the tracer reservoirs has either been read from + ! the restart file or has been specified in the segments. Initialize the tracer reservoir + ! values from the segments if they have not been set via the restart file. + call setup_OBC_tracer_reservoirs(G, GV, CS%OBC, restart_CSp) + call open_boundary_halo_update(G, CS%OBC) + endif + call register_obsolete_diagnostics(param_file, CS%diag) if (use_frazil) then @@ -4491,6 +4543,7 @@ subroutine MOM_end(CS) DEALLOC_(CS%uh) ; DEALLOC_(CS%vh) if (associated(CS%update_OBC_CSp)) call OBC_register_end(CS%update_OBC_CSp) + if (associated(CS%OBC)) call open_boundary_end(CS%OBC) call verticalGridEnd(CS%GV) call MOM_grid_end(CS%G) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index aaabab3500..fffe35104b 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -2039,6 +2039,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL 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 + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -2065,11 +2067,13 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL "gradient forces. Its inverse is subtracted off of specific volumes when "//& "in non-Boussinesq mode. The default is RHO_0.", & units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "RHO_PGF_REF_BUG", CS%rho_ref_bug, & "If true, recover a bug that RHO_0 (the mean seawater density in Boussinesq mode) "//& "and RHO_PGF_REF (the subtracted reference density in finite volume pressure "//& "gradient forces) are incorrectly interchanged in several instances in Boussinesq mode.", & - default=.true.) + default=enable_bugs) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, '', "DEFAULT_ANSWER_DATE", default_answer_date, default=99991231) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index f8bc982d18..88baff2c9b 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4,6 +4,7 @@ module MOM_barotropic ! This file is part of MOM6. See LICENSE.md for the license. use MOM_checksums, only : chksum0 +use MOM_coms, only : any_across_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field @@ -137,7 +138,7 @@ module MOM_barotropic !< The difference between the free surface height from the barotropic calculation and the sum !! of the layer thicknesses. This difference is imposed as a forcing term in the barotropic !! calculation over a baroclinic timestep [H ~> m or kg m-2]. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_cor_bound + real, allocatable, dimension(:,:) :: eta_cor_bound !< A limit on the rate at which eta_cor can be applied while avoiding instability !! [H T-1 ~> m s-1 or kg m-2 s-1]. This is only used if CS%bound_BT_corr is true. real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: & @@ -265,12 +266,18 @@ module MOM_barotropic !! velocities. The streaming band-pass filter must be turned on. logical :: use_wide_halos !< If true, use wide halos and march in during the !! barotropic time stepping for efficiency. + integer :: min_stencil !< The minimum stencil width to use with the wide halo iterations. + !! A nonzero value may reflect the distribution of OBC faces or it + !! may be useful for debugging purposes. logical :: clip_velocity !< If true, limit any velocity components that are !! are large enough for a CFL number to exceed !! CFL_trunc. This should only be used as a !! desperate debugging measure. logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: debug_bt !< If true, write verbose checksums for debugging purposes. + logical :: debug_bt !< If true, write verbose checksums from within the barotropic + !! time-stepping loop for debugging purposes. + logical :: debug_wide_halos !< If true, write the checksums on the full wide halos. Otherwise + !! only the output for the final computational domain is written. real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0 [L T-1 ~> m s-1]. real :: maxvel !< Velocity components greater than maxvel are @@ -351,6 +358,7 @@ module MOM_barotropic integer :: id_BTC_vbt_NN = -1, id_BTC_vbt_SS = -1 integer :: id_BTC_FA_u_rat0 = -1, id_BTC_FA_v_rat0 = -1, id_BTC_FA_h_rat0 = -1 integer :: id_uhbt0 = -1, id_vhbt0 = -1 + integer :: id_SSH_u_OBC = -1, id_SSH_v_OBC = -1, id_ubt_OBC = -1, id_vbt_OBC = -1 !>@} end type barotropic_CS @@ -755,9 +763,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, interp_eta_PF = associated(eta_PF_start) ! Figure out the fullest arrays that could be updated. - stencil = 1 + stencil = max(1, CS%min_stencil) if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. & - (CS%Nonlin_cont_update_period > 0)) stencil = 2 + (CS%Nonlin_cont_update_period > 0)) stencil = max(2, CS%min_stencil) find_etaav = present(etaav) @@ -1680,6 +1688,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, unscale=GV%m_to_H, scalar_pair=.true.) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, & haloshift=1, scalar_pair=.true.) + + if (apply_OBCs) then + call uvchksum("BT_OBC%[uv]bt_outer", CS%BT_OBC%ubt_outer, CS%BT_OBC%vbt_outer, CS%debug_BT_HI, & + symmetric=.true., omit_corners=.true., unscale=US%L_T_to_m_s) + if (allocated(CS%BT_OBC%SSH_outer_u) .and. allocated(CS%BT_OBC%SSH_outer_v)) & + call uvchksum("BT_OBC%SSH_outer[uv]", CS%BT_OBC%SSH_outer_u, CS%BT_OBC%SSH_outer_v, CS%debug_BT_HI, & + symmetric=.true., omit_corners=.true., unscale=US%Z_to_m, scalar_pair=.true.) + if (allocated(CS%BT_OBC%Cg_u) .and. allocated(CS%BT_OBC%Cg_v)) & + call uvchksum("BT_OBC%Cg_[uv]", CS%BT_OBC%Cg_u, CS%BT_OBC%Cg_v, CS%debug_BT_HI, & + symmetric=.true., omit_corners=.true., unscale=US%L_T_to_m_s, scalar_pair=.true.) + if (allocated(CS%BT_OBC%dZ_u) .and. allocated(CS%BT_OBC%dZ_v)) & + call uvchksum("BT_OBC%dZ_[uv]", CS%BT_OBC%dZ_u, CS%BT_OBC%dZ_v, CS%debug_BT_HI, & + symmetric=.true., omit_corners=.true., unscale=US%Z_to_m, scalar_pair=.true.) + endif endif if (CS%id_ubtdt > 0) then @@ -2098,6 +2120,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) endif endif + + if (CS%id_SSH_u_OBC > 0) call post_data(CS%id_SSH_u_OBC, CS%BT_OBC%SSH_outer_u(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_SSH_v_OBC > 0) call post_data(CS%id_SSH_v_OBC, CS%BT_OBC%SSH_outer_v(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_ubt_OBC > 0) call post_data(CS%id_ubt_OBC, CS%BT_OBC%ubt_outer(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbt_OBC > 0) call post_data(CS%id_vbt_OBC, CS%BT_OBC%vbt_outer(isd:ied,JsdB:JedB), CS%diag) else if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) @@ -2375,6 +2402,7 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL integer :: stencil ! The stencil size of the algorithm, often 1 or 2. integer :: err_count ! A counter to limit the volume of error messages written to stdout. integer :: i, j, n, is, ie, js, je + integer :: debug_halo ! The halo size to use for debugging checksums integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -2383,9 +2411,10 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL err_count = 0 ! Figure out the fullest arrays that could be updated. - stencil = 1 + stencil = max(1, CS%min_stencil) if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. (CS%Nonlin_cont_update_period > 0)) & - stencil = 2 + stencil = max(2, CS%min_stencil) + num_cycles = 1 if (CS%use_wide_halos) & num_cycles = min((is-CS%isdw) / stencil, (js-CS%jsdw) / stencil) @@ -2488,6 +2517,14 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL jsv = jsv+stencil ; jev = jev-stencil endif + ! Store the previous velocities for time-filtered transports and OBCs. + do j=jsv,jev ; do I=isv-2,iev+1 + ubt_prev(I,j) = ubt(I,j) + enddo ; enddo + do J=jsv-2,jev+1 ; do i=isv,iev + vbt_prev(i,J) = vbt(i,J) + enddo ; enddo + if (integral_BT_cont) then !$OMP parallel do default(shared) do j=jsv-1,jev+1 ; do I=isv-2,iev+1 @@ -2543,22 +2580,22 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL 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, & + f_4_v, bt_rem_v, BT_force_v, Cor_ref_v, Rayleigh_v, & wt_accel(n), G, US, CS) ! 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, & + f_4_u, bt_rem_u, BT_force_u, Cor_ref_u, Rayleigh_u, & wt_accel(n), G, US, CS) 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, & + f_4_u, bt_rem_u, BT_force_u, Cor_ref_u, Rayleigh_u, & wt_accel(n), G, US, CS) ! Now update the meridional velocity. call btloop_update_v(dtbt, ubt, vbt, v_accel_bt, Cor_v, PFv, isv, iev, jsv-1, jev, & - f_4_v, bt_rem_v, BT_force_v, vbt_prev, Cor_ref_v, Rayleigh_v, & + f_4_v, bt_rem_v, BT_force_v, Cor_ref_v, Rayleigh_v, & wt_accel(n), G, US, CS, Cor_bracket_bug=CS%use_old_coriolis_bracket_bug) endif @@ -2612,23 +2649,24 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL ! 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) + debug_halo = 0 ; if (CS%debug_wide_halos) debug_halo = iev - ie + call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., scalar_pair=.true.) + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) if (integral_BT_cont) & - call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & - unscale=US%L_to_m**2*GV%H_to_m) + call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_to_m**2*GV%H_to_m) endif ! Apply open boundary condition considerations to revise the updated velocities and transports. @@ -2665,11 +2703,11 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL !$OMP end do nowait 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) + call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) if (integral_BT_cont) & call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & - haloshift=iev-ie, unscale=US%L_to_m**2*GV%H_to_m) + haloshift=debug_halo, symmetric=.true., unscale=US%L_to_m**2*GV%H_to_m) endif ! Update eta in a corrector step using the barotropic continuity equation. @@ -2691,9 +2729,9 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL 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) + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s) + call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=debug_halo, unscale=GV%H_to_MKS) endif ! Issue warnings if there are unphysical values of the sea surface height or total water column mass. @@ -3170,7 +3208,7 @@ 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, & + bt_rem_v, BT_force_v, Cor_ref_v, Rayleigh_v, & wt_accel_n, G, US, CS, Cor_bracket_bug) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure @@ -3196,8 +3234,6 @@ subroutine btloop_update_v(dtbt, ubt, vbt, v_accel_bt, & 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 @@ -3245,7 +3281,6 @@ subroutine btloop_update_v(dtbt, ubt, vbt, v_accel_bt, & !$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 @@ -3270,7 +3305,7 @@ 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, & + bt_rem_u, BT_force_u, Cor_ref_u, Rayleigh_u, & wt_accel_n, G, US, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure @@ -3304,8 +3339,6 @@ subroutine btloop_update_u(dtbt, ubt, vbt, u_accel_bt, & 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]. @@ -3327,7 +3360,6 @@ subroutine btloop_update_u(dtbt, ubt, vbt, u_accel_bt, & ((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 @@ -4000,8 +4032,10 @@ subroutine initialize_BT_OBC(OBC, BT_OBC, G, CS) 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 :: OBC_type ! The integer encoding the type of OBC being used at a point [nondim] + logical :: reversed_OBCs ! True of there any OBCs in the opposite halo on this PE, e.g. points + ! with a southern OBC in a northern halo. + logical :: any_reversed_OBCs integer :: i, j, isdw, iedw, jsdw, jedw integer :: l_seg, Flather_OBC_in_halo @@ -4011,30 +4045,26 @@ subroutine initialize_BT_OBC(OBC, BT_OBC, G, CS) 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 + OBC_type = 0 + if (OBC%segnum_u(I,j) /= 0) then + l_seg = abs(OBC%segnum_u(I,j)) if (OBC%segment(l_seg)%gradient) OBC_type = GRADIENT_OBC if (OBC%segment(l_seg)%Flather) OBC_type = FLATHER_OBC if (OBC%segment(l_seg)%specified) OBC_type = SPECIFIED_OBC + u_OBC(I,j) = sign(OBC_type, OBC%segnum_u(I,j)) endif - 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 + OBC_type = 0 + if (OBC%segnum_v(i,J) /= 0) then + l_seg = abs(OBC%segnum_v(i,J)) if (OBC%segment(l_seg)%gradient) OBC_type = GRADIENT_OBC if (OBC%segment(l_seg)%Flather) OBC_type = FLATHER_OBC if (OBC%segment(l_seg)%specified) OBC_type = SPECIFIED_OBC + v_OBC(i,J) = sign(OBC_type, OBC%segnum_v(i,J)) endif - v_OBC(i,J) = OBC_sign * OBC_type enddo ; enddo call pass_vector(u_OBC, v_OBC, CS%BT_Domain) @@ -4101,6 +4131,15 @@ subroutine initialize_BT_OBC(OBC, BT_OBC, G, CS) BT_OBC%u_OBCs_on_PE = ((BT_OBC%Is_u_E_obc <= iedw) .or. (BT_OBC%Is_u_W_obc <= iedw)) BT_OBC%v_OBCs_on_PE = ((BT_OBC%is_v_N_obc <= iedw) .or. (BT_OBC%is_v_S_obc <= iedw)) + + ! Determine whether there are any OBCs in the opposite halo on any processors in the domain, e.g., + ! points with OBC_DIRECTION_S in a northern halo. + reversed_OBCs = (BT_OBC%u_OBCs_on_PE .and. ((BT_OBC%Is_u_E_obc <= G%isc-1) .or. (BT_OBC%Ie_u_W_obc >= G%iec))) .or. & + (BT_OBC%v_OBCs_on_PE .and. ((BT_OBC%Js_v_N_obc <= G%jsc-1) .or. (BT_OBC%Je_v_S_obc >= G%jec))) + any_reversed_OBCs = any_across_PEs(reversed_OBCs) + if (any_reversed_OBCs) call MOM_mesg("OBCs in an opposite halo require the use of a wider stencil.", 5) + if (any_reversed_OBCs) CS%min_stencil = max(CS%min_stencil, 2) + ! Allocate time-varying arrays that will be used for open boundary conditions. ! This pair is used with either Flather or specified OBCs. @@ -5325,7 +5364,12 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: use_BT_cont_type + logical :: mask_coastal_pressure_force ! If true, apply masks to some stored inverse grid spacings + ! so that diagnosed barotropic pressure gradient forces are zero at + ! land, coastal or OBC points. logical :: use_tides + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str @@ -5406,6 +5450,11 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & call get_param(param_file, mdl, "BTHALO", bt_halo_sz, & "The minimum halo size for the barotropic solver.", default=0, & layoutParam=.true.) + call get_param(param_file, mdl, "BT_WIDE_HALO_MIN_STENCIL", CS%min_stencil, & + "The minimum stencil width to use with the wide halo iterations. "//& + "A nonzero value may be useful for debugging purposes, but at the "//& + "cost of reducing the efficiency gain from BT_USE_WIDE_HALOS.", & + default=0, layoutParam=.true., do_not_log=.not.CS%use_wide_halos) #ifdef STATIC_MEMORY_ if ((bt_halo_sz > 0) .and. (bt_halo_sz /= BTHALO_)) call MOM_error(FATAL, & "barotropic_init: Run-time values of BTHALO must agree with the "//& @@ -5475,7 +5524,9 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) - call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=enable_bugs, do_not_log=.true.) call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_BUG", CS%wt_uv_bug, & "If true, recover a bug in barotropic solver that uses an unnormalized weight "//& "function for vertical averages of baroclinic velocity and forcing. Default "//& @@ -5483,7 +5534,7 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & 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.) + default=enable_bugs, 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 @@ -5622,6 +5673,12 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & "barotropic time-stepping loop. The data volume can be "//& "quite large if this is true.", default=CS%debug, & debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_BT_WIDE_HALOS", CS%debug_wide_halos, & + "If true, write the checksums on the full wide halos. Otherwise only the "//& + "output for the final computational domain is written. This can be valuable "//& + "for debugging certain cases where the stencil used in the wide halo "//& + "iterations depends on which opoen boundary conditions are in the halos.", & + default=.true., do_not_log=.not.(CS%debug_bt.and.CS%use_wide_halos), debuggingParam=.true.) call get_param(param_file, mdl, "LINEARIZED_BT_CORIOLIS", CS%linearized_BT_PV, & "If true use the bottom depth instead of the total water column thickness "//& @@ -5645,11 +5702,16 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & "The value of DTBT that will actually be used is an "//& "integer fraction of DT, rounding down.", & units="s or nondim", default=-0.98) - call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", & - CS%use_old_coriolis_bracket_bug , & + call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", CS%use_old_coriolis_bracket_bug, & "If True, use an order of operations that is not bitwise "//& "rotationally symmetric in the meridional Coriolis term of "//& "the barotropic solver.", default=.false.) + call get_param(param_file, mdl, "MASK_COASTAL_PRESSURE_FORCE", mask_coastal_pressure_force, & + "If true, use the land masks to zero out the diagnosed barotropic pressure "//& + "gradient accelerations at coastal or land points. This changes diagnostics "//& + "and improves the reproducibility of certain debugging checksums, but it "//& + "does not alter the solutions themselves.", default=.false.) + !### Change the default for MASK_COASTAL_PRESSURE_FORCE to true? ! Initialize a version of the MOM domain that is specific to the barotropic solver. call clone_MOM_domain(G%Domain, CS%BT_Domain, min_halo=wd_halos, symmetric=.true.) @@ -5679,9 +5741,8 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & ALLOC_(CS%frhatu(IsdB:IedB,jsd:jed,nz)) ; ALLOC_(CS%frhatv(isd:ied,JsdB:JedB,nz)) ALLOC_(CS%eta_cor(isd:ied,jsd:jed)) - if (CS%bound_BT_corr) then - ALLOC_(CS%eta_cor_bound(isd:ied,jsd:jed)) ; CS%eta_cor_bound(:,:) = 0.0 - endif + if (CS%bound_BT_corr) & + allocate(CS%eta_cor_bound(isd:ied,jsd:jed), source=0.0) ALLOC_(CS%IDatu(IsdB:IedB,jsd:jed)) ; ALLOC_(CS%IDatv(isd:ied,JsdB:JedB)) ALLOC_(CS%ua_polarity(isdw:iedw,jsdw:jedw)) @@ -5744,6 +5805,16 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) enddo ; enddo + ! This sets pressure force diagnostics on land, at coastlines and at OBC points to zero. + if (mask_coastal_pressure_force) then + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + CS%IdxCu(I,j) = G%OBCmaskCu(I,j) * G%IdxCu(I,j) + enddo ; enddo + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + CS%IdyCv(i,J) = G%OBCmaskCv(i,J) * G%IdyCv(i,J) + enddo ; enddo + endif + if (associated(OBC)) then ! Set up information about the location and nature of the open boundary condition points. call initialize_BT_OBC(OBC, CS%BT_OBC, G, CS) @@ -6035,6 +6106,18 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & 'Barotropic zonal transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) CS%id_vhbt0 = register_diag_field('ocean_model', 'vhbt0', diag%axesCv1, Time, & 'Barotropic meridional transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + if (associated(OBC)) then + if (OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally) then + CS%id_SSH_u_OBC = register_diag_field('ocean_model', 'SSH_u_OBC', diag%axesCu1, Time, & + 'Outer sea surface height at u OBC points', 'm', conversion=US%Z_to_m) + CS%id_SSH_v_OBC = register_diag_field('ocean_model', 'SSH_v_OBC', diag%axesCv1, Time, & + 'Outer sea surface height at v OBC points', 'm', conversion=US%Z_to_m) + CS%id_ubt_OBC = register_diag_field('ocean_model', 'ubt_OBC', diag%axesCu1, Time, & + 'Outer u velocity at OBC points', 'm', conversion=US%L_T_to_m_s) + CS%id_vbt_OBC = register_diag_field('ocean_model', 'vbt_OBC', diag%axesCv1, Time, & + 'Outer v velocity at OBC points', 'm', conversion=US%L_T_to_m_s) + endif + endif if (CS%id_frhatu1 > 0) allocate(CS%frhatu1(IsdB:IedB,jsd:jed,nz), source=0.) if (CS%id_frhatv1 > 0) allocate(CS%frhatv1(isd:ied,JsdB:JedB,nz), source=0.) @@ -6138,9 +6221,7 @@ subroutine barotropic_end(CS) ! Allocated in barotropic_init, called in timestep initialization DEALLOC_(CS%ua_polarity) ; DEALLOC_(CS%va_polarity) DEALLOC_(CS%IDatu) ; DEALLOC_(CS%IDatv) - if (CS%bound_BT_corr) then - DEALLOC_(CS%eta_cor_bound) - endif + if (allocated(CS%eta_cor_bound)) deallocate(CS%eta_cor_bound) DEALLOC_(CS%eta_cor) DEALLOC_(CS%bathyT) ; DEALLOC_(CS%IareaT) DEALLOC_(CS%frhatu) ; DEALLOC_(CS%frhatv) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 31863d10c2..8d8c4e1f5f 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -10,7 +10,7 @@ module MOM_boundary_update use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data +use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data, chksum_OBC_segments use MOM_open_boundary, only : OBC_registry_type, file_OBC_CS use MOM_open_boundary, only : register_file_OBC, file_OBC_end use MOM_unit_scaling, only : unit_scale_type @@ -41,6 +41,9 @@ module MOM_boundary_update logical :: use_tidal_bay = .false. !< If true, use the tidal_bay open boundary. logical :: use_shelfwave = .false. !< If true, use the shelfwave open boundary. logical :: use_dyed_channel = .false. !< If true, use the dyed channel open boundary. + logical :: debug_OBCs = .false. !< If true, write verbose OBC values for debugging purposes. + integer :: nk_OBC_debug = 0 !< The number of layers of OBC segment data to write out + !! in full when DEBUG_OBCS is true. !>@{ Pointers to the control structures for named OBC specifications type(file_OBC_CS), pointer :: file_OBC_CSp => NULL() type(Kelvin_OBC_CS), pointer :: Kelvin_OBC_CSp => NULL() @@ -69,6 +72,7 @@ subroutine call_OBC_register(G, GV, US, param_file, CS, OBC, tr_Reg) type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables + logical :: debug character(len=200) :: config character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. ! This include declares and sets the variable "version". @@ -106,6 +110,16 @@ subroutine call_OBC_register(G, GV, US, param_file, CS, OBC, tr_Reg) " supercritical - now only needed here for the allocations\n"//& " tidal_bay - Flather with tidal forcing on eastern boundary\n"//& " USER - user specified", default="none", do_not_log=.true.) + call get_param(param_file, mdl, "DEBUG", debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_OBCS", CS%debug_OBCs, & + "If true, write out verbose debugging data about OBCs.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "NK_OBC_DEBUG", CS%nk_OBC_debug, & + "The number of layers of OBC segment data to write out in full "//& + "when DEBUG_OBCS is true.", & + default=0, debuggingParam=.true., do_not_log=.not.CS%debug_OBCs) if (CS%use_files) CS%use_files = & register_file_OBC(param_file, CS%file_OBC_CSp, US, & @@ -152,9 +166,10 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) if (CS%use_shelfwave) & call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, US, h, Time) if (CS%use_dyed_channel) & - call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, Time) + call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, h, Time) if (OBC%any_needs_IO_for_data .or. OBC%add_tide_constituents) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + if (CS%debug_OBCs) call chksum_OBC_segments(OBC, G, GV, US, CS%nk_OBC_debug) end subroutine update_OBC_data diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index db60b2f0e4..5288fceaff 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -627,8 +627,8 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa uh(:,j,k), duhdu(:,k), visc_rem(:,k), & dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) if (local_specified_BC) then - do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - l_seg = OBC%segnum_u(I,j) + do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= 0) then + l_seg = abs(OBC%segnum_u(I,j)) if (OBC%segment(l_seg)%specified) uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) endif ; enddo endif @@ -722,7 +722,7 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa any_simple_OBC = .false. if (present(uhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do I=ish-1,ieh - l_seg = OBC%segnum_u(I,j) + l_seg = abs(OBC%segnum_u(I,j)) ! Avoid reconciling barotropic/baroclinic transports if transport is specified simple_OBC_pt(I) = .false. @@ -743,7 +743,7 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo if (any_simple_OBC) then ; do I=ish-1,ieh ; if (simple_OBC_pt(I)) then - u_cor(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + u_cor(I,j,k) = OBC%segment(abs(OBC%segnum_u(I,j)))%normal_vel(I,j,k) endif ; enddo ; endif enddo ; endif ! u-corrected @@ -763,10 +763,9 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa enddo ! NOTE: simple_OBC_pt(I) should prevent access to segment OBC_NONE do k=1,nz ; do I=ish-1,ieh ; if (simple_OBC_pt(I)) then - if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & - (OBC%segment(OBC%segnum_u(I,j))%specified)) & - FAuI(I) = FAuI(I) + OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) / & - OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + l_seg = abs(OBC%segnum_u(I,j)) + if ((abs(OBC%segment(l_seg)%normal_vel(I,j,k)) > 0.0) .and. (OBC%segment(l_seg)%specified)) & + FAuI(I) = FAuI(I) + OBC%segment(l_seg)%normal_trans(I,j,k) / OBC%segment(l_seg)%normal_vel(I,j,k) endif ; enddo ; enddo do I=ish-1,ieh ; if (simple_OBC_pt(I)) then BT_cont%FA_u_W0(I,j) = FAuI(I) ; BT_cont%FA_u_E0(I,j) = FAuI(I) @@ -847,7 +846,7 @@ subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, p real :: duhdu(SZIB_(G)) ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. logical, dimension(SZIB_(G)) :: do_I real :: ones(SZIB_(G)) ! An array of 1's [nondim] - integer :: i, j, k, ish, ieh, jsh, jeh, nz + integer :: i, j, k, ish, ieh, jsh, jeh, nz, l_seg logical :: local_specified_BC, OBC_in_row call cpu_clock_begin(id_clock_correct) @@ -870,15 +869,16 @@ subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, p do j=jsh,jeh ! Determining whether there are any OBC points outside of the k-loop should be more efficient. OBC_in_row = .false. - if (local_specified_BC) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - if (OBC%segment(OBC%segnum_u(I,j))%specified) OBC_in_row = .true. + if (local_specified_BC) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(abs(OBC%segnum_u(I,j)))%specified) OBC_in_row = .true. endif ; enddo ; endif do k=1,nz ! This sets uh and duhdu. call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh, duhdu, ones, & dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) - if (OBC_in_row) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - if (OBC%segment(OBC%segnum_u(I,j))%specified) uh(I) = OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) + if (OBC_in_row) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= 0) then + l_seg = abs(OBC%segnum_u(I,j)) + if (OBC%segment(l_seg)%specified) uh(I) = OBC%segment(l_seg)%normal_trans(I,j,k) endif ; enddo ; endif ! Accumulate the barotropic transport. @@ -956,13 +956,12 @@ subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & endif ; enddo if (local_open_BC) then - do I=ish-1,ieh ; if (do_I(I)) then ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - l_seg = OBC%segnum_u(I,j) - if (OBC%segment(l_seg)%open) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + do I=ish-1,ieh ; if (do_I(I)) then ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(abs(OBC%segnum_u(I,j)))%open) then + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i) duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h(i) * visc_rem(I) - else + else ! OBC_DIRECTION_W uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i+1) duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * h(i+1) * visc_rem(I) endif @@ -1477,6 +1476,7 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p logical :: use_visc_rem, set_BT_cont logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals logical :: simple_OBC_pt(SZI_(G)) ! Indicates points in a row with specified transport OBCs + type(OBC_segment_type), pointer :: segment => NULL() call cpu_clock_begin(id_clock_correct) @@ -1520,8 +1520,8 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p vh(:,J,k), dvhdv(:,k), visc_rem(:,k), & dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) if (local_specified_BC) then - do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - l_seg = OBC%segnum_v(i,J) + do i=ish,ieh ; if (OBC%segnum_v(i,J) /= 0) then + l_seg = abs(OBC%segnum_v(i,J)) if (OBC%segment(l_seg)%specified) vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) endif ; enddo endif @@ -1612,11 +1612,11 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p any_simple_OBC = .false. if (present(vhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do i=ish,ieh - l_seg = OBC%segnum_v(i,J) + l_seg = abs(OBC%segnum_v(i,J)) ! Avoid reconciling barotropic/baroclinic transports if transport is specified simple_OBC_pt(i) = .false. - if (l_seg /= OBC_NONE) simple_OBC_pt(i) = OBC%segment(l_seg)%specified + if (l_seg /= 0) simple_OBC_pt(i) = OBC%segment(l_seg)%specified do_I(i) = .not.simple_OBC_pt(i) any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(i) enddo ; else ; do i=ish,ieh @@ -1633,7 +1633,7 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo if (any_simple_OBC) then ; do i=ish,ieh ; if (simple_OBC_pt(i)) then - v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + v_cor(i,J,k) = OBC%segment(abs(OBC%segnum_v(i,J)))%normal_vel(i,J,k) endif ; enddo ; endif enddo ; endif ! v-corrected @@ -1653,10 +1653,9 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p enddo ! NOTE: simple_OBC_pt(i) should prevent access to segment OBC_NONE do k=1,nz ; do i=ish,ieh ; if (simple_OBC_pt(i)) then - if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & - (OBC%segment(OBC%segnum_v(i,J))%specified)) & - FAvi(i) = FAvi(i) + OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) / & - OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + segment => OBC%segment(abs(OBC%segnum_v(i,J))) + if ((abs(segment%normal_vel(i,J,k)) > 0.0) .and. (segment%specified)) & + FAvi(i) = FAvi(i) + segment%normal_trans(i,J,k) / segment%normal_vel(i,J,k) endif ; enddo ; enddo do i=ish,ieh ; if (simple_OBC_pt(i)) then BT_cont%FA_v_S0(i,J) = FAvi(i) ; BT_cont%FA_v_N0(i,J) = FAvi(i) @@ -1737,7 +1736,7 @@ subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, O real :: dvhdv(SZI_(G)) ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. logical, dimension(SZI_(G)) :: do_I real :: ones(SZI_(G)) ! An array of 1's [nondim] - integer :: i, j, k, ish, ieh, jsh, jeh, nz + integer :: i, j, k, ish, ieh, jsh, jeh, nz, l_seg logical :: local_specified_BC, OBC_in_row call cpu_clock_begin(id_clock_correct) @@ -1760,15 +1759,16 @@ subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, O do J=jsh-1,jeh ! Determining whether there are any OBC points outside of the k-loop should be more efficient. OBC_in_row = .false. - if (local_specified_BC) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - if (OBC%segment(OBC%segnum_v(i,J))%specified) OBC_in_row = .true. + if (local_specified_BC) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(abs(OBC%segnum_v(i,J)))%specified) OBC_in_row = .true. endif ; enddo ; endif do k=1,nz ! This sets vh and dvhdv. call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh, dvhdv, ones, & dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) - if (OBC_in_row) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - if (OBC%segment(OBC%segnum_v(i,J))%specified) vh(i) = OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) + if (OBC_in_row) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= 0) then + l_seg = abs(OBC%segnum_v(i,J)) + if (OBC%segment(l_seg)%specified) vh(i) = OBC%segment(l_seg)%normal_trans(i,J,k) endif ; enddo ; endif ! Accumulate the barotropic transport. @@ -1820,7 +1820,6 @@ subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & ! with the same units as h, i.e. [H ~> m or kg m-2]. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i - integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -1854,11 +1853,9 @@ subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & if (local_open_BC) then do i=ish,ieh ; if (do_I(i)) then - l_seg = OBC%segnum_v(i,J) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(abs(OBC%segnum_v(i,J)))%open) then + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * h(i,j) dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h(i,j) * visc_rem(i) else @@ -2385,8 +2382,7 @@ subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_ do n=1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle - if (segment%direction == OBC_DIRECTION_E .or. & - segment%direction == OBC_DIRECTION_W) then + if (segment%is_E_or_W) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed slp(i+1,j) = 0.0 @@ -2521,8 +2517,7 @@ subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_ do n=1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle - if (segment%direction == OBC_DIRECTION_S .or. & - segment%direction == OBC_DIRECTION_N) then + if (segment%is_N_or_S) then J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied slp(i,j+1) = 0.0 diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 40d1888595..d11af637a1 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -181,7 +181,8 @@ module MOM_dynamics_split_RK2 !! Euler (1) [nondim]. 0 is often used. real :: Cemp_NL !< Empirical coefficient of non-local momentum mixing [nondim] logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. + logical :: debug_OBC !< If true, do additional calls resetting values to help debug the correctness + !! of the open boundary condition code. logical :: fpmix !< If true, add non-local momentum flux increments and diffuse down the Eulerian gradient. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. logical :: visc_rem_dt_bug = .true. !< If true, recover a bug that uses dt_pred rather than dt for vertvisc_rem @@ -1402,6 +1403,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p type(group_pass_type) :: pass_av_h_uvh logical :: debug_truncations logical :: read_uv, read_h2 + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -1473,14 +1476,19 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) + call get_param(param_file, mdl, "OBC_DEBUGGING_TESTS", CS%debug_OBC, & + "If true, do additional calls resetting certain values to help verify the "//& + "correctness of the open boundary condition code.", & + default=.false., old_name="DEBUG_OBC", debuggingParam=.true., do_not_log=.true.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& "for in two places. This parameter controls the defaults of two individual "//& "flags, VISC_REM_TIMESTEP_BUG in MOM_dynamics_split_RK2(b) and "//& - "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=.true.) + "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=enable_bugs) call get_param(param_file, mdl, "VISC_REM_TIMESTEP_BUG", CS%visc_rem_dt_bug, & "If true, recover a bug that uses dt_pred rather than dt in "//& "vertvisc_remnant() at the end of predictor stage for the following "//& @@ -1544,7 +1552,7 @@ 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, GV, US, param_file, CS%SAL_CSp) + if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp, restart_CS) 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 diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 7896000a28..9bfbff5191 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -171,7 +171,8 @@ module MOM_dynamics_split_RK2b !! is forward-backward (0) or simulated backward !! Euler (1) [nondim]. 0 is often used. logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. + logical :: debug_OBC !< If true, do additional calls resetting values to help verify the correctness + !! of the open boundary condition code. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. logical :: visc_rem_dt_bug = .true. !< If true, recover a bug that uses dt_pred rather than dt for vertvisc_rem @@ -1302,6 +1303,8 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, character(len=48) :: thickness_units, flux_units, eta_rest_name logical :: debug_truncations logical :: read_uv, read_h2 + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -1359,14 +1362,19 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) + call get_param(param_file, mdl, "OBC_DEBUGGING_TESTS", CS%debug_OBC, & + "If true, do additional calls resetting certain values to help verify the "//& + "correctness of the open boundary condition code.", & + default=.false., old_name="DEBUG_OBC", debuggingParam=.true., do_not_log=.true.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& "for in two places. This parameter controls the defaults of two individual "//& "flags, VISC_REM_TIMESTEP_BUG in MOM_dynamics_split_RK2(b) and "//& - "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=.true.) + "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=enable_bugs) call get_param(param_file, mdl, "VISC_REM_TIMESTEP_BUG", CS%visc_rem_dt_bug, & "If true, recover a bug that uses dt_pred rather than dt in "//& "vertvisc_remnant() at the end of predictor stage for the following "//& @@ -1427,7 +1435,7 @@ 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, GV, US, param_file, CS%SAL_CSp) + if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp, restart_CS) 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 diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index bce0c4026a..d4d3356c3d 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -576,7 +576,7 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS) end subroutine register_restarts_dyn_unsplit !> Initialize parameters and allocate memory associated with the unsplit dynamics module. -subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS, & +subroutine initialize_dyn_unsplit(u, v, h, tv, Time, G, GV, US, param_file, diag, CS, & Accel_diag, Cont_diag, MIS, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & visc, dirs, ntrunc, cont_stencil) @@ -589,6 +589,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse !! for run-time parameters. @@ -710,7 +711,7 @@ 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, GV, US, param_file, CS%SAL_CSp) + if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp) if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, & CS%SAL_CSp, CS%tides_CSp) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index dd3df7bb3a..7bdae9ab20 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -526,7 +526,7 @@ subroutine register_restarts_dyn_unsplit_RK2(HI, GV, param_file, CS) end subroutine register_restarts_dyn_unsplit_RK2 !> Initialize parameters and allocate memory associated with the unsplit RK2 dynamics module. -subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag, CS, & +subroutine initialize_dyn_unsplit_RK2(u, v, h, tv, Time, G, GV, US, param_file, diag, CS, & Accel_diag, Cont_diag, MIS, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & visc, dirs, ntrunc, cont_stencil) @@ -536,6 +536,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse !! for run-time parameters. @@ -673,7 +674,7 @@ 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, GV, US, param_file, CS%SAL_CSp) + if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp) if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, & CS%SAL_CSp, CS%tides_CSp) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index f91d958fe8..f51ec928b6 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1183,7 +1183,7 @@ subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_units) ! Local variables real :: I_rho ! The inverse of the reference density [R-1 ~> m3 kg-1] ! or in some semi-Boussinesq cases the reference - ! density [H2 R-1 ~> m3 kg-1 or kg m-3] + ! density [H2 Z-2 R-1 ~> m3 kg-1 or kg m-3] logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] integer :: i, j, k, is, ie, js, je, hs @@ -1248,7 +1248,7 @@ subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_unit ! Local variables real :: I_rho ! The inverse of the reference density [R-1 ~> m3 kg-1] or in some semi-Boussinesq cases - ! the rescaled reference density [H2 R-1 ~> m3 kg-1 or kg m-3] + ! the rescaled reference density [H2 Z-2 R-1 ~> m3 kg-1 or kg m-3] logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] integer :: i, j, k, is, ie, js, je, hs @@ -1578,7 +1578,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'm s-1', conversion=US%Z_to_m*US%s_to_T) handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & - 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad') + 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad', conversion=1.0) if (present(use_berg_fluxes)) then if (use_berg_fluxes) then @@ -1586,7 +1586,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Friction velocity below iceberg ', 'm s-1', conversion=US%Z_to_m*US%s_to_T) handles%id_area_berg = register_diag_field('ocean_model', 'area_berg', diag%axesT1, Time, & - 'Area of grid cell covered by iceberg ', 'm2 m-2') + 'Area of grid cell covered by iceberg ', 'm2 m-2', conversion=1.0) handles%id_mass_berg = register_diag_field('ocean_model', 'mass_berg', diag%axesT1, Time, & 'Mass of icebergs ', 'kg m-2', conversion=US%RZ_to_kg_m2) @@ -1595,7 +1595,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Friction velocity below iceberg and ice shelf together', 'm s-1', conversion=US%Z_to_m*US%s_to_T) handles%id_frac_ice_cover = register_diag_field('ocean_model', 'frac_ice_cover', diag%axesT1, Time, & - 'Area of grid cell below iceberg and ice shelf together ', 'm2 m-2') + 'Area of grid cell below iceberg and ice shelf together ', 'm2 m-2', conversion=1.0) endif endif @@ -1603,7 +1603,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, if (present(use_cfcs)) then if (use_cfcs) then handles%id_ice_fraction = register_diag_field('ocean_model', 'ice_fraction', diag%axesT1, Time, & - 'Fraction of cell area covered by sea ice', 'm2 m-2') + 'Fraction of cell area covered by sea ice', 'm2 m-2', conversion=1.0) handles%id_u10_sqr = register_diag_field('ocean_model', 'u10_sqr', diag%axesT1, Time, & 'Wind magnitude at 10m, squared', 'm2 s-2', conversion=US%L_to_m**2*US%s_to_T**2) @@ -1781,11 +1781,13 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name='Water Flux into Sea Water From Rivers Area Integrated') if (present(use_glc_runoff)) then - handles%id_total_frunoff_glc = register_scalar_field('ocean_model', 'total_frunoff_glc', Time, diag, & - long_name='Area integrated frozen glacier runoff (calving) & iceberg melt into ocean', units='kg s-1') + handles%id_total_frunoff_glc = register_scalar_field('ocean_model', 'total_frunoff_glc', Time, diag, & + long_name='Area integrated frozen glacier runoff (calving) & iceberg melt into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) - handles%id_total_lrunoff_glc = register_scalar_field('ocean_model', 'total_lrunoff_glc', Time, diag,& - long_name='Area integrated liquid glacier runoff into ocean', units='kg s-1') + handles%id_total_lrunoff_glc = register_scalar_field('ocean_model', 'total_lrunoff_glc', Time, diag, & + long_name='Area integrated liquid glacier runoff into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) endif handles%id_total_net_massout = register_scalar_field('ocean_model', 'total_net_massout', Time, diag, & @@ -2010,12 +2012,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_heat_content_frunoff_glc = register_scalar_field('ocean_model', & 'total_heat_content_frunoff_glc', Time, diag, & long_name='Area integrated heat content (relative to 0C) of solid glacier runoff', & - units='W') ! todo: update cmor names + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) ! todo: update cmor names handles%id_total_heat_content_lrunoff_glc = register_scalar_field('ocean_model', & 'total_heat_content_lrunoff_glc', Time, diag, & long_name='Area integrated heat content (relative to 0C) of liquid glacier runoff', & - units='W') ! todo: update cmor names + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) ! todo: update cmor names endif handles%id_total_heat_content_lprec = register_scalar_field('ocean_model', & @@ -2139,7 +2141,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_lat_frunoff_glc = register_scalar_field('ocean_model', & 'total_lat_frunoff_glc', Time, diag, & long_name='Area integrated latent heat flux due to melting frozen glacier runoff', & - units='W') ! todo: update cmor names + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) ! todo: update cmor names endif handles%id_total_sens = register_scalar_field('ocean_model', & @@ -2259,17 +2261,17 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_saltFluxGlobalScl = register_scalar_field('ocean_model', & 'salt_flux_global_restoring_scaling', Time, diag, & 'Scaling applied to balance net global salt flux into ocean at surface', & - 'nondim') + 'nondim', conversion=1.0) handles%id_vPrecGlobalScl = register_scalar_field('ocean_model',& 'vprec_global_scaling', Time, diag, & 'Scaling applied to adjust net vprec into ocean to zero', & - 'nondim') + 'nondim', conversion=1.0) handles%id_netFWGlobalScl = register_scalar_field('ocean_model', & 'net_fresh_water_global_scaling', Time, diag, & 'Scaling applied to adjust net fresh water into ocean to zero', & - 'nondim') + 'nondim', conversion=1.0) !=============================================================== ! area integrals of surface salt fluxes @@ -2294,7 +2296,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, if (present(use_waves)) then if (use_waves) then handles%id_lamult = register_diag_field('ocean_model', 'lamult', & - diag%axesT1, Time, long_name='Langmuir enhancement factor received from WW3', units="nondim") + diag%axesT1, Time, long_name='Langmuir enhancement factor received from WW3', units="nondim", conversion=1.0) endif endif @@ -2960,7 +2962,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%lrunoff_glc)) then if (handles%id_lrunoff_glc > 0) call post_data(handles%id_lrunoff_glc, fluxes%lrunoff_glc, diag) if (handles%id_total_lrunoff_glc > 0) then - total_mass_flux = global_area_integral(fluxes%lrunoff_glc, G, scale=US%RZ_T_to_kg_m2s) + total_mass_flux = global_area_integral(fluxes%lrunoff_glc, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_lrunoff_glc, total_mass_flux, diag) endif endif @@ -2976,7 +2978,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%frunoff_glc)) then if (handles%id_frunoff_glc > 0) call post_data(handles%id_frunoff_glc, fluxes%frunoff_glc, diag) if (handles%id_total_frunoff_glc > 0) then - total_mass_flux = global_area_integral(fluxes%frunoff_glc, G, scale=US%RZ_T_to_kg_m2s) + total_mass_flux = global_area_integral(fluxes%frunoff_glc, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_frunoff_glc, total_mass_flux, diag) endif endif @@ -3002,8 +3004,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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_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) + total_heat_flux = global_area_integral(fluxes%heat_content_lrunoff_glc, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_lrunoff_glc, total_heat_flux, diag) endif if ((handles%id_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) & @@ -3015,8 +3017,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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_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) + total_heat_flux = global_area_integral(fluxes%heat_content_frunoff_glc, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_frunoff_glc, total_heat_flux, diag) endif if ((handles%id_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) & @@ -3281,8 +3283,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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_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) + total_heat_flux = global_area_integral(fluxes%latent_frunoff_glc_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_frunoff_glc, total_heat_flux, diag) endif if ((handles%id_sens > 0) .and. associated(fluxes%sens)) then diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index e0d456f9a3..94583673c2 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -75,8 +75,8 @@ module MOM_grid real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & mask2dT, & !< 0 for land points and 1 for ocean points on the h-grid [nondim]. - geoLatT, & !< The geographic latitude at q points [degrees_N] or [km] or [m]. - geoLonT, & !< The geographic longitude at q points [degrees_E] or [km] or [m]. + geoLatT, & !< The geographic latitude at tracer (h) points [degrees_N] or [km] or [m] + geoLonT, & !< The geographic longitude at tracer (h) points [degrees_E] or [km] or [m] dxT, & !< dxT is delta x at h points [L ~> m]. IdxT, & !< 1/dxT [L-1 ~> m-1]. dyT, & !< dyT is delta y at h points [L ~> m]. diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 5aa822a000..c9e4bc015e 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -3,7 +3,7 @@ module MOM_interface_heights ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_density_integrals, only : int_specific_vol_dp, avg_specific_vol +use MOM_density_integrals, only : int_specific_vol_dp, avg_specific_vol, int_density_dz use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, FATAL use MOM_EOS, only : calculate_density, average_specific_vol, EOS_type, EOS_domain @@ -20,7 +20,7 @@ module MOM_interface_heights public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple public calc_derived_thermo public convert_MLD_to_ML_thickness -public find_rho_bottom, find_col_avg_SpV +public find_rho_bottom, find_col_avg_SpV, find_col_mass !> Calculates the heights of the free surface or all interfaces from layer thicknesses. interface find_eta @@ -73,7 +73,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m]. ! dZ_ref is 0 unless the optional argument dZref is present. - integer i, j, k, isv, iev, jsv, jev, nz, halo + integer :: i, j, k, isv, iev, jsv, jev, nz, halo halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) @@ -191,7 +191,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m]. ! dZ_ref is 0 unless the optional argument dZref is present. - integer i, j, k, is, ie, js, je, nz, halo + integer :: i, j, k, is, ie, js, je, nz, halo halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -345,7 +345,7 @@ subroutine find_col_avg_SpV(h, SpV_avg, tv, G, GV, US, halo_size) real :: I_rho ! The inverse of the Boussiensq reference density [R-1 ~> m3 kg-1] real :: SpV_lay(SZK_(GV)) ! The inverse of the layer target potential densities [R-1 ~> m3 kg-1] character(len=128) :: mesg ! A string for error messages - integer i, j, k, is, ie, js, je, nz, halo + integer :: i, j, k, is, ie, js, je, nz, halo halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) @@ -391,6 +391,71 @@ subroutine find_col_avg_SpV(h, SpV_avg, tv, G, GV, US, halo_size) end subroutine find_col_avg_SpV +!> Calculate the integrated mass of the water column. +subroutine find_col_mass(h, tv, G, GV, US, mass, p_bot, p_surf) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass !< Integrated mass of the water column + !! [R Z ~> kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: p_bot !< Bottom pressure = g * mass + psurf + !! [R L2 T-2 ~> Pa] + real, dimension(:,:), optional, pointer :: p_surf !< A pointer to surface pressure + !! [R L2 T-2 ~> Pa] + + ! Local variables + real :: I_gEarth ! The inverse of GV%g_Earth [T2 Z L-2 ~> s2 m-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + z_top, & ! Height of the top of a layer [Z ~> m]. + z_bot, & ! Height of the bottom of a layer [Z ~> m]. + dp ! Change in hydrostatic pressure across a layer [R L2 T-2 ~> Pa]. + integer :: i, j, k, is, ie, js, je, isq, ieq, jsq, jeq, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isq = G%iscB ; ieq = G%iecB ; jsq = G%jscB ; jeq = G%jecB + nz = GV%ke + + do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo + if (GV%Boussinesq) then + if (associated(tv%eqn_of_state)) then + I_gEarth = 1.0 / GV%g_Earth + do j=jsq,jeq+1 ; do i=isq,ieq+1 ; z_bot(i,j) = 0.0 ; enddo ; enddo + do k=1,nz + ! NOTE: int_density_z expects z_top and z_bot values from [ij]sq to [ij]eq+1 + do j=jsq,jeq+1 ; do i=isq,ieq+1 + z_top(i,j) = z_bot(i,j) + z_bot(i,j) = z_top(i,j) - GV%H_to_Z * h(i,j,k) + enddo ; enddo + call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & + G%HI, tv%eqn_of_state, US, dp) + do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + dp(i,j) * I_gEarth + enddo ; enddo + enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + (GV%H_to_Z * GV%Rlay(k)) * h(i,j,k) + enddo ; enddo ; enddo + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + GV%H_to_RZ * h(i,j,k) + enddo ; enddo ; enddo + endif + + if (present(p_bot)) then + do j=js,je ; do i=is,ie + p_bot(i,j) = GV%g_Earth * mass(i,j) + enddo ; enddo + if (present(p_surf) .and. associated(p_surf)) then ; do j=js,je ; do i=is,ie + p_bot(i,j) = p_bot(i,j) + p_surf(i,j) + enddo ; enddo ; endif + endif + +end subroutine find_col_mass !> Determine the in situ density averaged over a specified distance from the bottom, !! calculating it as the inverse of the mass-weighted average specific volume. diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index cdba3e0ba9..372ed8701d 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -28,8 +28,8 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return other stratification dependent functions such as N^2 !! and dz*S^2*g-prime used, or calculable from factors used, during the calculation. -subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stanley, & - slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC) +subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stanley, slope_x, slope_y, & + N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC, OBC_N2) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -61,6 +61,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !! Eady growth rate at v-points. [Z T-1 ~> m s-1] integer, optional, intent(in) :: halo !< Halo width over which to compute type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + logical, optional, intent(in) :: OBC_N2 !< If present and true, use interior data + !! to calculate stratification at open boundary + !! condition faces. ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & @@ -127,6 +130,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan logical :: present_N2_u, present_N2_v logical :: local_open_u_BC, local_open_v_BC ! True if u- or v-face OBCs exist anywhere in the global domain. + logical :: OBC_friendly ! If true, open boundary conditions are in use and only interior data should + ! be used to calculate N2 at OBC faces. integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of ! state calculations at u-points. integer, dimension(2) :: EOSdom_v ! The shifted i-computational domain to use for equation of @@ -135,7 +140,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! state calculations at h points with 1 extra halo point integer :: is, ie, js, je, nz, IsdB integer :: i, j, k - integer :: l_seg if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -155,9 +159,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan local_open_u_BC = .false. local_open_v_BC = .false. + OBC_friendly = .false. if (present(OBC)) then ; if (associated(OBC)) then local_open_u_BC = OBC%open_u_BCs_exist_globally local_open_v_BC = OBC%open_v_BCs_exist_globally + if (present(OBC_N2)) OBC_friendly = OBC_N2 endif ; endif use_EOS = associated(tv%eqn_of_state) @@ -241,17 +247,17 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo do I=is-1,ie - GxSpV_u(I) = G_Rho0 !This will be changed if both use_EOS and allocated(tv%SpV_avg) are true + GxSpV_u(I) = G_Rho0 ! This will be changed if both use_EOS and allocated(tv%SpV_avg) are true enddo !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,h_neglect2, & !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,EOSdom_h1, & - !$OMP local_open_u_BC,dzu,OBC,use_stanley) & + !$OMP local_open_u_BC,dzu,OBC,use_stanley,OBC_friendly) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,slope,l_seg) & + !$OMP drdx,mag_grad2,slope) & !$OMP firstprivate(GxSpV_u) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then @@ -266,6 +272,26 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan T_u(I) = 0.25*((T(i,j,k) + T(i+1,j,k)) + (T(i,j,k-1) + T(i+1,j,k-1))) S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo + if (OBC_friendly) then + if (OBC%u_E_OBCs_on_PE .and. (j>=OBC%js_u_E_obc) .and. (j<=OBC%je_u_E_obc)) then + do I = max(is-1, OBC%Is_u_E_obc), min(ie, OBC%Ie_u_E_obc) + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E + pres_u(I) = pres(i,j,K) + T_u(I) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_u(I) = 0.5*(S(i,j,k) + S(i,j,k-1)) + endif + enddo + endif + if (OBC%u_W_OBCs_on_PE .and. (j>=OBC%js_u_W_obc) .and. (j<=OBC%je_u_W_obc)) then + do I = max(is-1, OBC%Is_u_W_obc), min(ie, OBC%Ie_u_W_obc) + if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W + pres_u(I) = pres(i+1,j,K) + T_u(I) = 0.5*(T(i+1,j,k) + T(i+1,j,k-1)) + S_u(I) = 0.5*(S(i+1,j,k) + S(i+1,j,k-1)) + endif + enddo + endif + endif call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & tv%eqn_of_state, EOSdom_u) if (present_N2_u .or. (present(dzSxN))) then @@ -338,8 +364,20 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! The expression for drdz above is mathematically equivalent to: ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) - ! This is the gradient of density along geopotentials. + ! which is an estimate of the gradient of density across geopotentials. if (present_N2_u) then + if (OBC_friendly) then ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E + drdz = drdkL / dzaL ! Note that drdz is not used for slopes at OBC faces. + if (use_EOS .and. allocated(tv%SpV_avg)) & + GxSpV_u(I) = GV%g_Earth * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j,k-1)) + elseif (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W + drdz = drdkR / dzaR + if (use_EOS .and. allocated(tv%SpV_avg)) & + GxSpV_u(I) = GV%g_Earth * 0.5 * (tv%SpV_avg(i+1,j,k) + tv%SpV_avg(i+1,j,k-1)) + endif + endif ; endif + N2_u(I,j,K) = GxSpV_u(I) * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] endif @@ -360,13 +398,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif if (local_open_u_BC) then - l_seg = OBC%segnum_u(I,j) - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then + if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(abs(OBC%segnum_u(I,j)))%open) then slope = 0. ! This and/or the masking code below is to make slopes match inside ! land mask. Might not be necessary except for DEBUG output. -! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E ! slope_x(I+1,j,K) = 0. ! else ! slope_x(I-1,j,K) = 0. @@ -375,6 +412,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif slope = slope * max(G%mask2dT(i,j), G%mask2dT(i+1,j)) endif + slope_x(I,j,K) = slope if (present(dzSxN)) & dzSxN(I,j,K) = sqrt( GxSpV_u(I) * max(0., (wtL * ( dzaL * drdkL )) & @@ -391,13 +429,13 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect, & !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSyN,EOSdom_v, & - !$OMP dzv,local_open_v_BC,OBC,use_stanley) & + !$OMP dzv,local_open_v_BC,OBC,use_stanley,OBC_friendly) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & !$OMP drho_dT_dT_hr,pres_hr,T_hr,S_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,slope,l_seg) & + !$OMP drdy,mag_grad2,slope) & !$OMP firstprivate(GxSpV_v) do J=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then @@ -411,6 +449,26 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan T_v(i) = 0.25*((T(i,j,k) + T(i,j+1,k)) + (T(i,j,k-1) + T(i,j+1,k-1))) S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo + if (OBC_friendly) then + if (OBC%v_N_OBCs_on_PE .and. (J>=OBC%Js_v_N_obc) .and. (J<=OBC%Je_v_N_obc)) then + do i = max(is, OBC%is_v_N_obc), min(ie, OBC%ie_v_N_obc) + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N + pres_v(i) = pres(i,j,K) + T_v(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_v(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + endif + enddo + endif + if (OBC%v_S_OBCs_on_PE .and. (J>=OBC%Js_v_S_obc) .and. (J<=OBC%Je_v_S_obc)) then + do i = max(is, OBC%is_v_S_obc), min(ie, OBC%ie_v_S_obc) + if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S + pres_v(i) = pres(i,j+1,K) + T_v(i) = 0.5*(T(i,j+1,k) + T(i,j+1,k-1)) + S_v(i) = 0.5*(S(i,j+1,k) + S(i,j+1,k-1)) + endif + enddo + endif + endif call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & tv%eqn_of_state, EOSdom_v) @@ -490,8 +548,22 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! The expression for drdz above is mathematically equivalent to: ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) - ! This is the gradient of density along geopotentials. - if (present_N2_v) N2_v(i,J,K) = GxSpV_v(i) * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + ! which is an estimate of the gradient of density across geopotentials. + if (present_N2_v) then + if (OBC_friendly) then ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N + drdz = drdkL / dzaL ! Note that drdz is not used for slopes at OBC faces. + if (use_EOS .and. allocated(tv%SpV_avg)) & + GxSpV_v(i) = GV%g_Earth * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j,k-1)) + elseif (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S + drdz = drdkL / dzaL + if (use_EOS .and. allocated(tv%SpV_avg)) & + GxSpV_v(i) = GV%g_Earth * 0.5 * (tv%SpV_avg(i,j+1,k) + tv%SpV_avg(i,j+1,k-1)) + endif + endif ; endif + + N2_v(i,J,K) = GxSpV_v(i) * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + endif if (use_EOS) then drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & @@ -510,13 +582,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif if (local_open_v_BC) then - l_seg = OBC%segnum_v(i,J) - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then + if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(abs(OBC%segnum_v(i,J)))%open) then slope = 0. ! This and/or the masking code below is to make slopes match inside ! land mask. Might not be necessary except for DEBUG output. -! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! if (OBC%segnum_v(i,J)) > 0) then ! OBC_DIRECTION_N ! slope_y(i,J+1,K) = 0. ! else ! slope_y(i,J-1,K) = 0. diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 19d3361514..9442ba77d9 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4,10 +4,9 @@ module MOM_open_boundary ! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : rotate_array, rotate_array_pair -use MOM_array_transform, only : allocate_rotated_array use MOM_coms, only : sum_across_PEs, Set_PElist, Get_PElist, PE_here, num_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE -use MOM_debugging, only : hchksum, uvchksum +use MOM_debugging, only : hchksum, uvchksum, chksum use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type @@ -19,14 +18,14 @@ 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, file_exists, SINGLE_FILE +use MOM_io, only : slasher, field_size, file_exists, stderr, 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 use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping use MOM_restart, only : register_restart_field, register_restart_pair -use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS use MOM_string_functions, only : extract_word, remove_spaces, uppercase, lowercase use MOM_tidal_forcing, only : astro_longitudes, astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) @@ -41,14 +40,12 @@ module MOM_open_boundary public open_boundary_apply_normal_flow public open_boundary_config -public open_boundary_setup_vert -public open_boundary_init +public open_boundary_halo_update public open_boundary_query public open_boundary_end public open_boundary_impose_normal_slope public open_boundary_impose_land_mask public radiation_open_bdry_conds -public set_tracer_data public update_OBC_segment_data public open_boundary_test_extern_uv public open_boundary_test_extern_h @@ -69,10 +66,12 @@ module MOM_open_boundary public setup_OBC_tracer_reservoirs public open_boundary_register_restarts public update_segment_tracer_reservoirs +public set_initialized_OBC_tracer_reservoirs public update_OBC_ramp public remap_OBC_fields public rotate_OBC_config -public rotate_OBC_init +public rotate_OBC_segment_direction +public write_OBC_info, chksum_OBC_segments public initialize_segment_data public flood_fill public flood_fill2 @@ -89,8 +88,11 @@ module MOM_open_boundary type(external_field) :: handle !< handle from FMS associated with segment data on disk type(external_field) :: dz_handle !< handle from FMS associated with segment thicknesses on disk logical :: use_IO = .false. !< True if segment data is based on file input - character(len=32) :: name !< a name identifier for the segment data + character(len=32) :: name !< A name identifier for the segment data. When there is grid + !! rotation, this is the name on the rotated internal grid. character(len=8) :: genre !< an identifier for the segment data + logical :: on_face !< If true, this field is discretized on the OBC segment + !! (velocity-point) faces, or if false it as the vorticiy points real :: scale !< A scaling factor for converting input data to !! the internal units of this field. For salinity this would !! be in units of [S ppt-1 ~> 1] @@ -185,10 +187,10 @@ module MOM_open_boundary logical :: is_E_or_W_2 !< True if the OB is facing East or West anywhere. type(OBC_segment_data_type), pointer :: field(:) => NULL() !< OBC data integer :: num_fields !< number of OBC data fields (e.g. u_normal,u_parallel and eta for Flather) - integer :: Is_obc !< i-indices of boundary segment. - integer :: Ie_obc !< i-indices of boundary segment. - integer :: Js_obc !< j-indices of boundary segment. - integer :: Je_obc !< j-indices of boundary segment. + integer :: Is_obc !< Starting local i-index of boundary segment, this may be outside of the local PE. + integer :: Ie_obc !< Ending local i-index of boundary segment, this may be outside of the local PE. + integer :: Js_obc !< Starting local j-index of boundary segment, this may be outside of the local PE. + integer :: Je_obc !< Ending local j-index of boundary segment, this may be outside of the local PE. integer :: uamp_index !< Save where uamp is in segment%field. integer :: uphase_index !< Save where uphase is in segment%field. integer :: vamp_index !< Save where vamp is in segment%field. @@ -203,8 +205,8 @@ module MOM_open_boundary real, allocatable :: Cg(:,:) !< The external gravity wave speed [L T-1 ~> m s-1] !! at OBC-points. real, allocatable :: Htot(:,:) !< The total column thickness [H ~> m or kg m-2] at OBC-points. - real, allocatable :: dZtot(:,:) !< The total column vertical extent [Z ~> m] at OBC-points. - real, allocatable :: h(:,:,:) !< The cell thickness [H ~> m or kg m-2] at OBC-points. + real, allocatable :: dZtot(:,:) !< The total column vertical extent [Z ~> m] at OBC segment faces. + real, allocatable :: h(:,:,:) !< The cell thickness [H ~> m or kg m-2] at OBC segment faces real, allocatable :: normal_vel(:,:,:) !< The layer velocity normal to the OB !! segment [L T-1 ~> m s-1]. real, allocatable :: tangential_vel(:,:,:) !< The layer velocity tangential to the OB segment @@ -293,7 +295,6 @@ module MOM_open_boundary !! require less frequent update logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs on the current PE logical :: any_needs_IO_for_data = .false. !< Is any i/o needed for OBCs globally - logical :: some_need_no_IO_for_data = .false. !< Are there any PEs with OBCs that do not need i/o. logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the relative vorticity on open boundaries. @@ -334,8 +335,12 @@ module MOM_open_boundary ! Properties of the segments used. type(OBC_segment_type), allocatable :: segment(:) !< List of segment objects. ! Which segment object describes the current point. - integer, allocatable :: segnum_u(:,:) !< Segment number of u-points. - integer, allocatable :: segnum_v(:,:) !< Segment number of v-points. + integer, allocatable :: segnum_u(:,:) !< The absolute value gives the segment number of any OBCs at u-points, + !! while the sign indicates whether they are Eastern (> 0) or Western (< 0) + !! OBCs, with 0 for velocities that are not on an OBC. + integer, allocatable :: segnum_v(:,:) !< The absolute value gives the segment number of any OBCs at v-points, + !! while the sign indicates whether they are Northern (> 0) or Southern (< 0) + !! OBCs, with 0 for velocities that are not on an OBC. ! Keep the OBC segment properties for external BGC tracers type(external_tracers_segments_props), pointer :: obgc_segments_props => NULL() !< obgc segment properties integer :: num_obgc_tracers = 0 !< The total number of obgc tracers @@ -348,30 +353,46 @@ module MOM_open_boundary real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of !! characteristics) in units of grid points per timestep [nondim]. logical :: OBC_pe !< Is there an open boundary on this tile? - type(remapping_CS), pointer :: remap_z_CS=> NULL() !< ALE remapping control structure for - !! z-space data on segments - type(remapping_CS), pointer :: remap_h_CS=> NULL() !< ALE remapping control structure for - !! thickness-based fields on segments + logical :: u_OBCs_on_PE !< True if there are any u-point OBCs on this PE, including in its halos. + logical :: v_OBCs_on_PE !< True if there are any v-point OBCs on this PE, including in its halos. + logical :: v_N_OBCs_on_PE !< True if there are any northern v-point OBCs on this PE, including in its halos. + logical :: v_S_OBCs_on_PE !< True if there are any southern v-point OBCs on this PE, including in its halos. + logical :: u_E_OBCs_on_PE !< True if there are any eastern u-point OBCs on this PE, including in its halos. + logical :: u_W_OBCs_on_PE !< True if there are any western u-point OBCs on this PE, including in its halos. + !>@{ Index ranges on the local PE for the open boundary conditions in various directions + integer :: Is_u_W_obc, Ie_u_W_obc, js_u_W_obc, je_u_W_obc + integer :: Is_u_E_obc, Ie_u_E_obc, js_u_E_obc, je_u_E_obc + integer :: is_v_S_obc, ie_v_S_obc, Js_v_S_obc, Je_v_S_obc + integer :: is_v_N_obc, ie_v_N_obc, Js_v_N_obc, Je_v_N_obc + !>@} + type(remapping_CS), pointer :: remap_z_CS => NULL() !< ALE remapping control structure for + !! z-space data on segments + type(remapping_CS), pointer :: remap_h_CS => NULL() !< ALE remapping control structure for + !! thickness-based fields on segments type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries - real, allocatable :: rx_normal(:,:,:) !< Array storage for normal phase speed for EW radiation OBCs in units of - !! grid points per timestep [nondim] - real, allocatable :: ry_normal(:,:,:) !< Array storage for normal phase speed for NS radiation OBCs in units of - !! grid points per timestep [nondim] - real, allocatable :: rx_oblique_u(:,:,:) !< X-direction oblique boundary condition radiation speeds squared - !! at u points for restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: ry_oblique_u(:,:,:) !< Y-direction oblique boundary condition radiation speeds squared - !! at u points for restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: rx_oblique_v(:,:,:) !< X-direction oblique boundary condition radiation speeds squared - !! at v points for restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: ry_oblique_v(:,:,:) !< Y-direction oblique boundary condition radiation speeds squared - !! at v points for restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: cff_normal_u(:,:,:) !< Denominator for normalizing EW oblique boundary condition radiation - !! rates at u points for restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: cff_normal_v(:,:,:) !< Denominator for normalizing NS oblique boundary condition radiation - !! rates at v points for restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: tres_x(:,:,:,:) !< Array storage of tracer reservoirs for restarts, in unscaled units [conc] - real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts, in unscaled units [conc] - logical :: debug !< If true, write verbose checksums for debugging purposes. + real, allocatable :: rx_normal(:,:,:) !< Array storage for normal phase speed for EW radiation OBCs + !! in units of grid points per timestep [nondim] + real, allocatable :: ry_normal(:,:,:) !< Array storage for normal phase speed for NS radiation OBCs + !! in units of grid points per timestep [nondim] + real, allocatable :: rx_oblique_u(:,:,:) !< X-direction oblique boundary condition radiation speeds + !! squared at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: ry_oblique_u(:,:,:) !< Y-direction oblique boundary condition radiation speeds + !! squared at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: rx_oblique_v(:,:,:) !< X-direction oblique boundary condition radiation speeds + !! squared at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: ry_oblique_v(:,:,:) !< Y-direction oblique boundary condition radiation speeds + !! squared at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: cff_normal_u(:,:,:) !< Denominator for normalizing EW oblique boundary condition + !! radiation rates at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: cff_normal_v(:,:,:) !< Denominator for normalizing NS oblique boundary condition + !! radiation rates at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: tres_x(:,:,:,:) !< Array storage of tracer reservoirs for restarts, + !! in unscaled units [conc] + real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts, + !! in unscaled units [conc] + logical :: debug !< If true, write verbose checksums for debugging purposes. + integer :: nk_OBC_debug = 0 !< The number of layers of OBC segment data to write out + !! in full when DEBUG_OBCS is true. real :: silly_h !< A silly value of thickness outside of the domain that can be used to test !! the independence of the OBCs to this external data [Z ~> m]. real :: silly_u !< A silly value of velocity outside of the domain that can be used to test @@ -393,7 +414,12 @@ 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. + logical :: exterior_OBC_bug !< If true, use incorrect form of tracers exterior to OBCs. + logical :: hor_index_bug !< If true, recover set of a horizontal indexing bugs in the OBC code. + logical :: reservoir_init_bug !< If true, set the OBC tracer reservoirs at the startup of a new + !! run from the interior tracer concentrations regardless of + !! properties that may be explicitly specified for the reservoir + !! concentrations. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -431,11 +457,11 @@ module MOM_open_boundary contains !> Enables OBC module and reads configuration parameters -!> This routine is called from MOM_initialize_fixed which -!> occurs before the initialization of the vertical coordinate -!> and ALE_init. Therefore segment data are not fully initialized -!> here. The remainder of the segment data are initialized in a -!> later call to update_open_boundary_data +!! This routine is called from MOM_initialize_fixed which +!! occurs before the initialization of the vertical coordinate +!! and ALE_init. Therefore segment data are not fully initialized +!! here. The remainder of the segment data are initialized in a +!! later call to update_open_boundary_data subroutine open_boundary_config(G, US, param_file, OBC) type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -444,13 +470,17 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! Local variables integer :: l ! For looping over segments - logical :: debug, debug_OBC, mask_outside, reentrant_x, reentrant_y + logical :: debug, mask_outside, reentrant_x, reentrant_y character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: check_remapping, force_bounds_in_subcell + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: debugging_tests ! If true, do additional calls resetting values to help debug the performance + ! of the open boundary condition code. logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm ! This include declares and sets the variable "version". # include "version_variable.h" @@ -547,25 +577,42 @@ subroutine open_boundary_config(G, US, param_file, OBC) endif call get_param(param_file, mdl, "DEBUG", debug, default=.false.) - ! This extra get_param call is to enable logging if either DEBUG or DEBUG_OBC are true. - call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=debug) - call get_param(param_file, mdl, "DEBUG_OBC", OBC%debug, & + call get_param(param_file, mdl, "DEBUG_OBCS", OBC%debug, & "If true, do additional calls to help debug the performance "//& "of the open boundary condition code.", & - default=debug, do_not_log=.not.(debug_OBC.or.debug), debuggingParam=.true.) + default=.false., debuggingParam=.true.) + if (OBC%debug .and. (num_PEs() > 1)) & + call MOM_error(FATAL, "DEBUG_OBCS = True is currently only supported for single PE runs.") + call get_param(param_file, mdl, "OBC_DEBUGGING_TESTS", debugging_tests, & + "If true, do additional calls resetting certain values to help verify the correctness "//& + "of the open boundary condition code.", & + default=.false., old_name="DEBUG_OBC", debuggingParam=.true.) + call get_param(param_file, mdl, "NK_OBC_DEBUG", OBC%nk_OBC_debug, & + "The number of layers of OBC segment data to write out in full "//& + "when DEBUG_OBCS is true.", & + default=0, debuggingParam=.true., do_not_log=.not.OBC%debug) call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& "conditions for debugging.", units="m", default=0.0, scale=US%m_to_Z, & - do_not_log=.not.OBC%debug, debuggingParam=.true.) + do_not_log=.not.debugging_tests, debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & "A silly value of velocities used outside of open boundary "//& "conditions for debugging.", units="m/s", default=0.0, scale=US%m_s_to_L_T, & - do_not_log=.not.OBC%debug, debuggingParam=.true.) + do_not_log=.not.debugging_tests, debuggingParam=.true.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "EXTERIOR_OBC_BUG", OBC%exterior_OBC_bug, & "If true, recover a bug in barotropic solver and other routines when "//& "boundary contitions interior to the domain are used.", & - default=.true.) + default=enable_bugs) + call get_param(param_file, mdl, "OBC_HOR_INDEXING_BUG", OBC%hor_index_bug, & + "If true, recover set of a horizontal indexing bugs in the OBC code.", & + default=enable_bugs) + call get_param(param_file, mdl, "OBC_RESERVOIR_INIT_BUG", OBC%reservoir_init_bug, & + "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& + "interior tracer concentrations regardless of properties that may be explicitly "//& + "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.) reentrant_x = .false. call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) reentrant_y = .false. @@ -610,8 +657,10 @@ subroutine open_boundary_config(G, US, param_file, OBC) OBC%segment(l)%Velocity_nudging_timescale_out = 0.0 OBC%segment(l)%num_fields = 0 enddo - allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=OBC_NONE) - allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=OBC_NONE) + allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0) + allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=0) + OBC%u_OBCs_on_PE = .false. + OBC%v_OBCs_on_PE = .false. do l = 1, OBC%number_of_segments write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") l @@ -628,6 +677,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) endif enddo + ! Set arrays indicating the segment number and segment direction, and also store the + ! range of indices within which various orientations of OBCs can be found on this PE. + call set_segnum_signs(OBC, G) ! Moved this earlier because time_interp_external_init needs to be called ! before anything that uses time_interp_external (such as initialize_segment_data) @@ -741,42 +793,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) end subroutine open_boundary_config -!> Setup vertical remapping for open boundaries -subroutine open_boundary_setup_vert(GV, US, OBC) - type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - ! Local variables - real :: dz_neglect, dz_neglect_edge ! Small thicknesses in vertical height units [Z ~> m] - - if (associated(OBC)) then - if (OBC%number_of_segments > 0) then - if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then - dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 - elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then - dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 - else - dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff - endif - allocate(OBC%remap_z_CS) - call initialize_remapping(OBC%remap_z_CS, OBC%remappingScheme, boundary_extrapolation=.false., & - check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & - om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & - force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & - h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) - allocate(OBC%remap_h_CS) - call initialize_remapping(OBC%remap_h_CS, OBC%remappingScheme, boundary_extrapolation=.false., & - check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & - om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & - force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & - h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) - endif - endif - -end subroutine open_boundary_setup_vert - -!> Allocate space for reading OBC data from files. It sets up the required vertical +!> Set up vertical remapping and allocate space for reading OBC data from files. It sets up the required vertical !! remapping. In the process, it does funky stuff with the MPI processes. subroutine initialize_segment_data(G, GV, US, OBC, PF) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -791,11 +809,12 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) character(len=20) :: segnam, suffix character(len=32) :: fieldname real :: value ! A value that is parsed from the segment data string [various units] + real :: dz_neglect, dz_neglect_edge ! Small thicknesses in vertical height units [Z ~> m] character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list character(len=256) :: mesg ! Message for error messages. - integer, dimension(4) :: siz,siz2 + integer, dimension(4) :: siz integer :: is, ie, js, je integer :: isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB @@ -804,10 +823,34 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) integer, dimension(1) :: single_pelist type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>NULL() !will be able to dynamically switch between sub-sampling refined grid data or model grid - integer :: IO_needs(3) ! Sums to determine global OBC data use and update patterns. + integer :: IO_needs(2) ! Sums to determine global OBC data use and update patterns. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + if (OBC%number_of_segments > 0) then + ! Set up vertical remapping for open boundaries. Remapping happens independently on each PE, + ! so this block could be skipped for PEs without open boundary conditions that use remapping. + if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 + elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 + else + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + endif + allocate(OBC%remap_z_CS) + call initialize_remapping(OBC%remap_z_CS, OBC%remappingScheme, boundary_extrapolation=.false., & + check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & + om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & + force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) + allocate(OBC%remap_h_CS) + call initialize_remapping(OBC%remap_h_CS, OBC%remappingScheme, boundary_extrapolation=.false., & + check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & + om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & + force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) + endif + ! There is a problem with the order of the OBC initialization ! with respect to ALE_init. Currently handling this by copying the ! param file so that I can use it later in step_MOM in order to finish @@ -834,6 +877,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) do n=1, OBC%number_of_segments segment => OBC%segment(n) + ! segment%values_needed is only true if this segment is on the local PE and some values need to be read. if (.not. segment%values_needed) cycle write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n @@ -871,19 +915,21 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB obgc_segments_props_list => OBC%obgc_segments_props !pointer to the head node + do m=1,segment%num_fields if (m <= num_fields) then - !These are tracers with segments specified in MOM6 style override files + ! These are tracers with segments specified in MOM6 style override files call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname) + segment%field(m)%genre = '' else - !These are obgc tracers with segments specified by external modules. - !Set a flag so that these can be distinguished from native tracers as they may need - !extra steps for preparation and handling. + ! These are obgc tracers with segments specified by external modules. + ! Set a flag so that these can be distinguished from native tracers as they may need + ! extra steps for preparation and handling. segment%field(m)%genre = 'obgc' - !Query the obgc segment properties by traversing the linkedlist - call get_obgc_segments_props(obgc_segments_props_list,fields(m),filename,fieldname,& - segment%field(m)%resrv_lfac_in,segment%field(m)%resrv_lfac_out) - !Make sure the obgc tracer is not specified in the MOM6 param file too. + ! Query the obgc segment properties by traversing the linkedlist + call get_obgc_segments_props(obgc_segments_props_list, fields(m), filename, fieldname, & + segment%field(m)%resrv_lfac_in, segment%field(m)%resrv_lfac_out) + ! Make sure the obgc tracer is not specified in the MOM6 param file too. do mm=1,num_fields if (trim(fields(m)) == trim(fields(mm))) then if (is_root_pe()) & @@ -892,177 +938,76 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) endif enddo endif + + segment%field(m)%name = trim(fields(m)) + ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input + ! value is rescaled there. + segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) + segment%field(m)%on_face = field_is_on_face(fields(m), segment%is_E_or_W) + if (trim(filename) /= 'none') then OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data ! segment%values_needed = .true. ! Indicates that i/o will be needed for this segment - segment%field(m)%name = trim(fields(m)) - ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input - ! value is rescaled there. - segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) segment%field(m)%use_IO = .true. - if (segment%field(m)%name == 'TEMP') then - segment%temp_segment_data_exists = .true. - segment%t_values_needed = .false. - endif - if (segment%field(m)%name == 'SALT') then - segment%salt_segment_data_exists = .true. - segment%s_values_needed = .false. - endif + filename = trim(inputdir)//trim(filename) fieldname = trim(fieldname)//trim(suffix) - call field_size(filename,fieldname,siz,no_domain=.true.) + 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) - call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) - call MOM_error(FATAL,'segment data are not on the supergrid') - endif - siz2(1) = 1 - if (siz(1)>1) then - if (OBC%brushcutter_mode) then - siz2(1) = (siz(1)-1)/2 - else - siz2(1) = siz(1) - endif - endif - siz2(2) = 1 - if (siz(2)>1) then - if (OBC%brushcutter_mode) then - siz2(2) = (siz(2)-1)/2 - else - siz2(2) = siz(2) - endif - endif - siz2(3) = siz(3) + 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) + call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) + call MOM_error(FATAL,'segment data are not on the supergrid') + endif - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%v_values_needed = .false. - elseif (segment%field(m)%name == 'Vamp') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%vamp_values_needed = .false. - segment%vamp_index = m - elseif (segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%vphase_values_needed = .false. - segment%vphase_index = m - elseif (segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%g_values_needed = .false. - else - allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz2(3))) - if (segment%field(m)%name == 'U') then - segment%u_values_needed = .false. - elseif (segment%field(m)%name == 'Uamp') then - segment%uamp_values_needed = .false. - segment%uamp_index = m - elseif (segment%field(m)%name == 'Uphase') then - segment%uphase_values_needed = .false. - segment%uphase_index = m - elseif (segment%field(m)%name == 'SSH') then - segment%z_values_needed = .false. - elseif (segment%field(m)%name == 'SSHamp') then - segment%zamp_values_needed = .false. - segment%zamp_index = m - elseif (segment%field(m)%name == 'SSHphase') then - segment%zphase_values_needed = .false. - segment%zphase_index = m - elseif (segment%field(m)%name == 'TEMP') then - segment%t_values_needed = .false. - elseif (segment%field(m)%name == 'SALT') then - segment%s_values_needed = .false. - endif + if (.not.segment%field(m)%on_face) then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz(3)), source=0.0) + elseif (segment%is_E_or_W) then + allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz(3)), source=0.0) + else + allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz(3)), source=0.0) + endif + + segment%field(m)%handle = init_external_field(trim(filename), trim(fieldname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) + if (siz(3) > 1) then + if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then + ! siz(3) is constituent for tidal variables + call field_size(filename, 'constituent', siz, no_domain=.true.) + ! expect third dimension to be number of constituents in MOM_input + if (siz(3) /= OBC%n_tide_constituents .and. OBC%add_tide_constituents) then + call MOM_error(FATAL, 'Number of constituents in input data is not '//& + 'the same as the number specified') endif else - if (segment%field(m)%name == 'U') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%u_values_needed = .false. - elseif (segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%g_values_needed = .false. - elseif (segment%field(m)%name == 'Uamp') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%uamp_values_needed = .false. - segment%uamp_index = m - elseif (segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%uphase_values_needed = .false. - segment%uphase_index = m + ! siz(3) is depth for everything else + fieldname = 'dz_'//trim(fieldname) + call field_size(filename, fieldname, siz, no_domain=.true.) + + if (.not.segment%field(m)%on_face) then + allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3)), source=0.0) + elseif (segment%is_E_or_W) then + allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3)), source=0.0) else - allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz2(3))) - if (segment%field(m)%name == 'V') then - segment%v_values_needed = .false. - elseif (segment%field(m)%name == 'Vamp') then - segment%vamp_values_needed = .false. - segment%vamp_index = m - elseif (segment%field(m)%name == 'Vphase') then - segment%vphase_values_needed = .false. - segment%vphase_index = m - elseif (segment%field(m)%name == 'SSH') then - segment%z_values_needed = .false. - elseif (segment%field(m)%name == 'SSHamp') then - segment%zamp_values_needed = .false. - segment%zamp_index = m - elseif (segment%field(m)%name == 'SSHphase') then - segment%zphase_values_needed = .false. - segment%zphase_index = m - elseif (segment%field(m)%name == 'TEMP') then - segment%t_values_needed = .false. - elseif (segment%field(m)%name == 'SALT') then - segment%s_values_needed = .false. - endif + allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3)), source=0.0) endif + segment%field(m)%dz_handle = init_external_field(trim(filename), trim(fieldname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) endif - segment%field(m)%buffer_src(:,:,:) = 0.0 - segment%field(m)%handle = init_external_field(trim(filename), trim(fieldname), & - ignore_axis_atts=.true., threading=SINGLE_FILE) - if (siz(3) > 1) then - if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then - ! siz(3) is constituent for tidal variables - call field_size(filename, 'constituent', siz, no_domain=.true.) - ! expect third dimension to be number of constituents in MOM_input - if (siz(3) /= OBC%n_tide_constituents .and. OBC%add_tide_constituents) then - call MOM_error(FATAL, 'Number of constituents in input data is not '//& - 'the same as the number specified') - endif - segment%field(m)%nk_src=siz(3) - else - ! siz(3) is depth for everything else - fieldname = 'dz_'//trim(fieldname) - call field_size(filename,fieldname,siz,no_domain=.true.) - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) - else - allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3))) - endif - else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) - else - allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) - endif - endif - segment%field(m)%dz_src(:,:,:) = 0.0 - segment%field(m)%nk_src=siz(3) - segment%field(m)%dz_handle = init_external_field(trim(filename), trim(fieldname), & - ignore_axis_atts=.true., threading=SINGLE_FILE) - endif - else - segment%field(m)%nk_src=1 - endif + segment%field(m)%nk_src = siz(3) + else + segment%field(m)%nk_src = 1 endif - else - segment%field(m)%name = trim(fields(m)) - ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input - ! value is rescaled there. - segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) + + if (segment%field(m)%name == 'TEMP') segment%temp_segment_data_exists = .true. + if (segment%field(m)%name == 'SALT') segment%salt_segment_data_exists = .true. + + else ! This data is not being read from a file. segment%field(m)%value = segment%field(m)%scale * value segment%field(m)%use_IO = .false. @@ -1074,39 +1019,34 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) 'tidal boundary conditions by value rather than file.') endif endif - if (segment%field(m)%name == 'U') then - segment%u_values_needed = .false. - elseif (segment%field(m)%name == 'Uamp') then - segment%uamp_values_needed = .false. - segment%uamp_index = m - elseif (segment%field(m)%name == 'Uphase') then - segment%uphase_values_needed = .false. - segment%uphase_index = m - elseif (segment%field(m)%name == 'V') then - segment%v_values_needed = .false. - elseif (segment%field(m)%name == 'Vamp') then - segment%vamp_values_needed = .false. - segment%vamp_index = m - elseif (segment%field(m)%name == 'Vphase') then - segment%vphase_values_needed = .false. - segment%vphase_index = m - elseif (segment%field(m)%name == 'SSH') then - segment%z_values_needed = .false. - elseif (segment%field(m)%name == 'SSHamp') then - segment%zamp_values_needed = .false. - segment%zamp_index = m - elseif (segment%field(m)%name == 'SSHphase') then - segment%zphase_values_needed = .false. - segment%zphase_index = m - elseif (segment%field(m)%name == 'TEMP') then - segment%t_values_needed = .false. - elseif (segment%field(m)%name == 'SALT') then - segment%s_values_needed = .false. - elseif (segment%field(m)%name == 'DVDX' .or. segment%field(m)%name == 'DUDY') then - segment%g_values_needed = .false. - endif endif + + ! Check on which values this field is providing. + if (segment%field(m)%name == 'TEMP') segment%t_values_needed = .false. + if (segment%field(m)%name == 'SALT') segment%s_values_needed = .false. + if (segment%field(m)%name == 'U') segment%u_values_needed = .false. + if (segment%field(m)%name == 'V') segment%v_values_needed = .false. + if (segment%field(m)%name == 'SSH') segment%z_values_needed = .false. + if ((segment%is_N_or_S .and. segment%field(m)%name == 'DUDY') .or. & + (segment%is_E_or_W .and. segment%field(m)%name == 'DVDX')) segment%g_values_needed = .false. + if (segment%field(m)%name == 'Uamp') segment%uamp_values_needed = .false. + if (segment%field(m)%name == 'Uphase') segment%uphase_values_needed = .false. + if (segment%field(m)%name == 'Vamp') segment%vamp_values_needed = .false. + if (segment%field(m)%name == 'Vphase') segment%vphase_values_needed = .false. + if (segment%field(m)%name == 'SSHamp') segment%zamp_values_needed = .false. + if (segment%field(m)%name == 'SSHphase') segment%zphase_values_needed = .false. + + ! Store the field number for later retrievals. + if (segment%field(m)%name == 'Uamp') segment%uamp_index = m + if (segment%field(m)%name == 'Uphase') segment%uphase_index = m + if (segment%field(m)%name == 'Vamp') segment%vamp_index = m + if (segment%field(m)%name == 'Vphase') segment%vphase_index = m + if (segment%field(m)%name == 'SSHamp') segment%zamp_index = m + if (segment%field(m)%name == 'SSHphase') segment%zphase_index = m + enddo + + ! Check for any values that have not been provided. if (segment%u_values_needed .or. segment%uamp_values_needed .or. segment%uphase_values_needed .or. & segment%v_values_needed .or. segment%vamp_values_needed .or. segment%vphase_values_needed .or. & segment%t_values_needed .or. segment%s_values_needed .or. segment%g_values_needed .or. & @@ -1121,14 +1061,109 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) ! Determine global IO data requirement patterns. IO_needs(1) = 0 ; if (OBC%needs_IO_for_data) IO_needs(1) = 1 IO_needs(2) = 0 ; if (OBC%update_OBC) IO_needs(2) = 1 - IO_needs(3) = 0 ; if (.not.OBC%needs_IO_for_data) IO_needs(3) = 1 - call sum_across_PES(IO_needs, 3) + call sum_across_PES(IO_needs, 2) OBC%any_needs_IO_for_data = (IO_needs(1) > 0) OBC%update_OBC = (IO_needs(2) > 0) - OBC%some_need_no_IO_for_data = (IO_needs(3) > 0) end subroutine initialize_segment_data +!> Determine whether a particular field is descretized at the normal-velocity faces of an open +!! boundary condition segment. +logical function field_is_on_face(name, is_E_or_W) + character(len=*), intent(in) :: name !< The OBC segment data name to interpret + logical, intent(in) :: is_E_or_W !< This is true for an eastern or western open boundary condition + + field_is_on_face = .true. + if (is_E_or_W) then + if ((name == 'V') .or. (name == 'Vamp') .or. (name == 'Vphase') .or. (name == 'DVDX')) & + field_is_on_face = .false. + else + if ((name == 'U') .or. (name == 'Uamp') .or. (name == 'Uphase') .or. (name == 'DUDY')) & + field_is_on_face = .false. + endif +end function field_is_on_face + +!> Determine based on its name whether a particular field a barotropic tidal field, for which the +!! third dimension is the tidal constituent rather than a vertical axis +logical function field_is_tidal(name) + character(len=*), intent(in) :: name !< The OBC segment data name to interpret + + field_is_tidal = ((index(name, 'phase') > 0) .or. (index(name, 'amp') > 0)) +end function field_is_tidal + +!> This subroutine sets the sign of the OBC%segnum_u and OBC%segnum_v arrays to indicate the +!! direction of the faces - positive for logically eastern or northern OBCs and neagative +!! for logically western or southern OBCs, or zero on non-OBC points. Also store information +!! about which orientations of OBCs ar on this PE and the range of indices within which the +!! various orientations of OBCs can be found on this PE. +subroutine set_segnum_signs(OBC, G) + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure, perhaps on a rotated grid. + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure used by OBC + + integer :: i, j + + OBC%u_OBCs_on_PE = .false. ; OBC%v_OBCs_on_PE = .false. + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + OBC%segnum_u(I,j) = abs(OBC%segnum_u(I,j)) + if (abs(OBC%segnum_u(I,j)) > 0) then + OBC%u_OBCs_on_PE = .true. + if (OBC%segment(abs(OBC%segnum_u(I,j)))%direction == OBC_DIRECTION_W) & + OBC%segnum_u(I,j) = -abs(OBC%segnum_u(I,j)) + endif + enddo ; enddo + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + OBC%segnum_v(i,J) = abs(OBC%segnum_v(i,J)) + if (abs(OBC%segnum_v(i,J)) > 0) then + OBC%v_OBCs_on_PE = .true. + if (OBC%segment(abs(OBC%segnum_v(i,J)))%direction == OBC_DIRECTION_S) & + OBC%segnum_v(i,J) = -abs(OBC%segnum_v(i,J)) + endif + enddo ; enddo + + ! Determine the maximum and minimum index range for various directions of OBC points on this PE + ! by first setting these one point outside of the wrong side of the domain. + OBC%Is_u_W_obc = G%IedB + 1 ; OBC%Ie_u_W_obc = G%IsdB - 1 + OBC%js_u_W_obc = G%jed + 1 ; OBC%je_u_W_obc = G%jsd - 1 + OBC%Is_u_E_obc = G%IedB + 1 ; OBC%Ie_u_E_obc = G%IsdB - 1 + OBC%js_u_E_obc = G%jed + 1 ; OBC%je_u_E_obc = G%jsd - 1 + OBC%is_v_S_obc = G%ied + 1 ; OBC%ie_v_S_obc = G%isd - 1 + OBC%Js_v_S_obc = G%JedB + 1 ; OBC%Je_v_S_obc = G%JsdB - 1 + OBC%is_v_N_obc = G%ied + 1 ; OBC%ie_v_N_obc = G%isd - 1 + OBC%Js_v_N_obc = G%JedB + 1 ; OBC%Je_v_N_obc = G%JsdB - 1 + OBC%v_N_OBCs_on_PE = .false. ; OBC%v_S_OBCs_on_PE = .false. + OBC%u_E_OBCs_on_PE = .false. ; OBC%u_W_OBCs_on_PE = .false. + ! Note that the loop ranges are reduced because outward facing OBCs can not be applied at edge points. + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB-1 + if (OBC%segnum_u(I,j) < 0) then ! This point has OBC_DIRECTION_W. + OBC%Is_u_W_obc = min(I, OBC%Is_u_W_obc) ; OBC%Ie_u_W_obc = max(I, OBC%Ie_u_W_obc) + OBC%js_u_W_obc = min(j, OBC%js_u_W_obc) ; OBC%je_u_W_obc = max(j, OBC%je_u_W_obc) + OBC%u_W_OBCs_on_PE = .true. + endif + enddo ; enddo + do j=G%jsd,G%jed ; do I=G%IsdB+1,G%IedB + if (OBC%segnum_u(I,j) > 0) then ! This point has OBC_DIRECTION_E. + OBC%Is_u_E_obc = min(I, OBC%Is_u_E_obc) ; OBC%Ie_u_E_obc = max(I, OBC%Ie_u_E_obc) + OBC%js_u_E_obc = min(j, OBC%js_u_E_obc) ; OBC%je_u_E_obc = max(j, OBC%je_u_E_obc) + OBC%u_E_OBCs_on_PE = .true. + endif + enddo ; enddo + do J=G%JsdB,G%JedB-1 ; do i=G%isd,G%ied + if (OBC%segnum_v(i,J) < 0) then ! This point has OBC_DIRECTION_S. + OBC%is_v_S_obc = min(i, OBC%is_v_S_obc) ; OBC%ie_v_S_obc = max(i, OBC%ie_v_S_obc) + OBC%Js_v_S_obc = min(J, OBC%Js_v_S_obc) ; OBC%Je_v_S_obc = max(J, OBC%Je_v_S_obc) + OBC%v_S_OBCs_on_PE = .true. + endif + enddo ; enddo + do J=G%JsdB+1,G%JedB ; do i=G%isd,G%ied + if (OBC%segnum_v(i,J) > 0) then ! This point has OBC_DIRECTION_N. + OBC%is_v_N_obc = min(i, OBC%is_v_N_obc) ; OBC%ie_v_N_obc = max(i, OBC%ie_v_N_obc) + OBC%Js_v_N_obc = min(J, OBC%Js_v_N_obc) ; OBC%Je_v_N_obc = max(J, OBC%Je_v_N_obc) + OBC%v_N_OBCs_on_PE = .true. + endif + enddo ; enddo + +end subroutine set_segnum_signs + !> Return an appropriate dimensional scaling factor for input data based on an OBC segment data !! name [various ~> 1], or 1 for tracers or other fields that do not match one of the specified names. !! Note that calls to register_segment_tracer can come before or after calls to scale_factor_from_name. @@ -1266,7 +1301,7 @@ subroutine initialize_obc_tides(OBC, US, param_file) end subroutine initialize_obc_tides !> Define indices for segment and store in hor_index_type -!> using global segment bounds corresponding to q-points +!! using global segment bounds corresponding to q-points subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) type(dyn_horgrid_type), intent(in) :: G !< grid type type(OBC_segment_type), intent(inout) :: seg !< Open boundary segment @@ -1275,7 +1310,7 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) integer, intent(in) :: Js_obc !< Q-point global j-index of start of segment integer, intent(in) :: Je_obc !< Q-point global j-index of end of segment ! Local variables - integer :: IsgB, IegB, JsgB, JegB + integer :: IsgB, IegB, JsgB, JegB ! Global corner point indices at the ends of the OBC segments integer :: isg, ieg, jsg, jeg ! Isg, Ieg will be I*_obc in global space @@ -1416,7 +1451,7 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) OBC%segment(l_seg)%direction = OBC_DIRECTION_E elseif (Je_obcJs_obc .and. j<=Je_obc) then OBC%segnum_u(I_obc,j) = l_seg + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) OBC%segnum_u(I_obc,j) = -l_seg + OBC%u_OBCs_on_PE = .true. endif enddo OBC%segment(l_seg)%Is_obc = I_obc @@ -1649,6 +1686,8 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) do i=G%HI%isd, G%HI%ied if (i>Is_obc .and. i<=Ie_obc) then OBC%segnum_v(i,J_obc) = l_seg + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) OBC%segnum_v(i,J_obc) = -l_seg + OBC%v_OBCs_on_PE = .true. endif enddo OBC%segment(l_seg)%Is_obc = Is_obc @@ -1680,6 +1719,7 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ ! Local variables character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of !! "I=%,J=%:%,string" + character(len=3) :: max_words !< maximum number of OBC types per segment integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J=" integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J=" integer :: j @@ -1745,6 +1785,14 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ "Range in string '"//trim(segment_str)//"' must span one cell.") endif + ! checking if the number of provided OBC types is less than or equal to 8 + if (extract_word(segment_str,',',3+size(action_str))/="") then + write(max_words, '(I3)') size(action_str) + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "// & + "Number of OBC descriptor words in '" // trim(segment_str) // "' is too large. " // & + "There can be at most " // trim(adjustl(max_words)) // " descriptor words.") + endif + ! Type of open boundary condition do j = 1, size(action_str) action_str(j) = extract_word(segment_str,',',2+j) @@ -1921,11 +1969,11 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) !This logic assumes all external tarcers need a reservoir !The segments for tracers are not initialized yet (that happens later in initialize_segment_data()) !so we cannot query to determine if this tracer needs a reservoir. - if (segment%is_E_or_W_2) then + if (segment%is_E_or_W_2) then OBC%tracer_x_reservoirs_used(m+na) = .true. - else + else OBC%tracer_y_reservoirs_used(m+na) = .true. - endif + endif enddo enddo @@ -1933,21 +1981,13 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) end subroutine parse_for_tracer_reservoirs -!> Initialize open boundary control structure and do any necessary rescaling of OBC -!! fields that have been read from a restart file. -subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) +!> Do any necessary halo updates on OBC-related fields. +subroutine open_boundary_halo_update(G, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< Parameter file handle type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(MOM_restart_CS), intent(in) :: restart_CS !< Restart structure, data intent(inout) ! Local variables - integer :: i, j, k, isd, ied, jsd, jed, nz, m - integer :: IsdB, IedB, JsdB, JedB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + integer :: m if (.not.associated(OBC)) return @@ -1977,7 +2017,7 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) enddo endif -end subroutine open_boundary_init +end subroutine open_boundary_halo_update logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, & apply_nudged_OBC, needs_ext_seg_data) @@ -2097,14 +2137,14 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) if (.not.associated(OBC)) return do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%is_E_or_W) then ! Sweep along u-segments and delete the OBC for blocked points. ! Also, mask all points outside. I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - if (G%mask2dCu(I,j) == 0) OBC%segnum_u(I,j) = OBC_NONE + if (G%mask2dCu(I,j) == 0) OBC%segnum_u(I,j) = 0 if (segment%direction == OBC_DIRECTION_W) then G%mask2dT(i,j) = 0.0 else @@ -2122,7 +2162,7 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) ! Sweep along v-segments and delete the OBC for blocked points. J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - if (G%mask2dCv(i,J) == 0) OBC%segnum_v(i,J) = OBC_NONE + if (G%mask2dCv(i,J) == 0) OBC%segnum_v(i,J) = 0 if (segment%direction == OBC_DIRECTION_S) then G%mask2dT(i,j) = 0.0 else @@ -2194,65 +2234,115 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) if (segment%is_E_or_W) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - if (OBC%segnum_u(I,j) /= OBC_NONE) any_U = .true. + if (OBC%segnum_u(I,j) /= 0) any_U = .true. enddo else J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - if (OBC%segnum_v(i,J) /= OBC_NONE) any_V = .true. + if (OBC%segnum_v(i,J) /= 0) any_V = .true. enddo endif enddo - OBC%OBC_pe = .true. - if (.not.(any_U .or. any_V)) OBC%OBC_pe = .false. + OBC%u_OBCs_on_PE = any_U + OBC%v_OBCs_on_PE = any_V + OBC%OBC_pe = (any_U .or. any_V) end subroutine open_boundary_impose_land_mask -!> Make sure the OBC tracer reservoirs are initialized. -subroutine setup_OBC_tracer_reservoirs(G, GV, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure +!> Initialize the tracer reservoirs values, perhaps only if they have not been set via a restart file. +subroutine setup_OBC_tracer_reservoirs(G, GV, OBC, restart_CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure + type(MOM_restart_CS), optional, intent(in) :: restart_CS !< MOM restart control structure + ! Local variables type(OBC_segment_type), pointer :: segment => NULL() real :: I_scale ! The inverse of the scaling factor for the tracers. ! For salinity the units would be [ppt S-1 ~> 1] + logical :: set_tres_x, set_tres_y + character(len=12) :: x_var_name, y_var_name integer :: i, j, k, m, n - do n=1,OBC%number_of_segments - segment=>OBC%segment(n) - if (associated(segment%tr_Reg)) then - if (segment%is_E_or_W) then - I = segment%HI%IsdB - do m=1,OBC%ntr - 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,GV%ke - do j=segment%HI%jsd,segment%HI%jed - OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,j,k) - enddo - enddo - endif - enddo + do m=1,OBC%ntr + + set_tres_x = allocated(OBC%tres_x) .and. OBC%tracer_x_reservoirs_used(m) + set_tres_y = allocated(OBC%tres_y) .and. OBC%tracer_y_reservoirs_used(m) + + if (present(restart_CS)) then + ! Set the names of the reservoirs for this tracer in the restart file, and inquire whether + ! they have been initialized + if (modulo(G%HI%turns, 2) == 0) then + write(x_var_name,'("tres_x_",I3.3)') m + write(y_var_name,'("tres_y_",I3.3)') m else - J = segment%HI%JsdB - do m=1,OBC%ntr - 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,GV%ke - do i=segment%HI%isd,segment%HI%ied - OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,J,k) - enddo - enddo - endif - enddo + write(x_var_name,'("tres_y_",I3.3)') m + write(y_var_name,'("tres_x_",I3.3)') m endif + if (set_tres_x) set_tres_x = .not.query_initialized(OBC%tres_x, x_var_name, restart_CS) + if (set_tres_y) set_tres_y = .not.query_initialized(OBC%tres_y, y_var_name, restart_CS) endif + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (associated(segment%tr_Reg)) then ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + + if (segment%is_E_or_W .and. set_tres_x) then + I = segment%HI%IsdB + if (segment%tr_Reg%Tr(m)%is_initialized) then + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,j,k) + enddo ; enddo + else + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,j,k) + enddo ; enddo + endif + elseif (segment%is_N_or_S .and. set_tres_y) then + J = segment%HI%JsdB + if (segment%tr_Reg%Tr(m)%is_initialized) then + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; enddo + else + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,J,k) + enddo ; enddo + endif + endif + endif ; endif + enddo enddo end subroutine setup_OBC_tracer_reservoirs +!> Record that the tracer reservoirs have been initialized so that their values are not reset later. +subroutine set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(ocean_OBC_type), intent(in) :: OBC !< Open boundary control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + character(len=12) :: x_var_name, y_var_name + integer :: i, j, k, m, n + + do m=1,OBC%ntr + ! Set the names of the reservoirs for this tracer in the restart file + if (modulo(G%HI%turns, 2) == 0) then + write(x_var_name,'("tres_x_",I3.3)') m + write(y_var_name,'("tres_y_",I3.3)') m + else + write(x_var_name,'("tres_y_",I3.3)') m + write(y_var_name,'("tres_x_",I3.3)') m + endif + + if (OBC%tracer_x_reservoirs_used(m)) call set_initialized(OBC%tres_x, x_var_name, restart_CS) + if (OBC%tracer_y_reservoirs_used(m)) call set_initialized(OBC%tres_y, y_var_name, restart_CS) + enddo + +end subroutine set_initialized_OBC_tracer_reservoirs + + !> Apply radiation conditions to 3D u,v at open boundaries subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dt) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure @@ -2303,6 +2393,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (.not.(OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) & return + if (OBC%debug) call chksum_OBC_segments(OBC, G, GV, US, OBC%nk_OBC_debug) + + eps = 1.0e-20*US%m_s_to_L_T**2 !! Copy previously calculated phase velocity from global arrays into segments @@ -3373,23 +3466,23 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, sym = G%Domain%symmetric if (OBC%radiation_BCs_exist_globally) then call uvchksum("radiation_OBCs: OBC%r[xy]_normal", OBC%rx_normal, OBC%ry_normal, G%HI, & - haloshift=0, symmetric=sym, unscale=1.0) + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0) endif if (OBC%oblique_BCs_exist_globally) then call uvchksum("radiation_OBCs: OBC%r[xy]_oblique_[uv]", OBC%rx_oblique_u, OBC%ry_oblique_v, G%HI, & - haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/US%L_T_to_m_s**2) call uvchksum("radiation_OBCs: OBC%r[yx]_oblique_[uv]", OBC%ry_oblique_u, OBC%rx_oblique_v, G%HI, & - haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/US%L_T_to_m_s**2) call uvchksum("radiation_OBCs: OBC%cff_normal_[uv]", OBC%cff_normal_u, OBC%cff_normal_v, G%HI, & - haloshift=0, symmetric=sym, unscale=1.0/US%L_T_to_m_s**2) + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/US%L_T_to_m_s**2) + endif + if ((OBC%ntr > 0) .and. allocated(OBC%tres_x) .and. allocated(OBC%tres_y)) then + do m=1,OBC%ntr + write(var_num,'(I3.3)') m + call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%HI, & + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0) + enddo endif - if (OBC%ntr == 0) return - if (.not. allocated (OBC%tres_x) .or. .not. allocated (OBC%tres_y)) return - do m=1,OBC%ntr - write(var_num,'(I3.3)') m - call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%HI, & - haloshift=0, symmetric=sym, unscale=1.0) - enddo endif end subroutine radiation_open_bdry_conds @@ -3588,60 +3681,8 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) end subroutine gradient_at_q_points -!> Sets the initial values of the tracer open boundary conditions. -!! Redoing this elsewhere. -subroutine set_tracer_data(OBC, tv, h, G, GV, PF) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ocean_OBC_type), target, intent(in) :: OBC !< Open boundary structure - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(param_file_type), intent(in) :: PF !< Parameter file handle - - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - integer :: i, j, k, n - - ! For now, there are no radiation conditions applied to the thicknesses, since - ! the thicknesses might not be physically motivated. Instead, sponges should be - ! used to enforce the near-boundary layer structure. - - if (associated(tv%T)) then - - call pass_var(tv%T, G%Domain) - call pass_var(tv%S, G%Domain) - - do n=1,OBC%number_of_segments - segment => OBC%segment(n) - if (.not. segment%on_pe) cycle - - if (segment%direction == OBC_DIRECTION_E) then - I=segment%HI%IsdB - do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed - tv%T(i+1,j,k) = tv%T(i,j,k) ; tv%S(i+1,j,k) = tv%S(i,j,k) - enddo ; enddo - elseif (segment%direction == OBC_DIRECTION_W) then - I=segment%HI%IsdB - do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed - tv%T(i,j,k) = tv%T(i+1,j,k) ; tv%S(i,j,k) = tv%S(i+1,j,k) - enddo ; enddo - elseif (segment%direction == OBC_DIRECTION_N) then - J=segment%HI%JsdB - do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied - tv%T(i,j+1,k) = tv%T(i,j,k) ; tv%S(i,j+1,k) = tv%S(i,j,k) - enddo ; enddo - elseif (segment%direction == OBC_DIRECTION_S) then - J=segment%HI%JsdB - do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied - tv%T(i,j,k) = tv%T(i,j+1,k) ; tv%S(i,j,k) = tv%S(i,j+1,k) - enddo ; enddo - endif - enddo - endif - -end subroutine set_tracer_data - -!> Needs documentation -function lookup_seg_field(OBC_seg,field) +!> Return the field number on the segment for the named field, or -1 if there is no field with that name. +function lookup_seg_field(OBC_seg, field) type(OBC_segment_type), intent(in) :: OBC_seg !< OBC segment character(len=32), intent(in) :: field !< The field name integer :: lookup_seg_field @@ -3663,16 +3704,15 @@ function get_tracer_index(OBC_seg,tr_name) type(OBC_segment_type), pointer :: OBC_seg !< OBC segment character(len=*), intent(in) :: tr_name !< The field name integer :: get_tracer_index, it - get_tracer_index=-1 - it=1 + get_tracer_index = -1 + it = 1 do while(allocated(OBC_seg%tr_Reg%Tr(it)%t)) if (trim(OBC_seg%tr_Reg%Tr(it)%name) == trim(tr_name)) then - get_tracer_index=it + get_tracer_index = it exit endif - it=it+1 + it = it + 1 enddo - return end function get_tracer_index !> Allocate segment data fields @@ -3697,7 +3737,9 @@ subroutine allocate_OBC_segment_data(OBC, segment) ! If these are just Flather, change update_OBC_segment_data accordingly allocate(segment%Cg(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%Htot(IsdB:IedB,jsd:jed), source=0.0) - allocate(segment%dZtot(IsdB:IedB,jsd:jed), source=0.0) + ! Allocate dZtot with extra values at the end to avoid segmentation faults in cases where + ! it is interpolated to OBC vorticity points. + allocate(segment%dZtot(IsdB:IedB,jsd-1:jed+1), source=0.0) allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0) if (segment%radiation) & @@ -3733,7 +3775,9 @@ subroutine allocate_OBC_segment_data(OBC, segment) ! If these are just Flather, change update_OBC_segment_data accordingly allocate(segment%Cg(isd:ied,JsdB:JedB), source=0.0) allocate(segment%Htot(isd:ied,JsdB:JedB), source=0.0) - allocate(segment%dZtot(isd:ied,JsdB:JedB), source=0.0) + ! Allocate dZtot with extra values at the end to avoid segmentation faults in cases where + ! it is interpolated to OBC vorticity points. + allocate(segment%dZtot(isd-1:ied+1,JsdB:JedB), source=0.0) allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0) if (segment%radiation) & @@ -3899,9 +3943,10 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< Model time + ! Local variables integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB, n, m, nz, nt + integer :: IsdB, IedB, JsdB, JedB, n, m, nz, nt, nk_dst type(OBC_segment_type), pointer :: segment => NULL() integer, dimension(4) :: siz real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input [various units] @@ -3909,32 +3954,35 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain integer :: ishift, jshift ! offsets for staggered locations - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Distance between the interfaces around a layer [Z ~> m] real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] real, dimension(:), allocatable :: dz_stack ! Distance between the interfaces at corner points [Z ~> m] integer :: is_obc2, js_obc2 - integer :: i_seg_offset, j_seg_offset + integer :: i_seg_offset, j_seg_offset, bug_offset real :: net_dz_src ! Total vertical extent of the incoming flow in the source field [Z ~> m] real :: net_dz_int ! Total vertical extent of the incoming flow in the model [Z ~> m] real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim] real :: tidal_vel ! Interpolated tidal velocity at the OBC points [L T-1 ~> m s-1] real :: tidal_elev ! Interpolated tidal elevation at the OBC points [Z ~> m] + real :: ramp_value ! If OBC%ramp is True, where we are on the ramp from 0 to 1, or 1 otherwise [nondim]. real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] integer :: turns ! Number of index quarter turns real :: time_delta ! Time since tidal reference date [T ~> s] + logical :: flip_buffer ! If true, the input buffer needs to be transposed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB nz=GV%ke - turns = G%HI%turns + turns = modulo(G%HI%turns, 4) if (.not. associated(OBC)) return if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref) if (OBC%number_of_segments >= 1) then + dz(:,:,:) = 0.0 call thickness_to_dz(h, tv, dz, G, GV, US) call pass_var(dz, G%Domain) endif @@ -3944,7 +3992,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (.not. segment%on_pe) cycle ! continue to next segment if not in computational domain - ! NOTE: These are in segment%HI, but defined slightly differently + ! NOTE: segment%is_obc and segment%ie_obc are range of indices for the full segment. + ! The other data set here are in segment%HI, but here they defined slightly differently. ni_seg = segment%ie_obc-segment%is_obc+1 nj_seg = segment%je_obc-segment%js_obc+1 is_obc = max(segment%is_obc,isd-1) @@ -3963,34 +4012,38 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! i2 has to start at Is_obc+1 and end at Ie_obc. ! j2 is J_obc and jshift has to be +1 at both the north and south. - ! calculate auxiliary fields at staggered locations - ishift=0;jshift=0 + ! calculate auxiliary fields at staggered locations + ishift = 0 ; jshift = 0 + segment%Htot(:,:) = 0.0 + segment%dZtot(:,:) = 0.0 if (segment%is_E_or_W) then allocate(normal_trans_bt(segment%HI%IsdB:segment%HI%IedB,segment%HI%jsd:segment%HI%jed), source=0.0) if (segment%direction == OBC_DIRECTION_W) ishift=1 I=segment%HI%IsdB + ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points + do k=1,GV%ke ; do j = max(segment%HI%jsd-1,G%jsd), min(segment%HI%jed+1,G%jed) + segment%dZtot(I,j) = segment%dZtot(I,j) + dz(i+ishift,j,k) + enddo ; enddo + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + segment%h(I,j,k) = h(i+ishift,j,k) + segment%Htot(I,j) = segment%Htot(I,j) + segment%h(I,j,k) + enddo ; enddo do j=segment%HI%jsd,segment%HI%jed - segment%Htot(I,j) = 0.0 - segment%dZtot(I,j) = 0.0 - do k=1,GV%ke - segment%h(I,j,k) = h(i+ishift,j,k) - segment%Htot(I,j) = segment%Htot(I,j) + segment%h(I,j,k) - segment%dZtot(I,j) = segment%dZtot(I,j) + dz(i+ishift,j,k) - enddo segment%Cg(I,j) = sqrt(GV%g_prime(1) * max(0.0, segment%dZtot(I,j))) enddo - else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) + else ! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB), source=0.0) if (segment%direction == OBC_DIRECTION_S) jshift=1 J=segment%HI%JsdB + ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points + do k=1,GV%ke ; do i = max(segment%HI%isd-1,G%isd), min(segment%HI%ied+1,G%ied) + segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,j+jshift,k) + enddo ; enddo + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + segment%h(i,J,k) = h(i,j+jshift,k) + segment%Htot(i,J) = segment%Htot(i,J) + segment%h(i,J,k) + enddo ; enddo do i=segment%HI%isd,segment%HI%ied - segment%Htot(i,J) = 0.0 - segment%dZtot(i,J) = 0.0 - do k=1,GV%ke - segment%h(i,J,k) = h(i,j+jshift,k) - segment%Htot(i,J) = segment%Htot(i,J) + segment%h(i,J,k) - segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,j+jshift,k) - enddo segment%Cg(i,J) = sqrt(GV%g_prime(1) * max(0.0, segment%dZtot(i,J))) enddo endif @@ -4007,48 +4060,17 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) siz(3) = size(segment%field(m)%buffer_src,3) if (.not.allocated(segment%field(m)%buffer_dst)) then if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency') - if (segment%field(m)%nk_src > 1) then - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent - elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase' .or. & - segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,siz(3))) ! 3rd dim is constituent - else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) - endif - else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent - elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase' .or. & - segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent - else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) - endif - endif + + nk_dst = GV%ke + if (field_is_tidal(segment%field(m)%name)) nk_dst = siz(3) + if (segment%field(m)%nk_src <= 1) nk_dst = 1 + if (.not.segment%field(m)%on_face) then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc, js_obc:je_obc, nk_dst), source=0.0) + elseif (segment%is_E_or_W) then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc, js_obc+1:je_obc, nk_dst), source=0.0) else - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & - segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) - endif - else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & - segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) - endif - endif + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc, js_obc:je_obc, nk_dst), source=0.0) endif - segment%field(m)%buffer_dst(:,:,:) = 0.0 endif ! read source data interpolated to the current model time ! NOTE: buffer is sized for vertex points, but may be used for faces @@ -4083,56 +4105,57 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! This is where the data values are actually read in. call time_interp_external(segment%field(m)%handle, Time, tmp_buffer_in, scale=segment%field(m)%scale) - ! NOTE: Rotation of face-points require that we skip the final value + ! NOTE: Rotation of face-points require that we skip the final value when not in brushcutter mode. if (turns /= 0) then - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - if (segment%is_E_or_W & - .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'Vamp' & - .or. segment%field(m)%name == 'Vphase' .or. segment%field(m)%name == 'DVDX')) then + flip_buffer = ((turns==1) .or. (turns==3)) + if (OBC%brushcutter_mode .or. (.not.flip_buffer)) then + call rotate_array(tmp_buffer_in, turns, tmp_buffer) + elseif (flip_buffer .and. segment%is_E_or_W .and. segment%field(m)%on_face) then nj_buf = size(tmp_buffer, 2) - 1 call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) - elseif (segment%is_N_or_S & - .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'Uamp' & - .or. segment%field(m)%name == 'Uphase' .or. segment%field(m)%name == 'DUDY')) then + elseif (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then ni_buf = size(tmp_buffer, 1) - 1 call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) else call rotate_array(tmp_buffer_in, turns, tmp_buffer) endif - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - if (segment%field(m)%name == 'U' & - .or. segment%field(m)%name == 'DVDX' & - .or. segment%field(m)%name == 'DUDY' & - .or. segment%field(m)%name == 'Uamp') then + if (((segment%field(m)%name == 'U') .and. ((turns==1).or.(turns==2))) .or. & + ((segment%field(m)%name == 'V') .and. ((turns==2).or.(turns==3))) .or. & + ((segment%field(m)%name == 'Vamp') .and. ((turns==2).or.(turns==3))) .or. & + ((segment%field(m)%name == 'Uamp') .and. ((turns==1).or.(turns==2))) .or. & + ((segment%field(m)%name == 'DVDX') .and. ((turns==1).or.(turns==3))) .or. & + ((segment%field(m)%name == 'DUDY') .and. ((turns==1).or.(turns==3))) ) then tmp_buffer(:,:,:) = -tmp_buffer(:,:,:) endif endif if (OBC%brushcutter_mode) then + ! In brushcutter mode, the input data includes vales at both the vorticity point nodes and + ! the velocity point faces of the OBC segments. The vorticity node values are at the odd + ! positions in tmp_buffer, while the faces are at the even points. The bug that is being + ! corrected here is the use of the odd indexed points for both the corners and the faces. + bug_offset = 0 ; if (OBC%hor_index_bug) bug_offset = -1 if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & - segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then + if (.not.segment%field(m)%on_face) then segment%field(m)%buffer_src(is_obc,:,:) = & - tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset)+1:2,:) + tmp_buffer(1, 2*(js_obc+j_seg_offset+1)-1:2*(je_obc+j_seg_offset)+1:2, :) else segment%field(m)%buffer_src(is_obc,:,:) = & - tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset):2,:) + tmp_buffer(1, 2*(js_obc+j_seg_offset+1)+bug_offset:2*(je_obc+j_seg_offset):2, :) endif else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & - segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then + if (.not.segment%field(m)%on_face) then segment%field(m)%buffer_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset)+1:2,1,:) + tmp_buffer(2*(is_obc+i_seg_offset+1)-1:2*(ie_obc+i_seg_offset)+1:2, 1, :) else segment%field(m)%buffer_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset):2,1,:) + tmp_buffer(2*(is_obc+i_seg_offset+1)+bug_offset:2*(ie_obc+i_seg_offset):2, 1, :) endif endif - else + else ! Not brushcutter_mode. if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & - segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then + if (.not.segment%field(m)%on_face) then segment%field(m)%buffer_src(is_obc,:,:) = & tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset+1,:) else @@ -4140,8 +4163,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset,:) endif else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & - segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then + if (.not.segment%field(m)%on_face) then segment%field(m)%buffer_src(:,js_obc,:) = & tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset+1,1,:) else @@ -4150,46 +4172,53 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif endif + ! no dz for tidal variables - if (segment%field(m)%nk_src > 1 .and.& - (index(segment%field(m)%name, 'phase') <= 0 .and. index(segment%field(m)%name, 'amp') <= 0)) then - ! This is where the 2-d tidal data values are actually read in. + if (segment%field(m)%nk_src <= 1) then ! This is 2-d data with no remapping. + segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) + elseif (field_is_tidal(segment%field(m)%name)) then + ! The 3rd axis for tidal variables is the tidal constituent, so there is no remapping. + segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:) + else + ! Read in 3-d data that may need to be remapped onto the new grid + ! This is also where the 2-d tidal data values (apart from phase and amp) are actually read in. call time_interp_external(segment%field(m)%dz_handle, Time, tmp_buffer_in, scale=US%m_to_Z) + if (turns /= 0) then - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - if (segment%is_E_or_W & - .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX')) then + flip_buffer = ((turns==1) .or. (turns==3)) + if (flip_buffer .and. segment%is_E_or_W .and. segment%field(m)%on_face) then nj_buf = size(tmp_buffer, 2) - 1 call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) - elseif (segment%is_N_or_S & - .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY')) then + elseif (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then ni_buf = size(tmp_buffer, 1) - 1 call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) else call rotate_array(tmp_buffer_in, turns, tmp_buffer) endif - endif + endif ! End of rotation + if (OBC%brushcutter_mode) then + bug_offset = 0 ; if (OBC%hor_index_bug) bug_offset = -1 if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + if (.not.segment%field(m)%on_face) then segment%field(m)%dz_src(is_obc,:,:) = & - tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset)+1:2,:) + tmp_buffer(1, 2*(js_obc+j_seg_offset+1)-1:2*(je_obc+j_seg_offset)+1:2, :) else segment%field(m)%dz_src(is_obc,:,:) = & - tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset):2,:) + tmp_buffer(1, 2*(js_obc+j_seg_offset+1)+bug_offset:2*(je_obc+j_seg_offset):2, :) endif else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + if (.not.segment%field(m)%on_face) then segment%field(m)%dz_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset)+1:2,1,:) + tmp_buffer(2*(is_obc+i_seg_offset+1)-1:2*(ie_obc+i_seg_offset)+1:2, 1, :) else segment%field(m)%dz_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset):2,1,:) + tmp_buffer(2*(is_obc+i_seg_offset+1)+bug_offset:2*(ie_obc+i_seg_offset):2, 1, :) endif endif - else + else ! Not brushcutter_mode. if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + if (.not.segment%field(m)%on_face) then segment%field(m)%dz_src(is_obc,:,:) = & tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset+1,:) else @@ -4197,7 +4226,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset,:) endif else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + if (.not.segment%field(m)%on_face) then segment%field(m)%dz_src(:,js_obc,:) = & tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset+1,1,:) else @@ -4207,18 +4236,24 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif - ! The units of ...%dz_src are no longer changed from [Z ~> m] to [H ~> m or kg m-2] here. - call adjustSegmentEtaToFitBathymetry(G,GV,US,segment,m) + if ((.not.segment%field(m)%on_face) .and. (.not.OBC%hor_index_bug)) then + ! This point is at the OBC vorticity point nodes, rather than the OBC velocity point faces. + call adjustSegmentEtaToFitBathymetry(G, GV, US, segment, m, at_node=.true.) + else + call adjustSegmentEtaToFitBathymetry(G, GV, US, segment, m, at_node=.false.) + endif if (segment%is_E_or_W) then ishift=1 if (segment%direction == OBC_DIRECTION_E) ishift=0 I=is_obc - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + if (.not.segment%field(m)%on_face) then ! Do q points for the whole segment do J=max(js_obc,jsd),min(je_obc,jed-1) ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here + !### For a concave corner between OBC segments, there are 3 thicknesses we might + ! consider using. segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer if (G%mask2dCu(I,j)>0. .and. G%mask2dCu(I,j+1)>0.) then dz_stack(:) = 0.5*(dz(i+ishift,j,:) + dz(i+ishift,j+1,:)) @@ -4260,7 +4295,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) jshift=1 if (segment%direction == OBC_DIRECTION_N) jshift=0 J=js_obc - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + if (.not.segment%field(m)%on_face) then ! Do q points for the whole segment do I=max(is_obc,isd),min(ie_obc,ied-1) segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer @@ -4303,57 +4338,28 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) enddo endif endif - elseif (segment%field(m)%nk_src > 1 .and. & - (index(segment%field(m)%name, 'phase') > 0 .or. index(segment%field(m)%name, 'amp') > 0)) then - ! no dz for tidal variables - segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:) - else ! 2d data - segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer endif deallocate(tmp_buffer) - if (turns /= 0) & - deallocate(tmp_buffer_in) + if (turns /= 0) deallocate(tmp_buffer_in) else ! use_IO = .false. (Uniform value) if (.not. allocated(segment%field(m)%buffer_dst)) then - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - else if (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - elseif (segment%field(m)%name == 'U') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) - elseif (segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' & - .or. segment%field(m)%name == 'SSHphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) - endif + nk_dst = GV%ke + if (field_is_tidal(segment%field(m)%name)) nk_dst = 1 + if (segment%field(m)%name == 'SSH') nk_dst = 1 + if (.not.segment%field(m)%on_face) then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc, js_obc:je_obc, nk_dst), & + source=segment%field(m)%value) + elseif (segment%is_E_or_W) then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc, js_obc+1:je_obc, nk_dst), & + source=segment%field(m)%value) else - if (segment%field(m)%name == 'U') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - elseif (segment%field(m)%name == 'V') then - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) - elseif (segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' & - .or. segment%field(m)%name == 'SSHphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) - endif + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc, js_obc:je_obc, nk_dst), & + source=segment%field(m)%value) endif - segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value endif endif - enddo + enddo ! end field loop + ! Start second loop to update all fields now that data for all fields are available. ! (split because tides depend on multiple variables). do m = 1,segment%num_fields @@ -4484,78 +4490,38 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif if (trim(segment%field(m)%name) == 'SSH') then - if (OBC%ramp) then - do j=js_obc2,je_obc - do i=is_obc2,ie_obc - tidal_elev = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - segment%SSH(i,j) = OBC%ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) - enddo - enddo - else - do j=js_obc2,je_obc - do i=is_obc2,ie_obc - tidal_elev = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - segment%SSH(i,j) = (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + ramp_value = 1.0 + if (OBC%ramp) ramp_value = OBC%ramp_value + do j=js_obc2,je_obc ; do i=is_obc2,ie_obc + tidal_elev = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents + tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo - enddo - endif + endif + segment%SSH(i,j) = ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + enddo ; enddo endif - if (trim(segment%field(m)%name) == 'TEMP') then - if (allocated(segment%field(m)%buffer_dst)) then - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo ; enddo ; enddo - if (.not. segment%tr_Reg%Tr(1)%is_initialized) then - ! if the tracer reservoir has not yet been initialized, then set to external value. - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(1)%tres(i,j,k) = segment%tr_Reg%Tr(1)%t(i,j,k) - enddo ; enddo ; enddo - segment%tr_Reg%Tr(1)%is_initialized=.true. - endif - else - segment%tr_Reg%Tr(1)%OBC_inflow_conc = segment%field(m)%value - endif - elseif (trim(segment%field(m)%name) == 'SALT') then - if (allocated(segment%field(m)%buffer_dst)) then - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo ; enddo ; enddo - if (.not. segment%tr_Reg%Tr(2)%is_initialized) then - !if the tracer reservoir has not yet been initialized, then set to external value. - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(2)%tres(i,j,k) = segment%tr_Reg%Tr(2)%t(i,j,k) - enddo ; enddo ; enddo - segment%tr_Reg%Tr(2)%is_initialized=.true. - endif - else - segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value - endif - elseif (trim(segment%field(m)%genre) == 'obgc') then - nt=get_tracer_index(segment,trim(segment%field(m)%name)) - if (nt < 0) then - call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) + ! Set the inflow and reservoir data for tracers. + if ((trim(segment%field(m)%name) == 'TEMP') .or. (trim(segment%field(m)%name) == 'SALT') .or. & + (trim(segment%field(m)%genre) == 'obgc')) then + if (trim(segment%field(m)%name) == 'TEMP') then + nt = 1 + elseif (trim(segment%field(m)%name) == 'SALT') then + nt = 2 + elseif (trim(segment%field(m)%genre) == 'obgc') then + nt = get_tracer_index(segment,trim(segment%field(m)%name)) + if (nt < 0) call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) endif if (allocated(segment%field(m)%buffer_dst)) then do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) enddo ; enddo ; enddo if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then - !if the tracer reservoir has not yet been initialized, then set to external value. + ! If the tracer reservoir has not yet been initialized, then set to external value. do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k) enddo ; enddo ; enddo @@ -4813,11 +4779,11 @@ subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & if (segment%is_E_or_W) then allocate(segment%tr_Reg%Tr(ntseg)%t(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) allocate(segment%tr_Reg%Tr(ntseg)%tres(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) - segment%tr_Reg%Tr(ntseg)%is_initialized=.false. + segment%tr_Reg%Tr(ntseg)%is_initialized = .false. elseif (segment%is_N_or_S) then allocate(segment%tr_Reg%Tr(ntseg)%t(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) allocate(segment%tr_Reg%Tr(ntseg)%tres(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) - segment%tr_Reg%Tr(ntseg)%is_initialized=.false. + segment%tr_Reg%Tr(ntseg)%is_initialized = .false. endif endif @@ -4838,6 +4804,7 @@ subroutine segment_tracer_registry_end(Reg) endif end subroutine segment_tracer_registry_end +!> Registers the temperature and salinity in the segment tracer registry. subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< Unit scaling type @@ -4845,7 +4812,7 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values -! Local variables + ! Local variables integer :: n, ntr_id character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list @@ -4912,12 +4879,13 @@ subroutine get_obgc_segments_props(node, tr_name,obc_src_file_name,obc_src_field node => node%next end subroutine get_obgc_segments_props +!> Registers a named tracer in the segment tracer registries for the OBC segments on which it is active. subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values - character(len=*), intent(in) :: tr_name!< Tracer name + character(len=*), intent(in) :: tr_name !< Tracer name ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf, ntr_id, fd_id integer :: i, j, k, n, m @@ -4940,6 +4908,7 @@ subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) end subroutine register_obgc_segments +!> Stores the interior tracer values on the segment, and in some cases also sets the tracer reservoir values. subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -4959,7 +4928,7 @@ subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) do n=1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle - nt=get_tracer_index(segment,tr_name) + nt = get_tracer_index(segment, tr_name) if (nt < 0) then call MOM_error(FATAL,"fill_obgc_segments: Did not find tracer "// tr_name) endif @@ -4967,40 +4936,66 @@ subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - I_scale = 1.0 - if (segment%tr_Reg%Tr(nt)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(nt)%scale - ! Fill with Tracer values - if (segment%is_E_or_W) then - I=segment%HI%IsdB + + ! Fill segments with Tracer values + if (segment%direction == OBC_DIRECTION_W) then + I = segment%HI%IsdB do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed - if (segment%direction == OBC_DIRECTION_W) then - segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i+1,j,k) - else - segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i,j,k) - endif - OBC%tres_x(I,j,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%t(I,j,k) + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i+1,j,k) enddo ; enddo - else - J=segment%HI%JsdB + elseif (segment%direction == OBC_DIRECTION_E) then + I = segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i,j,k) + enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_S) then + J = segment%HI%JsdB do k=1,nz ; do i=segment%HI%isd,segment%HI%ied - if (segment%direction == OBC_DIRECTION_S) then - segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j+1,k) - else - segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j,k) - endif - OBC%tres_y(i,J,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%t(i,J,k) + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j+1,k) + enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_N) then + J = segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j,k) enddo ; enddo endif - segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:) - enddo + + if (.not.segment%tr_Reg%Tr(nt)%is_initialized) & + segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:) + + if (OBC%reservoir_init_bug) then + ! OBC%tres_x and OBC%tres_y should not be set here, but in a subsequent call to setup_OBC_tracer_reservoirs. + ! Note that fill_obgc_segments is not called for runs that start from a restart file. + I_scale = 1.0 + if (segment%tr_Reg%Tr(nt)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(nt)%scale + if (segment%is_E_or_W) then + if (allocated(OBC%tres_x)) then + I = segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + OBC%tres_x(I,j,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%tres(I,j,k) + enddo ; enddo + endif + else ! segment%is_N_or_S + if (allocated(OBC%tres_y)) then + J = segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + OBC%tres_y(i,J,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%tres(i,J,k) + enddo ; enddo + endif + endif + endif + + enddo ! End of loop over segments. + end subroutine fill_obgc_segments +!> Set the value of temperatures and salinities on OBC segments subroutine fill_temp_salt_segments(G, GV, US, OBC, tv) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< Unit scaling type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz integer :: i, j, k @@ -5010,9 +5005,6 @@ subroutine fill_temp_salt_segments(G, GV, US, OBC, tv) if (.not. associated(tv%T) .and. associated(tv%S)) return ! Both temperature and salinity fields - call pass_var(tv%T, G%Domain) - call pass_var(tv%S, G%Domain) - nz = GV%ke do n=1, OBC%number_of_segments @@ -5048,11 +5040,12 @@ subroutine fill_temp_salt_segments(G, GV, US, OBC, tv) endif enddo ; enddo endif - segment%tr_Reg%Tr(1)%tres(:,:,:) = segment%tr_Reg%Tr(1)%t(:,:,:) - segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) + if (.not.segment%tr_Reg%Tr(1)%is_initialized) & + segment%tr_Reg%Tr(1)%tres(:,:,:) = segment%tr_Reg%Tr(1)%t(:,:,:) + if (.not.segment%tr_Reg%Tr(2)%is_initialized) & + segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) enddo - call setup_OBC_tracer_reservoirs(G, GV, OBC) end subroutine fill_temp_salt_segments !> Find the region outside of all open boundary segments and @@ -5115,50 +5108,38 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - l_seg = OBC%segnum_u(I,j) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then + if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W if (color(i,j) == 0.0) color(i,j) = cout if (color(i+1,j) == 0.0) color(i+1,j) = cin - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + elseif (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E if (color(i,j) == 0.0) color(i,j) = cin if (color(i+1,j) == 0.0) color(i+1,j) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - l_seg = OBC%segnum_v(i,J) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then + if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S if (color(i,j) == 0.0) color(i,j) = cout if (color(i,j+1) == 0.0) color(i,j+1) = cin - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + elseif (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N if (color(i,j) == 0.0) color(i,j) = cin if (color(i,j+1) == 0.0) color(i,j+1) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - l_seg = OBC%segnum_v(i,J) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then + if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i,j+1) == 0.0) color2(i,j+1) = cin - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + elseif (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i,j+1) == 0.0) color2(i,j+1) = cout endif enddo ; enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - l_seg = OBC%segnum_u(I,j) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then + if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i+1,j) == 0.0) color2(i+1,j) = cin - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + elseif (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i+1,j) == 0.0) color2(i+1,j) = cout endif @@ -5335,14 +5316,14 @@ subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, res vd(1) = var_desc("rx_normal", "gridpoint timestep-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') vd(2) = var_desc("ry_normal", "gridpoint timestep-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') - call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS) + call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS, scalar_pair=.true.) ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to ! permit timesteps to change between calls to the OBC code, the following would be needed instead: ! vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') ! vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') ! call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS, & - ! conversion=US%L_T_to_m_s) + ! conversion=US%L_T_to_m_s, scalar_pair=.true.) endif if (OBC%oblique_BCs_exist_globally) then @@ -5741,15 +5722,17 @@ end subroutine remap_OBC_fields !! is dilated (expanded) to fill the void. !! @remark{There is a (hard-wired) "tolerance" parameter such that the !! criteria for adjustment must equal or exceed 10cm.} -subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) +subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment, fld, at_node) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_segment_type), intent(inout) :: segment !< OBC segment integer, intent(in) :: fld !< field index to adjust thickness + logical, intent(in) :: at_node !< True this point is at the OBC nodes rather than the faces integer :: i, j, k, is, ie, js, je, nz, contractions, dilations real, allocatable, dimension(:,:,:) :: eta ! Segment source data interface heights [Z ~> m] + real, allocatable, dimension(:,:) :: dz_tot ! Segment total thicknesses [Z ~> m] real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] ! real :: dilate ! A factor by which to dilate the water column [nondim] !character(len=100) :: mesg @@ -5759,15 +5742,51 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) nz = size(segment%field(fld)%dz_src,3) if (segment%is_E_or_W) then - ! segment thicknesses are defined at cell face centers. - is = segment%HI%isdB ; ie = segment%HI%iedB - js = segment%HI%jsd ; je = segment%HI%jed - else - is = segment%HI%isd ; ie = segment%HI%ied + is = segment%HI%IsdB ; ie = segment%HI%IedB + if (at_node) then ! This point is at the OBC nodes, rather than the cell face centers. + Js = max(segment%Js_obc, G%jsd) + Je = min(segment%Je_obc, G%jed-1) + else ! Segment thicknesses are defined at cell face centers. + js = segment%HI%jsd ; je = segment%HI%jed + endif + else ! segment%is_N_or_S js = segment%HI%jsdB ; je = segment%HI%jedB + if (at_node) then ! This point is at the OBC nodes, rather than the cell face centers. + is = max(segment%HI%IsdB, G%isd) + ie = min(segment%HI%IedB, G%ied-1) + else ! Segment thicknesses are defined at cell face centers. + is = segment%HI%isd ; ie = segment%HI%ied + endif endif allocate(eta(is:ie,js:je,nz+1)) - contractions=0; dilations=0 + allocate(dz_tot(is:ie,js:je), source=0.0) + + if (at_node) then + if (segment%is_E_or_W) then + I = Is + do J=Js,Je + dz_tot(I,J) = 0.5*(segment%dZtot(I,j) + segment%dZtot(I,j+1)) + enddo + ! Do not extrapolate past the end of a global segment. + ! ### For a concave corner between segments, perhaps we should do something more sophisticated. + if (Js == segment%Js_obc) dz_tot(I,Js) = segment%dZtot(I,js+1) + if (Je == segment%Js_obc) dz_tot(I,Je) = segment%dZtot(I,je) + else + J = Js + do I=Is,Ie + dz_tot(I,J) = 0.5*(segment%dZtot(i,J) + segment%dZtot(i+1,J)) + enddo + ! Do not extrapolate past the end of a global segment. + if (Is == segment%Is_obc) dz_tot(Is,J) = segment%dZtot(is+1,J) + if (Ie == segment%Is_obc) dz_tot(Ie,J) = segment%dZtot(ie,J) + endif + else + do j=js,je ; do i=is,ie + dz_tot(i,j) = segment%dZtot(i,j) + enddo ; enddo + endif + + contractions = 0 ; dilations = 0 do j=js,je ; do i=is,ie eta(i,j,1) = 0.0 ! segment data are assumed to be located on a static grid ! For remapping calls, the entire column will be dilated @@ -5781,8 +5800,8 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The normal slope at the boundary is zero by a ! previous call to open_boundary_impose_normal_slope do k=nz+1,1,-1 - if (-eta(i,j,k) > segment%dZtot(i,j) + hTolerance) then - eta(i,j,k) = -segment%dZtot(i,j) + if (-eta(i,j,k) > dz_tot(i,j) + hTolerance) then + eta(i,j,k) = -dz_tot(i,j) contractions = contractions + 1 endif enddo @@ -5800,10 +5819,10 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. - if (-eta(i,j,nz+1) < segment%dZtot(i,j) - hTolerance) then + if (-eta(i,j,nz+1) < dz_tot(i,j) - hTolerance) then dilations = dilations + 1 ! expand bottom-most cell only - eta(i,j,nz+1) = -segment%dZtot(i,j) + eta(i,j,nz+1) = -dz_tot(i,j) segment%field(fld)%dz_src(i,j,nz) = eta(i,j,nz) - eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo @@ -5816,7 +5835,6 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) enddo ; enddo ! can not do communication call here since only PEs on the current segment are here - ! call sum_across_PEs(contractions) ! if ((contractions > 0) .and. (is_root_pe())) then ! write(mesg,'("Thickness OBCs were contracted ",'// & @@ -5829,19 +5847,20 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! '"to fit topography in ",I8," places.")') dilations ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) ! endif - deallocate(eta) + + deallocate(eta, dz_tot) end subroutine adjustSegmentEtaToFitBathymetry !> This is more of a rotate initialization than an actual rotate subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) - type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< Input OBC - type(dyn_horgrid_type), intent(in) :: G_in !< Input grid metric + type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< Input OBC + type(dyn_horgrid_type), intent(in) :: G_in !< Input grid type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC - type(dyn_horgrid_type), intent(in) :: G !< Rotated grid metric - integer, intent(in) :: turns !< Number of quarter turns + type(dyn_horgrid_type), intent(in) :: G !< Rotated grid + integer, intent(in) :: turns !< Number of quarter turns - integer :: l + integer :: c, n, l_seg if (OBC_in%number_of_segments==0) return @@ -5865,29 +5884,41 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) ! Segment rotation allocate(OBC%segment(0:OBC%number_of_segments)) - do l = 1, OBC%number_of_segments - call rotate_OBC_segment_config(OBC_in%segment(l), G_in, OBC%segment(l), G, turns) - ! Data up to setup_[uv]_point_obc is needed for allocate_obc_segment_data! - call allocate_OBC_segment_data(OBC, OBC%segment(l)) - call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), turns) + do l_seg = 1, OBC%number_of_segments + call rotate_OBC_segment_config(OBC_in%segment(l_seg), G_in, OBC%segment(l_seg), G, turns) + ! Data stored in setup_[uv]_point_obc is needed for allocate_obc_segment_data + call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) + ! Initialize the field-related data of a rotated segment. + call rotate_OBC_segment_data(OBC_in%segment(l_seg), OBC%segment(l_seg), turns) enddo ! The horizontal segment map - allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed)) - allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB)) - call rotate_array_pair(OBC_in%segnum_u, OBC_in%segnum_v, turns, & - OBC%segnum_u, OBC%segnum_v) + allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0) + allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=0) + call rotate_array_pair(OBC_in%segnum_u, OBC_in%segnum_v, turns, OBC%segnum_u, OBC%segnum_v) + call set_segnum_signs(OBC, G) ! These are conditionally enabled during segment configuration - OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally - OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally - OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally - OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally + if (modulo(turns,2) == 0) then + OBC%open_u_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally + OBC%open_v_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally + OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally + OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally + OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally + OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally + OBC%specified_u_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally + OBC%specified_v_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally + else ! Swap information for u- and v- OBCs + OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally + OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally + OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally + OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally + OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally + OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally + OBC%specified_u_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally + OBC%specified_v_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally + endif OBC%oblique_BCs_exist_globally = OBC_in%oblique_BCs_exist_globally - OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally - OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally - OBC%specified_u_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally - OBC%specified_v_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally OBC%radiation_BCs_exist_globally = OBC_in%radiation_BCs_exist_globally ! These are set by initialize_segment_data @@ -5895,14 +5926,71 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%update_OBC = OBC_in%update_OBC OBC%needs_IO_for_data = OBC_in%needs_IO_for_data OBC%any_needs_IO_for_data = OBC_in%any_needs_IO_for_data - OBC%some_need_no_IO_for_data = OBC_in%some_need_no_IO_for_data + OBC%update_OBC_seg_data = OBC_in%update_OBC_seg_data OBC%ntr = OBC_in%ntr + if (OBC%ntr > 0) then + allocate(OBC%tracer_x_reservoirs_used(OBC%ntr), source=.false.) + allocate(OBC%tracer_y_reservoirs_used(OBC%ntr), source=.false.) + if (modulo(turns,2) == 0) then + do n=1,OBC%ntr + OBC%tracer_x_reservoirs_used(n) = OBC_in%tracer_x_reservoirs_used(n) + OBC%tracer_y_reservoirs_used(n) = OBC_in%tracer_y_reservoirs_used(n) + enddo + else ! Swap information for u- and v- OBCs + do n=1,OBC%ntr + OBC%tracer_x_reservoirs_used(n) = OBC_in%tracer_y_reservoirs_used(n) + OBC%tracer_y_reservoirs_used(n) = OBC_in%tracer_x_reservoirs_used(n) + enddo + endif + endif OBC%gamma_uv = OBC_in%gamma_uv OBC%rx_max = OBC_in%rx_max OBC%OBC_pe = OBC_in%OBC_pe + ! These are run-time parameters that are read in via open_boundary_config + OBC%debug = OBC_in%debug + OBC%ramp = OBC_in%ramp + OBC%ramping_is_activated = OBC_in%ramping_is_activated + OBC%ramp_timescale = OBC_in%ramp_timescale + OBC%trunc_ramp_time = OBC_in%trunc_ramp_time + OBC%ramp_value = OBC_in%ramp_value + OBC%ramp_start_time = OBC_in%ramp_start_time + OBC%remap_answer_date = OBC_in%remap_answer_date + OBC%check_reconstruction = OBC_in%check_reconstruction + OBC%check_remapping = OBC_in%check_remapping + OBC%force_bounds_in_subcell = OBC_in%force_bounds_in_subcell + OBC%om4_remap_via_sub_cells = OBC_in%om4_remap_via_sub_cells + OBC%remappingScheme = OBC_in%remappingScheme + OBC%exterior_OBC_bug = OBC_in%exterior_OBC_bug + OBC%hor_index_bug = OBC_in%hor_index_bug + OBC%n_tide_constituents = OBC_in%n_tide_constituents + OBC%add_tide_constituents = OBC_in%add_tide_constituents + + ! These are read in via initialize_obc_tides when n_tide_constituents > 0 + if (OBC%add_tide_constituents .and. (OBC%n_tide_constituents>0)) then + OBC%add_eq_phase = OBC_in%add_eq_phase + OBC%add_nodal_terms = OBC_in%add_nodal_terms + OBC%time_ref = OBC_in%time_ref + + allocate(OBC%tide_names(OBC%n_tide_constituents)) + allocate(OBC%tide_frequencies(OBC%n_tide_constituents)) + allocate(OBC%tide_eq_phases(OBC%n_tide_constituents)) + allocate(OBC%tide_fn(OBC%n_tide_constituents)) + allocate(OBC%tide_un(OBC%n_tide_constituents)) + do c=1,OBC%n_tide_constituents + OBC%tide_names(c) = OBC_in%tide_names(c) + OBC%tide_frequencies(c) = OBC_in%tide_frequencies(c) + OBC%tide_eq_phases(c) = OBC_in%tide_eq_phases(c) + OBC%tide_fn(c) = OBC_in%tide_fn(c) + OBC%tide_un(c) = OBC_in%tide_un(c) + enddo + + if (OBC%add_eq_phase .or. OBC%add_nodal_terms) & + OBC%tidal_longitudes = OBC_in%tidal_longitudes + endif + ! remap_z_CS and remap_h_CS are set up by initialize_segment_data, so we copy the fields here. if (ASSOCIATED(OBC_in%remap_z_CS)) then allocate(OBC%remap_z_CS) @@ -5913,9 +6001,6 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%remap_h_CS = OBC_in%remap_h_CS endif - ! TODO: The OBC registry seems to be a list of "registered" OBC types. - ! It does not appear to be used, so for now we skip this record. - !OBC%OBC_Reg => OBC_in%OBC_Reg end subroutine rotate_OBC_config !> Rotate the OBC segment configuration data from the input to model index map. @@ -5927,8 +6012,9 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) integer, intent(in) :: turns !< Number of quarter turns ! Global segment indices - integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain - integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain + integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain global indices + integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain global indices + integer :: qturns ! The number of quarter turns in the range of 0 to 3 ! NOTE: A "rotation" of the OBC segment string would allow us to use ! setup_[uv]_point_obc to set up most of this. For now, we just copy/swap @@ -5937,6 +6023,8 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) ! This is set if the segment is in the local grid segment%on_pe = segment_in%on_pe + qturns = modulo(turns, 4) + ! Transfer configuration flags segment%Flather = segment_in%Flather segment%radiation = segment_in%radiation @@ -5954,13 +6042,37 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) segment%open = segment_in%open segment%gradient = segment_in%gradient - ! NOTE: [uv]_values_needed are swapped - segment%u_values_needed = segment_in%v_values_needed - segment%v_values_needed = segment_in%u_values_needed + if ((qturns == 0) .or. (qturns == 2)) then + segment%u_values_needed = segment_in%u_values_needed + segment%v_values_needed = segment_in%v_values_needed + segment%uamp_values_needed = segment_in%uamp_values_needed + segment%vamp_values_needed = segment_in%vamp_values_needed + segment%uphase_values_needed = segment_in%uphase_values_needed + segment%vphase_values_needed = segment_in%vphase_values_needed + segment%uamp_index = segment_in%uamp_index ! ### Perhaps this should not be set here. + segment%vamp_index = segment_in%vamp_index + segment%uphase_index = segment_in%uphase_index + segment%vphase_index = segment_in%vphase_index + else ! NOTE: [uv]_values_needed are swapped + segment%u_values_needed = segment_in%v_values_needed + segment%v_values_needed = segment_in%u_values_needed + segment%uamp_values_needed = segment_in%vamp_values_needed + segment%vamp_values_needed = segment_in%uamp_values_needed + segment%uphase_values_needed = segment_in%vphase_values_needed + segment%vphase_values_needed = segment_in%uphase_values_needed + segment%uamp_index = segment_in%vamp_index ! ### Perhaps this should not be set here. + segment%vamp_index = segment_in%uamp_index + segment%uphase_index = segment_in%vphase_index + segment%vphase_index = segment_in%uphase_index + endif segment%z_values_needed = segment_in%z_values_needed segment%g_values_needed = segment_in%g_values_needed segment%t_values_needed = segment_in%t_values_needed segment%s_values_needed = segment_in%s_values_needed + segment%zamp_values_needed = segment_in%zamp_values_needed + segment%zphase_values_needed = segment_in%zphase_values_needed + segment%zamp_index = segment_in%zamp_index ! ### Perhaps this should not be set here. + segment%zphase_index = segment_in%zphase_index segment%values_needed = segment_in%values_needed @@ -5974,7 +6086,7 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) ! NOTE: The values stored in the segment are always saved in ascending order, ! e.g. (is < ie). In order to use setup_segment_indices, we reorder the ! indices here to indicate face direction. - ! Segment indices are also indexed locally, so we remove the halo offset. + ! Segment indices are also indexed locally, so here we convert to global indices if (segment_in%direction == OBC_DIRECTION_N) then Is_obc_in = segment_in%Ie_obc + G_in%idg_offset Ie_obc_in = segment_in%Is_obc + G_in%idg_offset @@ -5991,18 +6103,26 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) Je_obc_in = segment_in%Je_obc + G_in%jdg_offset endif - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - Is_obc = G_in%jegB - Js_obc_in - Ie_obc = G_in%JegB - Je_obc_in - Js_obc = Is_obc_in - Je_obc = Ie_obc_in - - ! Orientation is based on the index ordering, [IJ][se]_obc are re-ordered - ! after the index is set. So we now need to restore the original order + ! Rotate the global indices of the segment according to the number of turns. + if (qturns == 0) then + Is_obc = Is_obc_in ; Ie_obc = Ie_obc_in + Js_obc = Js_obc_in ; Je_obc = Je_obc_in + elseif (qturns == 1) then + Is_obc = G_in%JegB - Js_obc_in ; Ie_obc = G_in%JegB - Je_obc_in + Js_obc = Is_obc_in ; Je_obc = Ie_obc_in + elseif (qturns == 2) then + Is_obc = G_in%IegB - Is_obc_in ; Ie_obc = G_in%IegB - Ie_obc_in + Js_obc = G_in%JegB - Js_obc_in ; Je_obc = G_in%JegB - Je_obc_in + elseif (qturns == 3) then + Is_obc = Js_obc_in ; Ie_obc = Je_obc_in + Js_obc = G_in%IegB - Is_obc_in ; Je_obc = G_in%IegB - Ie_obc_in + endif + ! Orientation is based on the index ordering, and setup_segment_indices + ! is based on the the original order in the intput files. call setup_segment_indices(G, segment, Is_obc, Ie_obc, Js_obc, Je_obc) - ! Re-order [IJ][se]_obc back to ascending, and remove the halo offset. + ! Re-order [IJ][se]_obc back to ascending, and remove the global indexing offset. if (Is_obc > Ie_obc) then segment%Is_obc = Ie_obc - G%idg_offset segment%Ie_obc = Is_obc - G%idg_offset @@ -6020,31 +6140,14 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) endif ! Reconfigure the directional flags - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - select case (segment_in%direction) - case (OBC_DIRECTION_N) - segment%direction = OBC_DIRECTION_W - segment%is_E_or_W_2 = segment_in%is_N_or_S - segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe - segment%is_N_or_S = .false. - case (OBC_DIRECTION_W) - segment%direction = OBC_DIRECTION_S - segment%is_N_or_S = segment_in%is_E_or_W - segment%is_E_or_W = .false. - segment%is_E_or_W_2 = .false. - case (OBC_DIRECTION_S) - segment%direction = OBC_DIRECTION_E - segment%is_E_or_W_2 = segment_in%is_N_or_S - segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe - segment%is_N_or_S = .false. - case (OBC_DIRECTION_E) - segment%direction = OBC_DIRECTION_N - segment%is_N_or_S = segment_in%is_E_or_W - segment%is_E_or_W = .false. - segment%is_E_or_W_2 = .false. - case (OBC_NONE) - segment%direction = OBC_NONE - end select + segment%direction = rotate_OBC_segment_direction(segment_in%direction, turns) + + segment%is_E_or_W_2 = ((segment%direction == OBC_DIRECTION_E) .or. & + (segment%direction == OBC_DIRECTION_W)) + segment%is_E_or_W = segment_in%on_PE .and. segment%is_E_or_W_2 + segment%is_N_or_S = segment_in%on_PE .and. & + ((segment%direction == OBC_DIRECTION_N) .or. & + (segment%direction == OBC_DIRECTION_S)) ! These are conditionally set if Lscale_{in,out} are present segment%Tr_InvLscale_in = segment_in%Tr_InvLscale_in @@ -6052,52 +6155,101 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) end subroutine rotate_OBC_segment_config -!> Initialize the segments and field-related data of a rotated OBC. -subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CS, OBC) - type(ocean_OBC_type), intent(in) :: OBC_in !< OBC on input map - type(ocean_grid_type), intent(in) :: G !< Rotated grid metric - type(verticalGrid_type), intent(in) :: GV !< Vertical grid - type(unit_scale_type), intent(in) :: US !< Unit scaling - type(param_file_type), intent(in) :: param_file !< Input parameters - type(thermo_var_ptrs), intent(inout) :: tv !< Tracer fields - type(MOM_restart_CS), intent(in) :: restart_CS !< Restart CS - type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC - - logical :: use_temperature - integer :: l - - 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.) - - do l = 1, OBC%number_of_segments - call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), G%HI%turns) - enddo - - if (use_temperature) & - call fill_temp_salt_segments(G, GV, US, OBC, tv) +!> Return the direction of an OBC segment on after rotation to the new grid. Note that +!! rotate_OBC_seg_direction(rotate_OBC_seg_direction(direction, turns), -turns) = direction. +function rotate_OBC_segment_direction(direction, turns) result(rotated_dir) + integer, intent(in) :: direction !< The orientation of an OBC segment on the original grid + integer, intent(in) :: turns !< Number of quarter turns + integer :: rotated_dir !< An integer encoding the new rotated segment direction + + integer :: qturns ! The number of quarter turns in the range of 0 to 3 + + qturns = modulo(turns, 4) + + if ((qturns == 0) .or. (direction == OBC_NONE)) then + rotated_dir = direction + else ! Determine the segment direction on a rotated grid + select case (direction) + case (OBC_DIRECTION_N) + if (qturns == 0) rotated_dir = OBC_DIRECTION_N + if (qturns == 1) rotated_dir = OBC_DIRECTION_W + if (qturns == 2) rotated_dir = OBC_DIRECTION_S + if (qturns == 3) rotated_dir = OBC_DIRECTION_E + case (OBC_DIRECTION_W) + if (qturns == 0) rotated_dir = OBC_DIRECTION_W + if (qturns == 1) rotated_dir = OBC_DIRECTION_S + if (qturns == 2) rotated_dir = OBC_DIRECTION_E + if (qturns == 3) rotated_dir = OBC_DIRECTION_N + case (OBC_DIRECTION_S) + if (qturns == 0) rotated_dir = OBC_DIRECTION_S + if (qturns == 1) rotated_dir = OBC_DIRECTION_E + if (qturns == 2) rotated_dir = OBC_DIRECTION_N + if (qturns == 3) rotated_dir = OBC_DIRECTION_W + case (OBC_DIRECTION_E) + if (qturns == 0) rotated_dir = OBC_DIRECTION_E + if (qturns == 1) rotated_dir = OBC_DIRECTION_N + if (qturns == 2) rotated_dir = OBC_DIRECTION_W + if (qturns == 3) rotated_dir = OBC_DIRECTION_S + case (OBC_NONE) + rotated_dir = OBC_NONE + case default ! This should never happen. + rotated_dir = direction + end select + endif - call open_boundary_init(G, GV, US, param_file, OBC, restart_CS) -end subroutine rotate_OBC_init +end function rotate_OBC_segment_direction !> Rotate an OBC segment's fields from the input to the model index map. subroutine rotate_OBC_segment_data(segment_in, segment, turns) - type(OBC_segment_type), intent(in) :: segment_in - type(OBC_segment_type), intent(inout) :: segment - integer, intent(in) :: turns + type(OBC_segment_type), intent(in) :: segment_in !< The unrotated segment to use as a source + type(OBC_segment_type), intent(inout) :: segment !< The rotated segment to initialize + integer, intent(in) :: turns !< The number of quarter turns of the grid to apply + ! Local variables + logical :: flip_normal_vel_sign, flip_tang_vel_sign integer :: n integer :: num_fields - + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, ke num_fields = segment_in%num_fields allocate(segment%field(num_fields)) + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + if ((turns == 0) .or. (turns == 2)) then + segment%uamp_index = segment_in%uamp_index + segment%vamp_index = segment_in%vamp_index + segment%uphase_index = segment_in%uphase_index + segment%vphase_index = segment_in%vphase_index + else ! NOTE: [uv]_values_needed are swapped + segment%uamp_index = segment_in%vamp_index + segment%vamp_index = segment_in%uamp_index + segment%uphase_index = segment_in%vphase_index + segment%vphase_index = segment_in%uphase_index + endif + segment%zamp_index = segment_in%zamp_index + segment%zphase_index = segment_in%zphase_index + segment%num_fields = segment_in%num_fields do n = 1, num_fields segment%field(n)%handle = segment_in%field(n)%handle segment%field(n)%dz_handle = segment_in%field(n)%dz_handle + segment%field(n)%use_IO = segment_in%field(n)%use_IO + segment%field(n)%genre = segment_in%field(n)%genre + segment%field(n)%scale = segment_in%field(n)%scale + segment%field(n)%resrv_lfac_in = segment_in%field(n)%resrv_lfac_in + segment%field(n)%resrv_lfac_out = segment_in%field(n)%resrv_lfac_out + segment%field(n)%on_face = segment_in%field(n)%on_face + + if (allocated(segment_in%field(n)%buffer_dst)) then + call allocate_rotated_seg_data(segment_in%field(n)%buffer_dst, segment_in%HI, & + segment%field(n)%buffer_dst, segment) + call rotate_array(segment_in%field(n)%buffer_dst, turns, segment%field(n)%buffer_dst) + endif if (modulo(turns, 2) /= 0) then select case (segment_in%field(n)%name) @@ -6125,30 +6277,501 @@ subroutine rotate_OBC_segment_data(segment_in, segment, turns) endif if (allocated(segment_in%field(n)%buffer_src)) then - call allocate_rotated_array(segment_in%field(n)%buffer_src, & - lbound(segment_in%field(n)%buffer_src), turns, & - segment%field(n)%buffer_src) - call rotate_array(segment_in%field(n)%buffer_src, turns, & - segment%field(n)%buffer_src) + call allocate_rotated_seg_data(segment_in%field(n)%buffer_src, segment_in%HI, & + segment%field(n)%buffer_src, segment) + call rotate_array(segment_in%field(n)%buffer_src, turns, segment%field(n)%buffer_src) endif segment%field(n)%nk_src = segment_in%field(n)%nk_src if (allocated(segment_in%field(n)%dz_src)) then - call allocate_rotated_array(segment_in%field(n)%dz_src, & - lbound(segment_in%field(n)%dz_src), turns, & - segment%field(n)%dz_src) - call rotate_array(segment_in%field(n)%dz_src, turns, & - segment%field(n)%dz_src) + call allocate_rotated_seg_data(segment_in%field(n)%dz_src, segment_in%HI, segment%field(n)%dz_src, segment) + call rotate_array(segment_in%field(n)%dz_src, turns, segment%field(n)%dz_src) endif segment%field(n)%value = segment_in%field(n)%value enddo + if (allocated(segment_in%SSH)) & + call rotate_array(segment_in%SSH, turns, segment%SSH) + if (allocated(segment_in%cg)) & + call rotate_array(segment_in%cg, turns, segment%cg) + if (allocated(segment_in%htot)) & + call rotate_array(segment_in%htot, turns, segment%htot) + if (allocated(segment_in%dztot)) & + call rotate_array(segment_in%dztot, turns, segment%dztot) + if (allocated(segment_in%h)) & + call rotate_array(segment_in%h, turns, segment%h) + if (allocated(segment_in%normal_vel)) & + call rotate_array(segment_in%normal_vel, turns, segment%normal_vel) + if (allocated(segment_in%normal_trans)) & + call rotate_array(segment_in%normal_trans, turns, segment%normal_trans) + if (allocated(segment_in%normal_vel_bt)) & + call rotate_array(segment_in%normal_vel_bt, turns, segment%normal_vel_bt) + if (allocated(segment_in%tangential_vel)) & + call rotate_array(segment_in%tangential_vel, turns, segment%tangential_vel) + if (allocated(segment_in%tangential_grad)) & + call rotate_array(segment_in%tangential_grad, turns, segment%tangential_grad) + if (allocated(segment_in%grad_normal)) & + call rotate_array(segment_in%grad_normal, turns, segment%grad_normal) + if (allocated(segment_in%grad_tan)) & + call rotate_array(segment_in%grad_tan, turns, segment%grad_tan) + if (allocated(segment_in%grad_gradient)) & + call rotate_array(segment_in%grad_gradient, turns, segment%grad_gradient) + if (modulo(turns, 2) /= 0) then + if (allocated(segment_in%rx_norm_rad)) & + call rotate_array(segment_in%rx_norm_rad, turns, segment%ry_norm_rad) + if (allocated(segment_in%ry_norm_rad)) & + call rotate_array(segment_in%ry_norm_rad, turns, segment%rx_norm_rad) + if (allocated(segment_in%rx_norm_obl)) & + call rotate_array(segment_in%rx_norm_obl, turns, segment%ry_norm_obl) + if (allocated(segment_in%ry_norm_obl)) & + call rotate_array(segment_in%ry_norm_obl, turns, segment%rx_norm_obl) + else + if (allocated(segment_in%rx_norm_rad)) & + call rotate_array(segment_in%rx_norm_rad, turns, segment%rx_norm_rad) + if (allocated(segment_in%ry_norm_rad)) & + call rotate_array(segment_in%ry_norm_rad, turns, segment%ry_norm_rad) + if (allocated(segment_in%rx_norm_obl)) & + call rotate_array(segment_in%rx_norm_obl, turns, segment%rx_norm_obl) + if (allocated(segment_in%ry_norm_obl)) & + call rotate_array(segment_in%ry_norm_obl, turns, segment%ry_norm_obl) + endif + if (allocated(segment_in%cff_normal)) & + call rotate_array(segment_in%cff_normal, turns, segment%cff_normal) + if (allocated(segment_in%nudged_normal_vel)) & + call rotate_array(segment_in%nudged_normal_vel, turns, segment%nudged_normal_vel) + if (allocated(segment_in%nudged_tangential_vel)) & + call rotate_array(segment_in%nudged_tangential_vel, turns, segment%nudged_tangential_vel) + if (allocated(segment_in%nudged_tangential_grad)) & + call rotate_array(segment_in%nudged_tangential_grad, turns, segment%nudged_tangential_grad) + + ! Change the sign of the normal or tangential velocities or transports that have been read in from + ! a file, depending on the orientation of the face and the number of quarter turns of the grid. + flip_normal_vel_sign = .false. ; flip_tang_vel_sign = .false. + do n = 1, num_fields + if (((segment%field(n)%name == 'U') .or. (segment%field(n)%name == 'Uamp')) .and. & + ((modulo(turns, 4) == 1) .or. (modulo(turns, 4) == 2)) ) then + if (allocated(segment%field(n)%buffer_dst)) & + segment%field(n)%buffer_dst(:,:,:) = -segment%field(n)%buffer_dst(:,:,:) + segment%field(n)%value = -segment%field(n)%value + if (segment%is_E_or_W) flip_normal_vel_sign = .true. + if (segment%is_N_or_S) flip_tang_vel_sign = .true. + elseif (((segment%field(n)%name == 'V') .or. (segment%field(n)%name == 'Vamp')) .and. & + ((modulo(turns, 4) == 3) .or. (modulo(turns, 4) == 2)) ) then + if (allocated(segment%field(n)%buffer_dst)) & + segment%field(n)%buffer_dst(:,:,:) = -segment%field(n)%buffer_dst(:,:,:) + segment%field(n)%value = -segment%field(n)%value + if (segment%is_N_or_S) flip_normal_vel_sign = .true. + if (segment%is_E_or_W) flip_tang_vel_sign = .true. + endif + enddo + + if (flip_normal_vel_sign) then + segment%normal_trans(:,:,:) = -segment%normal_trans(:,:,:) + segment%normal_vel(:,:,:) = -segment%normal_vel(:,:,:) + segment%normal_vel_bt(:,:) = -segment%normal_vel_bt(:,:) + if (allocated(segment%nudged_normal_vel)) & + segment%nudged_normal_vel(:,:,:) = -segment%nudged_normal_vel(:,:,:) + endif + + if (flip_tang_vel_sign) then + if (allocated(segment%tangential_vel)) & + segment%tangential_vel(:,:,:) = -segment%tangential_vel(:,:,:) + if (allocated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(:,:,:) = -segment%nudged_tangential_vel(:,:,:) + endif + segment%temp_segment_data_exists = segment_in%temp_segment_data_exists segment%salt_segment_data_exists = segment_in%salt_segment_data_exists end subroutine rotate_OBC_segment_data + +!> Allocate an array of data for a field on a segment based on the size of a potentially rotated source array +subroutine allocate_rotated_seg_data(src_array, HI_in, tgt_array, segment) + real, dimension(:,:,:), intent(in) :: src_array !< The segment data on the unrotated source grid + type(hor_index_type), intent(in) :: HI_in !< Horizontal indices on the source grid + real, dimension(:,:,:), allocatable, intent(inout) :: tgt_array !< The segment data that is being allocated + type(OBC_segment_type), intent(inout) :: segment !< OBC segment on the target grid + + ! Local variables + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nk + logical :: corner ! True if this field is discretized at the OBC segment nodes rather than the faces. + + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + nk = size(src_array, 3) + + ! Determine whether the source array is allocated at a segment face or at the corners. + corner = (size(src_array, 1) == abs(HI_in%IedB - HI_in%IsdB) + 1 ) .and. & + (size(src_array, 2) == abs(HI_in%JedB - HI_in%JsdB) + 1 ) + + if (corner) then + allocate(tgt_array(IsdB:IedB,JsdB:JedB,nk), source=0.0) + elseif (segment%is_E_or_W) then + allocate(tgt_array(IsdB:IedB,jsd:jed,nk), source=0.0) + elseif (segment%is_N_or_S) then + allocate(tgt_array(isd:ied,JsdB:JedB,nk), source=0.0) + endif +end subroutine allocate_rotated_seg_data + + +!> Write out information about the contents of the OBC control structure +subroutine write_OBC_info(OBC, G, GV, US) + type(ocean_OBC_type), pointer :: OBC !< An open boundary condition control structure + type(ocean_grid_type), intent(in) :: G !< Rotated grid metric + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< Unit scaling + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + integer :: turns ! Number of index quarter turns + integer :: c, n, dir, unrot_dir + character(len=1024) :: mesg + + turns = modulo(G%HI%turns, 4) + + write(mesg, '("OBC has ", I3, " segments.")') OBC%number_of_segments + call MOM_mesg(mesg, verb=1) + ! call MOM_error(WARNING, mesg) + + if (modulo(turns, 2) == 0) then + if (OBC%open_u_BCs_exist_globally) call MOM_mesg("open_u_BCs_exist_globally", verb=1) + if (OBC%open_v_BCs_exist_globally) call MOM_mesg("open_v_BCs_exist_globally", verb=1) + if (OBC%Flather_u_BCs_exist_globally) call MOM_mesg("Flather_u_BCs_exist_globally", verb=1) + if (OBC%Flather_v_BCs_exist_globally) call MOM_mesg("Flather_v_BCs_exist_globally", verb=1) + if (OBC%nudged_u_BCs_exist_globally) call MOM_mesg("nudged_u_BCs_exist_globally", verb=1) + if (OBC%nudged_v_BCs_exist_globally) call MOM_mesg("nudged_v_BCs_exist_globally", verb=1) + if (OBC%specified_u_BCs_exist_globally) call MOM_mesg("specified_u_BCs_exist_globally", verb=1) + if (OBC%specified_v_BCs_exist_globally) call MOM_mesg("specified_v_BCs_exist_globally", verb=1) + else ! The u- and v-directions are swapped. + if (OBC%open_v_BCs_exist_globally) call MOM_mesg("open_u_BCs_exist_globally", verb=1) + if (OBC%open_u_BCs_exist_globally) call MOM_mesg("open_v_BCs_exist_globally", verb=1) + if (OBC%Flather_v_BCs_exist_globally) call MOM_mesg("Flather_u_BCs_exist_globally", verb=1) + if (OBC%Flather_u_BCs_exist_globally) call MOM_mesg("Flather_v_BCs_exist_globally", verb=1) + if (OBC%nudged_v_BCs_exist_globally) call MOM_mesg("nudged_u_BCs_exist_globally", verb=1) + if (OBC%nudged_u_BCs_exist_globally) call MOM_mesg("nudged_v_BCs_exist_globally", verb=1) + if (OBC%specified_v_BCs_exist_globally) call MOM_mesg("specified_u_BCs_exist_globally", verb=1) + if (OBC%specified_u_BCs_exist_globally) call MOM_mesg("specified_v_BCs_exist_globally", verb=1) + endif + + if (OBC%oblique_BCs_exist_globally) call MOM_mesg("oblique_BCs_exist_globally", verb=1) + if (OBC%radiation_BCs_exist_globally) call MOM_mesg("radiation_BCs_exist_globally", verb=1) + if (OBC%user_BCs_set_globally) call MOM_mesg("user_BCs_set_globally", verb=1) + if (OBC%update_OBC) call MOM_mesg("update_OBC", verb=1) + if (OBC%update_OBC_seg_data) call MOM_mesg("update_OBC_seg_data", verb=1) + if (OBC%needs_IO_for_data) call MOM_mesg("needs_IO_for_data", verb=1) + if (OBC%any_needs_IO_for_data) call MOM_mesg("any_needs_IO_for_data", verb=1) + if (OBC%zero_vorticity) call MOM_mesg("zero_vorticity", verb=1) + if (OBC%freeslip_vorticity) call MOM_mesg("freeslip_vorticity", verb=1) + if (OBC%computed_vorticity) call MOM_mesg("computed_vorticity", verb=1) + if (OBC%specified_vorticity) call MOM_mesg("specified_vorticity", verb=1) + if (OBC%zero_strain) call MOM_mesg("zero_strain", verb=1) + if (OBC%freeslip_strain) call MOM_mesg("freeslip_strain", verb=1) + if (OBC%computed_strain) call MOM_mesg("computed_strain", verb=1) + if (OBC%specified_strain) call MOM_mesg("specified_strain", verb=1) + if (OBC%zero_biharmonic) call MOM_mesg("zero_biharmonic", verb=1) + if (OBC%brushcutter_mode) call MOM_mesg("brushcutter_mode", verb=1) + if (OBC%check_reconstruction) call MOM_mesg("check_reconstruction", verb=1) + if (OBC%check_remapping) call MOM_mesg("check_remapping", verb=1) + if (OBC%force_bounds_in_subcell) call MOM_mesg("force_bounds_in_subcell", verb=1) + if (OBC%om4_remap_via_sub_cells) call MOM_mesg("om4_remap_via_sub_cells", verb=1) + if (OBC%exterior_OBC_bug) call MOM_mesg("exterior_OBC_bug", verb=1) + if (OBC%hor_index_bug) call MOM_mesg("hor_index_bug", verb=1) + if (OBC%debug) call MOM_mesg("debug", verb=1) + if (OBC%ramp) call MOM_mesg("ramp", verb=1) + if (OBC%ramping_is_activated) call MOM_mesg("ramping_is_activated", verb=1) + write(mesg, '("n_tide_constituents ", I3)') OBC%n_tide_constituents + call MOM_mesg(mesg, verb=1) + if (OBC%n_tide_constituents > 0) then + do c=1,OBC%n_tide_constituents + write(mesg, '(" properties ", 4ES16.6)') & + US%s_to_T*OBC%tide_frequencies(c), OBC%tide_eq_phases(c), OBC%tide_fn(c), OBC%tide_un(c) + call MOM_mesg(trim(OBC%tide_names(c))//mesg, verb=1) + enddo + endif + if (OBC%ramp) then + write(mesg, '("ramp_values ", 3ES16.6)') OBC%ramp_timescale, OBC%trunc_ramp_time, OBC%ramp_value + call MOM_mesg(mesg, verb=1) + endif + write(mesg, '("gamma_uv ", ES16.6)') OBC%gamma_uv + call MOM_mesg(mesg, verb=1) + write(mesg, '("rx_max ", ES16.6)') OBC%rx_max + call MOM_mesg(mesg, verb=1) + + call MOM_mesg("remappingScheme = "//trim(OBC%remappingScheme), verb=1) + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + dir = segment%direction + + unrot_dir = rotate_OBC_segment_direction(dir, -turns) + write(mesg, '(" Segment ", I3, " has direction ", I3)') n, unrot_dir + if (unrot_dir == OBC_DIRECTION_N) write(mesg, '(" Segment ", I3, " is Northern")') n + if (unrot_dir == OBC_DIRECTION_S) write(mesg, '(" Segment ", I3, " is Southern")') n + if (unrot_dir == OBC_DIRECTION_E) write(mesg, '(" Segment ", I3, " is Eastern")') n + if (unrot_dir == OBC_DIRECTION_W) write(mesg, '(" Segment ", I3, " is Western")') n + call MOM_mesg(mesg, verb=1) + + ! write(mesg, '(" range: ", 4I3)') segment%Is_obc, segment%Ie_obc, segment%Js_obc, segment%Je_obc + if (modulo(turns, 2) == 0) then + write(mesg, '(" size: ", 4I3)') 1+abs(segment%Ie_obc-segment%Is_obc), 1+abs(segment%Je_obc-segment%Js_obc) + else + write(mesg, '(" size: ", 4I3)') 1+abs(segment%Je_obc-segment%Js_obc), 1+abs(segment%Ie_obc-segment%Is_obc) + endif + call MOM_mesg(mesg, verb=1) + + if (segment%on_pe) call MOM_mesg(" Segment is on PE.", verb=1) + + if (segment%Flather) call MOM_mesg(" Flather", verb=1) + if (segment%radiation) call MOM_mesg(" radiation", verb=1) + if (segment%radiation_tan) call MOM_mesg(" radiation_tan", verb=1) + if (segment%radiation_grad) call MOM_mesg(" radiation_grad", verb=1) + if (segment%oblique) call MOM_mesg(" oblique", verb=1) + if (segment%oblique_tan) call MOM_mesg(" oblique_tan", verb=1) + if (segment%oblique_grad) call MOM_mesg(" oblique_grad", verb=1) + if (segment%nudged) call MOM_mesg(" nudged", verb=1) + if (segment%nudged_tan) call MOM_mesg(" nudged_tan", verb=1) + if (segment%nudged_grad) call MOM_mesg(" nudged_grad", verb=1) + if (segment%specified) call MOM_mesg(" specified", verb=1) + if (segment%specified_tan) call MOM_mesg(" specified_tan", verb=1) + if (segment%specified_grad) call MOM_mesg(" specified_grad", verb=1) + if (segment%open) call MOM_mesg(" open", verb=1) + if (segment%gradient) call MOM_mesg(" gradient", verb=1) + if (segment%values_needed) call MOM_mesg(" values_needed", verb=1) + if (modulo(turns, 2) == 0) then + if (segment%is_N_or_S) call MOM_mesg(" is_N_or_S", verb=1) + if (segment%is_E_or_W) call MOM_mesg(" is_E_or_W", verb=1) + if (segment%u_values_needed) call MOM_mesg(" u_values_needed", verb=1) + if (segment%uamp_values_needed) call MOM_mesg(" uamp_values_needed", verb=1) + if (segment%uphase_values_needed) call MOM_mesg(" uphase_values_needed", verb=1) + if (segment%v_values_needed) call MOM_mesg(" v_values_needed", verb=1) + if (segment%vamp_values_needed) call MOM_mesg(" vamp_values_needed", verb=1) + if (segment%vphase_values_needed) call MOM_mesg(" vphase_values_needed", verb=1) + else ! The x- and y-directions are swapped. + if (segment%is_E_or_W) call MOM_mesg(" is_N_or_S", verb=1) + if (segment%is_N_or_S) call MOM_mesg(" is_E_or_W", verb=1) + if (segment%v_values_needed) call MOM_mesg(" u_values_needed", verb=1) + if (segment%vamp_values_needed) call MOM_mesg(" uamp_values_needed", verb=1) + if (segment%vphase_values_needed) call MOM_mesg(" uphase_values_needed", verb=1) + if (segment%u_values_needed) call MOM_mesg(" v_values_needed", verb=1) + if (segment%uamp_values_needed) call MOM_mesg(" vamp_values_needed", verb=1) + if (segment%uphase_values_needed) call MOM_mesg(" vphase_values_needed", verb=1) + endif + if (segment%t_values_needed) call MOM_mesg(" t_values_needed", verb=1) + if (segment%s_values_needed) call MOM_mesg(" s_values_needed", verb=1) + if (segment%z_values_needed) call MOM_mesg(" z_values_needed", verb=1) + if (segment%zamp_values_needed) call MOM_mesg(" zamp_values_needed", verb=1) + if (segment%zphase_values_needed) call MOM_mesg(" zphase_values_needed", verb=1) + if (segment%g_values_needed) call MOM_mesg(" g_values_needed", verb=1) +! if (segment%is_E_or_W_2) call MOM_mesg(" is_E_or_W_2", verb=1) + if (segment%temp_segment_data_exists) call MOM_mesg(" temp_segment_data_exists", verb=1) + if (segment%salt_segment_data_exists) call MOM_mesg(" salt_segment_data_exists", verb=1) + + write(mesg, '(" Tr_InvLscale_out ", ES16.6)') segment%Tr_InvLscale_out*US%m_to_L + call MOM_mesg(mesg, verb=1) + write(mesg, '(" Tr_InvLscale_in ", ES16.6)') segment%Tr_InvLscale_in*US%m_to_L + call MOM_mesg(mesg, verb=1) + + enddo + + call chksum_OBC_segments(OBC, G, GV, US, 0) + +end subroutine write_OBC_info + +!> Write checksums and perhaps the values of all the allocated arrays on an OBC segments. +subroutine chksum_OBC_segments(OBC, G, GV, US, nk) + type(ocean_OBC_type), pointer :: OBC !< OBC on input map + type(ocean_grid_type), intent(in) :: G !< Rotated grid metric + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< Unit scaling + integer, intent(in) :: nk !< The number of layers to print + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + real :: norm ! A sign change used when rotating a normal component [nondim] + real :: tang ! A sign change used when rotating a tangential component [nondim] + character(len=8) :: sn, segno + character(len=1024) :: mesg + integer :: c, n, dir + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + dir = segment%direction + + write(segno, '(I3)') n + sn = '('//trim(adjustl(segno))//')' + + ! Turn each segment and write it as though it is an eastern face. + norm = 0.0 ; tang = 0.0 + if (dir == OBC_DIRECTION_E) then + norm = 1.0 ; tang = 1.0 + elseif (dir == OBC_DIRECTION_N) then + norm = 1.0 ; tang = -1.0 + elseif (dir == OBC_DIRECTION_W) then + norm = -1.0 ; tang = -1.0 + elseif (dir == OBC_DIRECTION_S) then + norm = -1.0 ; tang = 1.0 + endif + + if (allocated(segment%Cg)) call write_2d_array_vals("Cg"//trim(sn), segment%Cg, dir, nk, unscale=US%L_T_to_m_s) + if (allocated(segment%Htot)) call write_2d_array_vals("Htot"//trim(sn), segment%Htot, dir, nk, unscale=GV%H_to_mks) + if (allocated(segment%dZtot)) call write_2d_array_vals("dZtot"//trim(sn), segment%dZtot, dir, nk, unscale=US%Z_to_m) + if (allocated(segment%SSH)) call write_2d_array_vals("SSH"//trim(sn), segment%SSH, dir, nk, unscale=US%Z_to_m) + if (allocated(segment%h)) call write_3d_array_vals("h"//trim(sn), segment%h, dir, nk, unscale=GV%H_to_mks) + if (allocated(segment%normal_vel)) & + call write_3d_array_vals("normal_vel"//trim(sn), segment%normal_vel, dir, nk, unscale=norm*US%L_T_to_m_s) + if (allocated(segment%normal_vel_bt)) & + call write_2d_array_vals("normal_vel_bt"//trim(sn), segment%normal_vel_bt, dir, nk, unscale=norm*US%L_T_to_m_s) + if (allocated(segment%tangential_vel)) & + call write_3d_array_vals("tangential_vel"//trim(sn), segment%tangential_vel, dir, nk, unscale=tang*US%L_T_to_m_s) + if (allocated(segment%tangential_grad)) & + call write_3d_array_vals("tangential_grad"//trim(sn), segment%tangential_grad, dir, nk, & + unscale=tang*norm*US%s_to_T) + if (allocated(segment%normal_trans)) & + call write_3d_array_vals("normal_trans"//trim(sn), segment%normal_trans, dir, nk, & + unscale=norm*GV%H_to_mks*US%L_T_to_m_s*US%L_to_m) + if (allocated(segment%grad_normal)) & + call write_3d_array_vals("grad_normal"//trim(sn), segment%grad_normal, dir, nk, unscale=norm*tang*US%L_T_to_m_s) + if (allocated(segment%grad_tan)) & + call write_3d_array_vals("grad_tan"//trim(sn), segment%grad_tan, dir, nk, unscale=1.0*US%L_T_to_m_s) + if (allocated(segment%grad_gradient)) & + call write_3d_array_vals("grad_gradient"//trim(sn), segment%grad_gradient, dir, nk, unscale=norm*US%s_to_T) + + if (allocated(segment%rx_norm_rad)) & + call write_3d_array_vals("rxy_norm_rad"//trim(sn), segment%rx_norm_rad, dir, nk, unscale=1.0) + if (allocated(segment%ry_norm_rad)) & + call write_3d_array_vals("rxy_norm_rad"//trim(sn), segment%ry_norm_rad, dir, nk, unscale=1.0) + if (segment%is_E_or_W) then + if (allocated(segment%rx_norm_obl)) & + call write_3d_array_vals("rx_norm_obl"//trim(sn), segment%rx_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2) + if (allocated(segment%ry_norm_obl)) & + call write_3d_array_vals("ry_norm_obl"//trim(sn), segment%ry_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2) + else ! The x- and y- directions are swapped. + if (allocated(segment%ry_norm_obl)) & + call write_3d_array_vals("rx_norm_obl"//trim(sn), segment%ry_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2) + if (allocated(segment%rx_norm_obl)) & + call write_3d_array_vals("ry_norm_obl"//trim(sn), segment%rx_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2) + endif + + if (allocated(segment%cff_normal)) & + call write_3d_array_vals("cff_normal"//trim(sn), segment%cff_normal, dir, nk, unscale=US%L_T_to_m_s**2) + if (allocated(segment%nudged_normal_vel)) & + call write_3d_array_vals("nudged_normal_vel"//trim(sn), segment%nudged_normal_vel, dir, nk, & + unscale=norm*US%L_T_to_m_s) + if (allocated(segment%nudged_tangential_vel)) & + call write_3d_array_vals("nudged_tangential_vel"//trim(sn), segment%nudged_tangential_vel, dir, nk, & + unscale=tang*US%L_T_to_m_s) + if (allocated(segment%nudged_tangential_grad)) & + call write_3d_array_vals("nudged_tangential_grad"//trim(sn), segment%nudged_tangential_grad, dir, nk, & + unscale=tang*norm*US%s_to_T) + enddo + + contains + + !> Write out the values in a named 2-d segment data array + subroutine write_2d_array_vals(name, Array, seg_dir, nkp, unscale) + character(len=*), intent(in) :: name !< The name of the variable + real, dimension(:,:), intent(in) :: Array !< The 2-d array to write [A ~> a] + integer, intent(in) :: seg_dir !< The direction of the segment + integer, intent(in) :: nkp !< Print all the values if this is greater than 0 + real, optional, intent(in) :: unscale !< A factor that undoes the scaling of the array [a A-1 ~> 1] + ! Local variables + real :: scale ! A factor that undoes the scaling of the array [a A-1 ~> 1] + character(len=1024) :: mesg + character(len=24) :: val + integer :: i, j, n, iounit + + scale = 1.0 ; if (present(unscale)) scale = unscale + iounit = stderr + + if (nkp > 0) then + write(iounit, '(2X,A,":")') trim(name) + mesg = "" ; n = 0 + if ((seg_dir == OBC_DIRECTION_N) .or. (seg_dir == OBC_DIRECTION_W)) then + do j=size(Array,2),1,-1 ; do i=size(Array,1),1,-1 + write(val, '(ES16.6)') scale*Array(i,j) + mesg = trim(mesg)//" "//trim(val) ; n = n + 1 + if (n >= 12) then + write(iounit, '(2X,A)') trim(mesg) + mesg = "" ; n = 0 + endif + enddo ; enddo + else + do j=1,size(Array,2) ; do i=1,size(Array,1) + write(val, '(ES16.6)') scale*Array(i,j) + mesg = trim(mesg)//" "//trim(val) ; n = n + 1 + if (n >= 12) then + write(iounit, '(2X,A)') trim(mesg) + mesg = "" ; n = 0 + endif + enddo ; enddo + endif + if (n > 0) write(iounit, '(2X,A)') trim(mesg) + endif + + if (scale == 1.0) then + call chksum(Array, name) + else + call chksum(scale*Array(:,:), name) + endif + end subroutine write_2d_array_vals + + !> Write out the values in a 3-d segment data array + subroutine write_3d_array_vals(name, Array, seg_dir, nkp, unscale) + character(len=*), intent(in) :: name !< The name of the variable + real, dimension(:,:,:), intent(in) :: Array !< The 3-d array to write + integer, intent(in) :: seg_dir !< The direction of the segment + integer, intent(in) :: nkp !< The number of layers to print + real, optional, intent(in) :: unscale !< A factor that undoes the scaling of the array [a A-1 ~> 1] + ! Local variables + real :: scale ! A factor that undoes the scaling of the array [a A-1 ~> 1] + logical :: reverse + character(len=1024) :: mesg + character(len=24) :: val + integer :: i, j, k, n, nk, iounit + + scale = 1.0 ; if (present(unscale)) scale = unscale + iounit = stderr + + if (nkp > 0) then + nk = min(nkp, size(Array,3)) + write(iounit, '(2X,A,":")') trim(name) + do k=1,nk + mesg = "" ; n = 0 + if ((seg_dir == OBC_DIRECTION_N) .or. (seg_dir == OBC_DIRECTION_W)) then + do j=size(Array,2),1,-1 ; do i=size(Array,1),1,-1 + write(val, '(ES16.6)') scale*Array(i,j,k) + mesg = trim(mesg)//" "//trim(val) ; n = n + 1 + if (n >= 12) then + write(iounit, '(2X,A)') trim(mesg) + mesg = "" ; n = 0 + endif + enddo ; enddo + else + do j=1,size(Array,2) ; do i=1,size(Array,1) + write(val, '(ES16.6)') scale*Array(i,j,k) + mesg = trim(mesg)//" "//trim(val) ; n = n + 1 + if (n >= 12) then + write(iounit, '(2X,A)') trim(mesg) + mesg = "" ; n = 0 + endif + enddo ; enddo + endif + if (n > 0) write(iounit, '(2X,A)') trim(mesg) + enddo + endif + + if (scale == 1.0) then + call chksum(Array, name) + else + call chksum(scale*Array(:,:,:), name) + endif + + end subroutine write_3d_array_vals + +end subroutine chksum_OBC_segments + !> \namespace mom_open_boundary !! This module implements some aspects of internal open boundary !! conditions in MOM. diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index cc5059bd48..c6483f8cef 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -101,8 +101,9 @@ module MOM_variables ! These arrays are accumulated fluxes for communication with other components. real, dimension(:,:), pointer :: frazil => NULL() !< The energy needed to heat the ocean column to the - !! freezing point since calculate_surface_state was2 + !! freezing point since calculate_surface_state was !! last called [Q Z R ~> J m-2]. + logical :: frazil_was_reset !< If true, frazil has not accumulated since it was last reset. real, dimension(:,:), pointer :: salt_deficit => NULL() !< The salt needed to maintain the ocean column !! at a minimum salinity of MIN_SALINITY since the last time diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 85af39e377..64c4de070e 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -659,7 +659,7 @@ subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call uvchksum(mesg, u_comp, v_comp, G%HI, halos, scale=unscale) + call uvchksum(mesg, u_comp, v_comp, G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then @@ -691,7 +691,7 @@ subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars, unscale) are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call uvchksum(mesg, u_comp, v_comp, G%HI, halos, scale=unscale) + call uvchksum(mesg, u_comp, v_comp, G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then @@ -723,8 +723,8 @@ subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call Bchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) - call Bchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) + call Bchksum(u_comp, mesg//"(u)", G%HI, halos, unscale=unscale) + call Bchksum(v_comp, mesg//"(v)", G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then @@ -758,8 +758,8 @@ subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric, un are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call Bchksum(u_comp, mesg//"(u)", G%HI, halos, symmetric=symmetric, scale=unscale) - call Bchksum(v_comp, mesg//"(v)", G%HI, halos, symmetric=symmetric, scale=unscale) + call Bchksum(u_comp, mesg//"(u)", G%HI, halos, symmetric=symmetric, unscale=unscale) + call Bchksum(v_comp, mesg//"(v)", G%HI, halos, symmetric=symmetric, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then @@ -791,8 +791,8 @@ subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call hchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) - call hchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) + call hchksum(u_comp, mesg//"(u)", G%HI, halos, unscale=unscale) + call hchksum(v_comp, mesg//"(v)", G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then @@ -824,8 +824,8 @@ subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars, unscale) are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call hchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) - call hchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) + call hchksum(u_comp, mesg//"(u)", G%HI, halos, unscale=unscale) + call hchksum(v_comp, mesg//"(v)", G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then diff --git a/src/diagnostics/MOM_diagnose_KdWork.F90 b/src/diagnostics/MOM_diagnose_KdWork.F90 index 12f8191619..8b89933169 100644 --- a/src/diagnostics/MOM_diagnose_KdWork.F90 +++ b/src/diagnostics/MOM_diagnose_KdWork.F90 @@ -340,7 +340,7 @@ subroutine KdWork_Diagnostics(G,GV,US,diag,VBF,N2_Salt,N2_Temp,dz) 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 + elseif (VBF%id_Bdif_bkgnd>0) then call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_bkgnd, VBF%Bflx_salt) call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_bkgnd, VBF%Bflx_temp) endif @@ -783,37 +783,40 @@ subroutine Allocate_VBF_CS(G, GV, VBF) 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 ) & + if (VBF%id_Bdif_salt_dz>0 .or. VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_salt>0 .or. VBF%id_Bdif>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_salt_idz>0 .or. VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_salt_idV>0) & allocate(VBF%Kd_salt(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%do_bflx_temp .or. VBF%do_bflx_temp_dz ) & + if (VBF%id_Bdif_temp_dz>0 .or. VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_temp>0 .or. VBF%id_Bdif>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_temp_idz>0 .or. VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_temp_idV>0) & allocate(VBF%Kd_temp(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_BBL>0 .or. VBF%id_Bdif_dz_BBL>0 .or. VBF%id_Bdif_idV_BBL>0) & + + if (VBF%id_Bdif_BBL>0 .or. VBF%id_Bdif_dz_BBL>0 .or. VBF%id_Bdif_idz_BBL>0 .or. VBF%id_Bdif_idV_BBL>0) & allocate(VBF%Kd_BBL(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_ePBL>0 .or. VBF%id_Bdif_dz_ePBL>0 .or. VBF%id_Bdif_idV_ePBL>0) & + if (VBF%id_Bdif_ePBL>0 .or. VBF%id_Bdif_dz_ePBL>0 .or. VBF%id_Bdif_idz_ePBL>0 .or. VBF%id_Bdif_idV_ePBL>0) & allocate(VBF%Kd_ePBL(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_KS>0 .or. VBF%id_Bdif_dz_KS>0 .or. VBF%id_Bdif_idV_KS>0) & + if (VBF%id_Bdif_KS>0 .or. VBF%id_Bdif_dz_KS>0 .or. VBF%id_Bdif_idz_KS>0 .or. VBF%id_Bdif_idV_KS>0) & allocate(VBF%Kd_KS(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_bkgnd>0 .or. VBF%id_Bdif_dz_bkgnd>0 .or. VBF%id_Bdif_idV_bkgnd>0) & + if (VBF%id_Bdif_bkgnd>0 .or. VBF%id_Bdif_dz_bkgnd>0 .or. VBF%id_Bdif_idz_bkgnd>0 .or. VBF%id_Bdif_idV_bkgnd>0) & allocate(VBF%Kd_bkgnd(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_ddiff_temp>0 .or. VBF%id_Bdif_dz_ddiff_temp>0 .or. VBF%id_Bdif_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) & + if (VBF%id_Bdif_ddiff_temp>0 .or. VBF%id_Bdif_dz_ddiff_temp>0 .or. VBF%id_Bdif_idz_ddiff_temp>0 & + .or. VBF%id_Bdif_idV_ddiff_temp>0) allocate(VBF%Kd_ddiff_T(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_ddiff_salt>0 .or. VBF%id_Bdif_dz_ddiff_salt>0 .or. VBF%id_Bdif_idV_ddiff_salt>0 & + .or. VBF%id_Bdif_idV_ddiff_salt>0) allocate(VBF%Kd_ddiff_S(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_leak>0 .or. VBF%id_Bdif_dz_leak>0 .or. VBF%id_Bdif_idz_leak>0 .or. VBF%id_Bdif_idV_leak>0) & allocate(VBF%Kd_leak(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_quad>0 .or. VBF%id_Bdif_dz_quad>0 .or. VBF%id_Bdif_idV_quad>0) & + if (VBF%id_Bdif_quad>0 .or. VBF%id_Bdif_dz_quad>0 .or. VBF%id_Bdif_idz_quad>0 .or. VBF%id_Bdif_idV_quad>0) & allocate(VBF%Kd_quad(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_itidal>0 .or. VBF%id_Bdif_dz_itidal>0 .or. VBF%id_Bdif_idV_itidal>0) & + if (VBF%id_Bdif_itidal>0 .or. VBF%id_Bdif_dz_itidal>0 .or. VBF%id_Bdif_idz_itidal>0 .or. VBF%id_Bdif_idV_itidal>0) & allocate(VBF%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_Froude>0 .or. VBF%id_Bdif_dz_Froude>0 .or. VBF%id_Bdif_idV_Froude>0) & + if (VBF%id_Bdif_Froude>0 .or. VBF%id_Bdif_dz_Froude>0 .or. VBF%id_Bdif_idz_Froude>0 .or. VBF%id_Bdif_idV_Froude>0) & allocate(VBF%Kd_Froude(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_slope>0 .or. VBF%id_Bdif_dz_slope>0 .or. VBF%id_Bdif_idV_slope>0) & + if (VBF%id_Bdif_slope>0 .or. VBF%id_Bdif_dz_slope>0 .or. VBF%id_Bdif_idz_slope>0 .or. VBF%id_Bdif_idV_slope>0) & allocate(VBF%Kd_slope(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_lowmode>0 .or. VBF%id_Bdif_dz_lowmode>0 .or. VBF%id_Bdif_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) & + if (VBF%id_Bdif_lowmode>0 .or. VBF%id_Bdif_dz_lowmode>0 .or. VBF%id_Bdif_idz_lowmode>0 .or. & + VBF%id_Bdif_idV_lowmode>0) allocate(VBF%Kd_lowmode(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_Niku>0 .or. VBF%id_Bdif_dz_Niku>0 .or. VBF%id_Bdif_idz_Niku>0 .or. VBF%id_Bdif_idV_Niku>0) & allocate(VBF%Kd_Niku(isd:ied,jsd:jed,nz+1), source=0.0) - if (VBF%id_Bdif_itides>0 .or. VBF%id_Bdif_dz_itides>0 .or. VBF%id_Bdif_idV_itides>0) & + if (VBF%id_Bdif_itides>0 .or. VBF%id_Bdif_dz_itides>0 .or. VBF%id_Bdif_idz_itides>0 .or. VBF%id_Bdif_idV_itides>0) & allocate(VBF%Kd_itides(isd:ied,jsd:jed,nz+1), source=0.0) end subroutine Allocate_VBF_CS diff --git a/src/diagnostics/MOM_diagnose_MLD.F90 b/src/diagnostics/MOM_diagnose_MLD.F90 index d8cadb5bdd..bd1bcc8ab8 100644 --- a/src/diagnostics/MOM_diagnose_MLD.F90 +++ b/src/diagnostics/MOM_diagnose_MLD.F90 @@ -246,7 +246,7 @@ 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, MLD_out) +subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, k_bounds, diagPtr, OM4_iteration, MLD_out) ! Author: Brandon Reichl ! Date: October 2, 2020 ! // @@ -278,6 +278,9 @@ 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 + integer, dimension(2), intent(in) :: k_bounds !< vertical interface bounds to apply calculations + logical, optional, intent(in) :: OM4_iteration !< Uses a legacy version of the MLD iteration + !! it is kept to reproduce OM4 output real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: MLD_out !< Send MLD to other routines [Z ~> m] @@ -315,11 +318,16 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr, real :: Gpx ! The derivative of Gx with x [R Z2 ~> kg m-1] real :: Hx ! The vertical integral depth [Z ~> m] real :: iHx ! The inverse of Hx [Z-1 ~> m-1] - real :: Hpx ! The derivative of Hx with x, hard coded to 1. Why? [nondim] + real :: Hpx ! The derivative of Hx with x, since H(x) = constant + x, its derivative is 1. [nondim] real :: Ix ! A double integral in depth of density [R Z2 ~> kg m-1] real :: Ipx ! The derivative of Ix with x [R Z ~> kg m-2] real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] + real :: Zr ! An upper (lower) bound for the PE integration in surface (bottom) mixed layer mode [Z ~> m] + integer :: k_Zr ! Sets the index of Zr + real :: pe_dir ! A factor that is used to generalize the iteration for upper and lower mixed layers + integer :: k_int ! Controls the direction of the loop to be forward or backward + logical :: use_OM4_iteration ! A logical to use the OM4_iteration if the optional argument is present integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: IT, iM @@ -327,31 +335,66 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (present(OM4_iteration)) then + use_OM4_iteration = OM4_iteration + endif + pRef_MLD(:) = 0.0 mld(:,:,:) = 0.0 PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. + ! The derivative of H(x) is always 1., so it is moved outside the loops. + Hpx = 1. + do iM=1,3 PE_threshold(iM) = Mixing_Energy(iM) / GV%g_Earth_Z_T2 enddo EOSdom(:) = EOS_domain(G%HI) + if (k_bounds(1)0) then + ! We want to reference pressure to bottom for upward calculation + pRef_MLD(:) = 0.0 + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + do k=1,nz + pRef_MLD(i) = pRef_MLD(i) + h(i,j,k)*GV%H_to_RZ*GV%g_Earth + enddo + endif ; enddo + endif do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD, rho_c(:,k), tv%eqn_of_state, EOSdom) + call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD(:), rho_c(:,k), tv%eqn_of_state, EOSdom) enddo do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + !We reference everything to the SSH, so that Z_int(1) is defined where Z=0. + ! All presently implemented calculations are not sensitive to this choice. + ! If "use_OM4_iteration = .true." setting this non-zero would break the iteration Z_int(1) = 0.0 do k=1,nz Z_int(K+1) = Z_int(K) - dZ(i,k) enddo + ! Set the reference for the upper (lower) bound of the mixing integral as the surface + ! or the bottom depending on the direction of the calculation (as determined by + ! the interface bounds k_bounds) + Zr = Z_int(k_Zr) + do iM=1,3 ! Initialize these for each column-wise calculation @@ -362,10 +405,15 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr, H_ML_TST = 0.0 PE_Mixed = 0.0 - do k=1,nz + do k=k_bounds(1),k_bounds(2),k_int - ! This is the unmixed PE cumulative sum from top down - PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) + ! This is the unmixed PE cumulative sum in the direction k_int + ! The first expression preserves OM4 diagnostic answers, the second is more robust + if (use_OM4_iteration) then + PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) + else + PE = PE + 0.5 * (Rho_c(i,k) * dZ(i,k)) * (Z_int(K) + Z_int(K+1)) + endif ! This is the depth and integral of density H_ML_TST = H_ML + dZ(i,k) @@ -375,65 +423,120 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr, Rho_ML = RhoDZ_ML_TST/H_ML_TST ! The PE assuming all layers including this were mixed - ! Note that 0. could be replaced with "Surface", which doesn't have to be 0 - ! but 0 is a good reference value. - PE_Mixed_TST = 0.5 * Rho_ML * (0.**2 - (0. - H_ML_TST)**2) + ! Zr is the upper (lower) bound of the integral when operating in surface (bottom) + ! mixed layer calculation mode. + !These are mathematically equivalent, the latter is numerically well-behaved, but the + ! former is kept as a comment as it may be more intuitive how it is derived. + !PE_Mixed_TST = (0.5 * (Rho_ML*pe_dir)) * ( (Zr + pe_dir*H_ML_TST)**2 - Zr**2.) + PE_Mixed_TST = (0.5 * (Rho_ML*pe_dir)) * (H_ML_TST * (H_ML_TST + 2.0*pe_dir*Zr)) ! Check if we supplied enough energy to mix to this layer if (PE_Mixed_TST - PE <= PE_threshold(iM)) then H_ML = H_ML_TST RhoDZ_ML = RhoDZ_ML_TST - - else ! If not, we need to solve where the energy ran out + else ! If not, we need to solve where the energy ran out within the layer ! This will be done with a Newton's method iteration: - R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) - D1 = H_ML ! The thickness of the mixed layer (not including this layer) - R2 = Rho_c(i,k) ! The density of this layer - D2 = dZ(i,k) ! The thickness of this layer - - ! This block could be used to calculate the function coefficients if - ! we don't reference all values to a surface designated as z=0 - ! S = Surface - ! Ca = -(R2) - ! Cb = -( (R1*D1) + R2*(2.*D1-2.*S) ) - ! D = D1**2. - 2.*D1*S - ! Cc = -( R1*D1*(2.*D1-2.*S) + R2*D ) - ! Cd = -(R1*D1*D) - ! Ca2 = R2 - ! Cb2 = R2*(2*D1-2*S) - ! C = S**2 + D2**2 + D1**2 - 2*D1*S - 2.*D2*S +2.*D1*D2 - ! Cc2 = R2*(D+S**2-C) - ! - ! If the surface is S = 0, it simplifies to: - Ca = -R2 - Cb = -(R1 * D1 + R2 * (2. * D1)) - D = D1**2 - Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) - Cd = -R1 * (D1 * D) - Ca2 = R2 - Cb2 = R2 * (2. * D1) - C = D2**2 + D1**2 + 2. * (D1 * D2) - Cc2 = R2 * (D - C) - ! First guess for an iteration using Newton's method X = dZ(i,k) * 0.5 + ! We are trying to solve the function: + ! F(x) = G(x)/H(x)+I(x) + ! for where F(x) = PE+PE_threshold, or equivalently for where + ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 + ! We also need the derivative of this function for the Newton's method iteration + ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) + ! + !For the Surface Boundary Layer: + ! The total function F(x) adds the PE of the top layer with some entrained distance X + ! to the PE of the bottom layer below the entrained distance: + ! (Rho1*D1+Rho2*x) + ! PE = ---------------- (Zr^2 - (Zr-D1-x)^2) + Rho2 * ((Zr-D1-x)^2 - (Zr-D1-D2)^2) + ! (D1 + x) + ! + ! where Rho1 is the mixed density, D1 is the mixed thickness, Rho2 is the unmixed density, + ! D2 is the unmixed thickness, Zr is the top surface height, and x is the fraction of the + ! unmixed region that becomes mixed. + ! + !// + !G(x) = (Rho1*D1+Rho2*x)*(Zr^2 - (Zr-(D1+x))^2) + ! + ! = -Rho2 * x^3 + (-Rho1*D1-2*Rho2*D1+2*Rho2*Zr)*x^2 + ! \-Ca-/ \--------Cb----------------/ + ! + ! + (-2*Rho1*D1^2+2*Rho1*D1*Zr-Rho2*D1^2+Rho2*2*D1*Zr)*X + Rho1*(-D1^3+2*D1^2*Zr) + ! \----------------------Cc----------------------/ \-------Cd----------/ + ! + !// + !H(x) = D1 + x + ! + !// + !I(x) = Rho2 * ((Zr-(D1+x))^2-(Zr-(D1+D2))^2) + ! = Rho2 * x^2 + Rho2*(2*D1-2*Zr) * X + Rho2*(D1^2-2*D1*Zr-D2^2+D1^2-2*D1*Zr-2*D2*Zr+2*D1*D2) + ! \Ca2/ \-----Cb2-----/ \-------------------Cc2----------------------------/ + ! + ! + !For the Bottom Boundary Layer: + ! The total function is relative to Zr as the bottom interface height, so slightly different: + ! (Rho1*D1+Rho2*X) + ! PE = ---------------- ((Zr+D1+X)^2 - Zr^2) + Rho2 * ((Zr+D1+D2)^2 - (Zr+D1+X)^2) + ! (D1 + X) + ! These differences propagate through and are accounted for via the factor pe_dir + ! + ! Set these coefficients before the iteration + R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) + D1 = H_ML ! The thickness of the mixed layer (not including this layer) + R2 = Rho_c(i,k) ! The density of this layer to be mixed + D2 = dZ(i,k) ! The thickness of this layer to be mixed + + ! This sets Zr to "0", which only works for the downward surface mixed layer calculation. + ! it should give the same answer at roundoff as the more general expressions below. + if (k_int>0 .and. use_OM4_iteration) then + Ca = -(R2) + Cb = -(R1 * D1 + R2 * (2. * D1)) + D = D1**2 + Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) + Cd = -R1 * (D1 * D) + Ca2 = R2 + Cb2 = R2 * (2. * D1) + C = D2**2 + D1**2 + 2. * (D1 * D2) + D = D1**2 + Cc2 = R2 * (D - C) + else + ! recall pe_dir = -1 for down, pe_dir = 1 for up. + !down Ca = -R2 + !up Ca = R2 + Ca = pe_dir * R2 ! Density of layer to be mixed + !down Cb = -(R1*D1) - 2.*R2*D1 + 2.*Zr*R2 + !up Cb = (R1*D1) + 2.*R2*D1 + 2.*Zr*R2 + Cb = pe_dir * ( (R1 * D1) + (2. * R2) * ( D1 + Zr ) ) + !down Cc = -2.*R1*D1**2 - R2*D1**2 + 2.*R2*D1*Zr + 2.*Zr*R1*D1 + !up Cc = 2.*R1*D1**2 + R2*D1**2 + 2.*R2*D1*Zr + 2.*Zr*R1*D1 + Cc = ( pe_dir * D1**2 ) * ( R2 + 2.*R1 ) + ( 2. * ( Zr * D1 ) ) * ( R2 + R1 ) + !down Cd = R1*(-D1**3+2.*D1**2*Zr) + !up Cd = R1*( D1**3+2.*D1**2*Zr) + Cd = ( R1 * D1**2 ) * ( pe_dir * D1 + 2. * Zr ) + !down Ca2 = R2 + !up Ca2 = -R2 + Ca2 = ( -1. * pe_dir ) * R2 + !down Cb2 = R2*(2*D1-2*Zr) + !up Cb2 = R2*(-2*D1-2*Zr) + Cb2 = ( 2. * R2 ) * ( (-1.*pe_dir)*D1 - Zr ) + !down Cc2 = R2*(2.*Zr*D2-2.*D1*D2-D2**2) + !up Cc2 = R2*(2.*Zr*D2+2.*D1*D2+D2**2) + Cc2 = ( R2 * D2 ) * ( 2.* Zr + pe_dir * ( 2. * D1 + D2 ) ) + endif + IT=0 do while(IT<10)!We can iterate up to 10 times - ! We are trying to solve the function: - ! F(x) = G(x)/H(x)+I(x) - ! for where F(x) = PE+PE_threshold, or equivalently for where - ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 - ! We also need the derivative of this function for the Newton's method iteration - ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) + ! G and its derivative Gx = 0.5 * (Ca * (X*X*X) + Cb * X**2 + Cc * X + Cd) Gpx = 0.5 * (3. * (Ca * X**2) + 2. * (Cb * X) + Cc) ! H, its inverse, and its derivative Hx = D1 + X iHx = 1. / Hx - Hpx = 1. + !Hpx = 1. ! The derivative is always 1 so it was moved outside the loop ! I and its derivative Ix = 0.5 * (Ca2 * X**2 + Cb2 * X + Cc2) Ipx = 0.5 * (2. * Ca2 * X + Cb2) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index d164363ec4..6c220c79cf 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -24,7 +24,7 @@ module MOM_diagnostics use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, find_col_mass use MOM_spatial_means, only : global_area_mean, global_layer_mean use MOM_spatial_means, only : global_volume_mean, global_area_integral use MOM_tracer_registry, only : tracer_registry_type, post_tracer_transport_diagnostics @@ -39,7 +39,6 @@ module MOM_diagnostics #include public calculate_diagnostic_fields, register_time_deriv, write_static_fields -public find_eta public register_surface_diags, post_surface_dyn_diags, post_surface_thermo_diags public register_transport_diags, post_transport_diagnostics public MOM_diagnostics_init, MOM_diagnostics_end @@ -903,7 +902,6 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) btm_pres,&! The pressure at the ocean bottom, or CMIP variable 'pbo'. ! This is the column mass multiplied by gravity plus the pressure ! at the ocean surface [R L2 T-2 ~> Pa]. - dpress, & ! Change in hydrostatic pressure across a layer [R L2 T-2 ~> Pa]. tr_int ! vertical integral of a tracer times density, ! (Rho_0 in a Boussinesq model) [Conc R Z ~> Conc kg m-2]. real :: IG_Earth ! Inverse of gravitational acceleration [T2 Z L-2 ~> s2 m-1]. @@ -943,52 +941,14 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) call post_data(CS%id_col_ht, z_bot, CS%diag) endif - ! NOTE: int_density_z expects z_top and z_btm values from [ij]sq to [ij]eq+1 if (CS%id_col_mass > 0 .or. CS%id_pbo > 0) then - do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo - if (GV%Boussinesq) then - if (associated(tv%eqn_of_state)) then - IG_Earth = 1.0 / GV%g_Earth - do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 - z_bot(i,j) = 0.0 - enddo ; enddo - do k=1,nz - do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 - z_top(i,j) = z_bot(i,j) - z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) - enddo ; enddo - call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & - G%HI, tv%eqn_of_state, US, dpress) - do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth - enddo ; enddo - enddo - else - do k=1,nz ; do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + (GV%H_to_Z*GV%Rlay(k))*h(i,j,k) - enddo ; enddo ; enddo - endif - else - do k=1,nz ; do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + GV%H_to_RZ*h(i,j,k) - enddo ; enddo ; enddo - endif - if (CS%id_col_mass > 0) then - call post_data(CS%id_col_mass, mass, CS%diag) - endif if (CS%id_pbo > 0) then - do j=js,je ; do i=is,ie ; btm_pres(i,j) = 0.0 ; enddo ; enddo - ! 'pbo' is defined as the sea water pressure at the sea floor - ! pbo = (mass * g) + p_surf - ! where p_surf is the sea water pressure at sea water surface. - do j=js,je ; do i=is,ie - btm_pres(i,j) = GV%g_Earth * mass(i,j) - if (associated(p_surf)) then - btm_pres(i,j) = btm_pres(i,j) + p_surf(i,j) - endif - enddo ; enddo + call find_col_mass(h, tv, G, GV, US, mass, btm_pres, p_surf) call post_data(CS%id_pbo, btm_pres, CS%diag) + else + call find_col_mass(h, tv, G, GV, US, mass) endif + if (CS%id_col_mass > 0) call post_data(CS%id_col_mass, mass, CS%diag) endif end subroutine calculate_vertical_integrals diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 3971e04350..b7202aade1 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -115,6 +115,7 @@ module MOM_sum_output !! including ENERGYSAVEDAYS [s]. logical :: date_stamped_output !< If true, use dates (not times) in messages to stdout. + logical :: ISO_date_stamped_output !< If true, use ISO formatted dates in messages to stdout. type(time_type) :: Start_time !< The start time of the simulation. ! Start_time is set in MOM_initialization.F90 integer, pointer :: ntrunc => NULL() !< The number of times the velocity has been @@ -238,6 +239,9 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & call get_param(param_file, mdl, "DATE_STAMPED_STDOUT", CS%date_stamped_output, & "If true, use dates (not times) in messages to stdout", & default=.true.) + call get_param(param_file, mdl, "ISO_DATE_STAMPED_STDOUT", CS%ISO_date_stamped_output, & + "If true, use ISO formatted dates in messages to stdout", & + default=.false.) ! Note that the units of CS%Timeunit are the MKS units of [s]. call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & "The time unit in seconds a number of input fields", & @@ -419,8 +423,8 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci real :: reday ! Time in units given by CS%Timeunit, but often [days] character(len=240) :: energypath_nc character(len=200) :: mesg - character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str - logical :: date_stamped + character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str, ISO_date_str + logical :: date_stamped, ISO_date_stamped type(time_type) :: dt_force ! A time_type version of the forcing timestep. real :: S_min ! The global minimum unmasked value of the salinity [ppt] @@ -834,7 +838,8 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci call get_time(day, start_of_day, num_days) date_stamped = (CS%date_stamped_output .and. (get_calendar_type() /= NO_CALENDAR)) - if (date_stamped) & + ISO_date_stamped = (CS%ISO_date_stamped_output .and. (get_calendar_type() /= NO_CALENDAR)) + if (date_stamped .or. ISO_date_stamped) & call get_date(day, iyear, imonth, iday, ihour, iminute, isecond, itick) if (abs(CS%timeunit - 86400.0) < 1.0) then reday = REAL(num_days)+ (REAL(start_of_day)/86400.0) @@ -853,12 +858,13 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci elseif (n < 100000000) then ; write(n_str, '(I8)') n else ; write(n_str, '(I10)') n ; endif - if (date_stamped) then + date_str = trim(mesg_intro)//trim(day_str) + if (date_stamped) & write(date_str,'("MOM Date",i7,2("/",i2.2)," ",i2.2,2(":",i2.2))') & iyear, imonth, iday, ihour, iminute, isecond - else - date_str = trim(mesg_intro)//trim(day_str) - endif + if (ISO_date_stamped) & + write(ISO_date_str,'(i7.4,2(i2.2),"T",i2.2,2(i2.2))') & + iyear, imonth, iday, ihour, iminute, isecond if (is_root_pe()) then ! Only the root PE actually writes anything. if (CS%use_temperature) then @@ -872,17 +878,33 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci endif if (CS%use_temperature) then - write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& - &es11.4,", M ",ES11.5,", S",f8.4,", T",f8.4,& - &", Me ",ES9.2,", Se ",ES9.2,", Te ",ES9.2)') & - trim(n_str), trim(day_str), CS%ntrunc, 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 + if (ISO_date_stamped) then + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& + &es11.4,", M ",ES11.5,", S",f8.4,", T",f8.4,& + &", Me ",ES9.2,", Se ",ES9.2,", Te ",ES9.2)') & + trim(n_str), trim(ISO_date_str), CS%ntrunc, US%L_T_to_m_s**2*En_mass, max_CFL(1), & + -US%Z_to_m*Z_0APE(1), US%RZL2_to_kg*mass_tot, salin, US%C_to_degC*temp, mass_anom/mass_tot, & + salin_anom, US%C_to_degC*temp_anom + else + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& + &es11.4,", M ",ES11.5,", S",f8.4,", T",f8.4,& + &", Me ",ES9.2,", Se ",ES9.2,", Te ",ES9.2)') & + trim(n_str), trim(day_str), CS%ntrunc, US%L_T_to_m_s**2*En_mass, max_CFL(1), & + -US%Z_to_m*Z_0APE(1), US%RZL2_to_kg*mass_tot, salin, US%C_to_degC*temp, mass_anom/mass_tot, & + salin_anom, US%C_to_degC*temp_anom + endif else - write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& - &ES11.4,", Mass ",ES11.5,", Me ",ES9.2)') & - trim(n_str), trim(day_str), CS%ntrunc, 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 + if (ISO_date_stamped) then + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& + &ES11.4,", Mass ",ES11.5,", Me ",ES9.2)') & + trim(n_str), trim(ISO_date_str), CS%ntrunc, US%L_T_to_m_s**2*En_mass, max_CFL(1), & + -US%Z_to_m*Z_0APE(1), US%RZL2_to_kg*mass_tot, mass_anom/mass_tot + else + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& + &ES11.4,", Mass ",ES11.5,", Me ",ES9.2)') & + trim(n_str), trim(day_str), CS%ntrunc, US%L_T_to_m_s**2*En_mass, max_CFL(1), & + -US%Z_to_m*Z_0APE(1), US%RZL2_to_kg*mass_tot, mass_anom/mass_tot + endif endif if (CS%ntrunc > 0) then diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 4c7f86668c..0227ef78e7 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, gsw_sr_from_sp +use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp, gsw_ct_from_pt use MOM_temperature_convert, only : poTemp_to_consTemp, consTemp_to_poTemp use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero use MOM_TFreeze, only : calculate_TFreeze_teos10, calculate_TFreeze_TEOS_poly @@ -34,7 +34,7 @@ module MOM_EOS public EOS_init public EOS_manual_init public EOS_quadrature -public EOS_use_linear +! public EOS_use_linear public EOS_fit_range public EOS_unit_tests public analytic_int_density_dz @@ -115,11 +115,19 @@ module MOM_EOS real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] real :: dRho_dT !< The partial derivative of density with temperature [kg m-3 degC-1] real :: dRho_dS !< The partial derivative of density with salinity [kg m-3 ppt-1] + real :: dRho_dp !< The partial derivative of density with pressure [s2 m-2] ! The following parameters are use with the linear expression for the freezing ! point only. real :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] real :: dTFr_dS !< The derivative of freezing point with salinity [degC ppt-1] real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1] +! The following are logicals pertaining to definitions of the thermodynamic state variables + logical :: use_conT_absS =.false. !< True if the model internal temperature is the conservative temperature and + !! the salinity is absolute salinity. These could be separated into two flags, + !! but right now it is controlled by one input parameter and there is no known + !! need to have one True and one False. + logical :: TFreeze_S_is_pracS =.true. !< True if the freezing point expression is formulated from practical salinity + logical :: TFreeze_T_is_potT = .true. !< True if the freezing point expression yields a potential temperature logical :: use_Wright_2nd_deriv_bug = .false. !< If true, use a separate subroutine that !! retains a buggy version of the calculations of the second @@ -529,28 +537,50 @@ subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale, scale_fr ! Local variables real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] real :: S_scale ! A factor to convert salinity to units of ppt [ppt S-1 ~> 1] + real :: iS_scale! A factor to convert salinity to units of S [S ppt-1 ~> 1] + real :: absS ! A salinity converted to absolute salinity, only used in specific scenarios [ppt] + real :: TFreeze_S ! The salinity for the freezing equation in model units [S ~> PSU or ppt] - p_scale = 1.0 ; S_scale = 1.0 + p_scale = 1.0 ; S_scale = 1.0 ; iS_scale = 1.0 if (present(pres_scale)) p_scale = pres_scale if (present(scale_from_EOS)) then ; if (scale_from_EOS) then p_scale = EOS%RL2_T2_to_Pa S_scale = EOS%S_to_ppt + iS_scale = EOS%ppt_to_S endif ; endif + if (EOS%use_conT_absS) then + ! Otherwise absS is unneeded and therefore unset + absS = S*S_scale + if (EOS%TFreeze_S_is_pracS) then + TFreeze_S = gsw_sp_from_sr(absS)*iS_scale + else + TFreeze_S = S + endif + else + TFreeze_S = S + endif + select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S_scale*S, p_scale*pressure, T_fr, EOS%TFr_S0_P0, & + call calculate_TFreeze_linear(S_scale*TFreeze_S, p_scale*pressure, T_fr, EOS%TFr_S0_P0, & EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S_scale*S, p_scale*pressure, T_fr) + call calculate_TFreeze_Millero(S_scale*TFreeze_S, p_scale*pressure, T_fr) case (TFREEZE_TEOSPOLY) - call calculate_TFreeze_TEOS_poly(S_scale*S, p_scale*pressure, T_fr) + call calculate_TFreeze_TEOS_poly(S_scale*TFreeze_S, p_scale*pressure, T_fr) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S_scale*S, p_scale*pressure, T_fr) + call calculate_TFreeze_teos10(S_scale*TFreeze_S, p_scale*pressure, T_fr) case default call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select + if (EOS%use_conT_absS .and. EOS%TFreeze_T_is_potT) then + ! absS is set only if EOS%use_conT_absS is True + ! absS and T_fr have physical units here and don't need converted + T_fr = gsw_ct_from_pt(absS,T_fr) + endif + if (present(scale_from_EOS)) then ; if (scale_from_EOS) then T_fr = EOS%degC_to_C * T_fr endif ; endif @@ -561,8 +591,8 @@ end subroutine calculate_TFreeze_scalar subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_scale) real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure, in [Pa] or [R L2 T-2 ~> Pa] depending on pres_scale - real, dimension(:), intent(inout) :: T_fr !< Freezing point potential temperature referenced - !! to the surface [degC] + real, dimension(:), intent(inout) :: T_fr !< Freezing point, either potential temperature referenced to the + !! surface or conservative temperature depending on settings [degC] integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), intent(in) :: EOS !< Equation of state structure @@ -572,21 +602,35 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_sca ! Local variables real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real, dimension(size(S)) :: absS ! A salinity converted to absolute salinity, only used in specific scenarios [ppt] + real, dimension(size(S)) :: TFreeze_S ! The salinity for the freezing equation in model units [S ~> PSU or ppt] integer :: j p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + if (EOS%use_conT_absS) then + ! Otherwise absS is unneeded and therefore unset + absS(:) = S(:) + if (EOS%TFreeze_S_is_pracS) then + TFreeze_S(:) = gsw_sp_from_sr(absS(:)) + else + TFreeze_S(:) = S(:) + endif + else + TFreeze_S(:) = S(:) + endif + if (p_scale == 1.0) then select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, pressure, T_fr, start, npts, & + call calculate_TFreeze_linear(TFreeze_S, pressure, T_fr, start, npts, & EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, pressure, T_fr, start, npts) + call calculate_TFreeze_Millero(TFreeze_S, pressure, T_fr, start, npts) case (TFREEZE_TEOSPOLY) - call calculate_TFreeze_TEOS_poly(S, pressure, T_fr, start, npts) + call calculate_TFreeze_TEOS_poly(TFreeze_S, pressure, T_fr, start, npts) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, pressure, T_fr, start, npts) + call calculate_TFreeze_teos10(TFreeze_S, pressure, T_fr, start, npts) case default call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select @@ -594,19 +638,25 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_sca do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, pres, T_fr, start, npts, & + call calculate_TFreeze_linear(TFreeze_S, pres, T_fr, start, npts, & EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, pres, T_fr, start, npts) + call calculate_TFreeze_Millero(TFreeze_S, pres, T_fr, start, npts) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, pres, T_fr, start, npts) + call calculate_TFreeze_teos10(TFreeze_S, pres, T_fr, start, npts) case (TFREEZE_TEOSPOLY) - call calculate_TFreeze_TEOS_poly(S, pres, T_fr, start, npts) + call calculate_TFreeze_TEOS_poly(TFreeze_S, pres, T_fr, start, npts) case default call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select endif + if (EOS%use_conT_absS .and. EOS%TFreeze_T_is_potT) then + ! absS is set only if EOS%use_conT_absS is True! + T_fr(:) = gsw_ct_from_pt(absS(:),T_fr(:)) + endif + + end subroutine calculate_TFreeze_array !> Calls the appropriate subroutine to calculate the freezing point for a 1-D array, taking @@ -614,8 +664,9 @@ end subroutine calculate_TFreeze_array subroutine calculate_TFreeze_1d(S, pressure, T_fr, EOS, dom) real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] - real, dimension(:), intent(inout) :: T_fr !< Freezing point potential temperature referenced - !! to the surface [C ~> degC] + real, dimension(:), intent(inout) :: T_fr !< Freezing point, either potential temperature referenced to the + !! surface or conservative temperature depending on settings + !! [C ~> degC] type(EOS_type), intent(in) :: EOS !< Equation of state structure integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking !! into account that arrays start at 1. @@ -623,6 +674,8 @@ subroutine calculate_TFreeze_1d(S, pressure, T_fr, EOS, dom) ! Local variables real, dimension(size(T_fr)) :: pres ! Pressure converted to [Pa] real, dimension(size(T_fr)) :: Sa ! Salinity converted to [ppt] + real, dimension(size(T_fr)) :: absS ! Salinity converted to absoluate salinity [ppt] + real, dimension(size(T_fr)) :: TFreeze_S ! The salinity for the freezing equation in model units [S ~> PSU or ppt] integer :: i, is, ie, npts if (present(dom)) then @@ -631,24 +684,36 @@ subroutine calculate_TFreeze_1d(S, pressure, T_fr, EOS, dom) is = 1 ; ie = size(T_Fr) ; npts = 1 + ie - is endif + if (EOS%use_conT_absS) then + ! Otherwise absS is unneeded and therefore unset + absS(:) = S(:)*EOS%S_to_ppt + if (EOS%TFreeze_S_is_pracS) then + TFreeze_S(:) = gsw_sp_from_sr(absS(:))*EOS%ppt_to_S + else + TFreeze_S(:) = S(:) + endif + else + TFreeze_S(:) = S(:) + endif + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%S_to_ppt == 1.0)) then select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, pressure, T_fr, is, npts, & + call calculate_TFreeze_linear(TFreeze_S, pressure, T_fr, is, npts, & EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, pressure, T_fr, is, npts) + call calculate_TFreeze_Millero(TFreeze_S, pressure, T_fr, is, npts) case (TFREEZE_TEOSPOLY) - call calculate_TFreeze_TEOS_poly(S, pressure, T_fr, is, npts) + call calculate_TFreeze_TEOS_poly(TFreeze_S, pressure, T_fr, is, npts) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, pressure, T_fr, is, npts) + call calculate_TFreeze_teos10(TFreeze_S, pressure, T_fr, is, npts) case default call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select else do i=is,ie pres(i) = EOS%RL2_T2_to_Pa * pressure(i) - Sa(i) = EOS%S_to_ppt * S(i) + Sa(i) = EOS%S_to_ppt * TFreeze_S(i) enddo select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) @@ -665,6 +730,13 @@ subroutine calculate_TFreeze_1d(S, pressure, T_fr, EOS, dom) end select endif + if (EOS%use_conT_absS .and. EOS%TFreeze_T_is_potT) then + ! absS is set only if EOS%use_conT_absS is True! + ! absS is in ppt and T_fr is in degC at this point. + T_fr(:) = gsw_ct_from_pt(absS(:),T_fr(:)) + endif + + if (EOS%degC_to_C /= 1.0) then do i=is,ie ; T_fr(i) = EOS%degC_to_C * T_fr(i) ; enddo endif @@ -1140,7 +1212,7 @@ subroutine average_specific_vol(T, S, p_t, dp, SpV_avg, EOS, dom, scale) select case (EOS%form_of_EOS) case (EOS_LINEAR) call avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, is, npts, EOS%Rho_T0_S0, & - EOS%dRho_dT, EOS%dRho_dS) + EOS%dRho_dT, EOS%dRho_dS, EOS%dRho_dp) case (EOS_WRIGHT) call avg_spec_vol_buggy_wright(T, S, p_t, dp, SpV_avg, is, npts) case (EOS_WRIGHT_FULL) @@ -1160,7 +1232,7 @@ subroutine average_specific_vol(T, S, p_t, dp, SpV_avg, EOS, dom, scale) select case (EOS%form_of_EOS) case (EOS_LINEAR) call avg_spec_vol_linear(Ta, Sa, pres, dpres, SpV_avg, is, npts, EOS%Rho_T0_S0, & - EOS%dRho_dT, EOS%dRho_dS) + EOS%dRho_dT, EOS%dRho_dS, EOS%dRho_dp) case (EOS_WRIGHT) call avg_spec_vol_buggy_wright(Ta, Sa, pres, dpres, SpV_avg, is, npts) case (EOS_WRIGHT_FULL) @@ -1270,7 +1342,7 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & ! Local variables real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] - + real :: dRdp_scale ! A factor to convert drho_dp to the desired units [T-2 L2 s2 m-2 ~> 1] ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical ! integration be used instead of analytic. This is a safety check. @@ -1280,10 +1352,11 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & case (EOS_LINEAR) dRdT_scale = EOS%kg_m3_to_R * EOS%C_to_degC dRdS_scale = EOS%kg_m3_to_R * EOS%S_to_ppt + dRdp_scale = EOS%kg_m3_to_R * EOS%RL2_T2_to_Pa call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & - dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dza, & - intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, P_surf, dP_tiny, MassWghtInterp) + dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dRdp_scale*EOS%dRho_dp, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, P_surf, dP_tiny, MassWghtInterp) case (EOS_WRIGHT) call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & @@ -1358,6 +1431,7 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, ! desired units [R m3 kg-1 ~> 1] real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] + real :: dRdp_scale ! A factor to convert drho_dp to the desired units [T-2 L2 s2 m-2 ~> 1] real :: pres_scale ! A multiplicative factor to convert pressure into Pa [Pa T2 R-1 L-2 ~> 1] ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical @@ -1369,14 +1443,15 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, rho_scale = EOS%kg_m3_to_R dRdT_scale = EOS%kg_m3_to_R * EOS%C_to_degC dRdS_scale = EOS%kg_m3_to_R * EOS%S_to_ppt - if ((rho_scale /= 1.0) .or. (dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then - call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - rho_scale*EOS%Rho_T0_S0, dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp) + dRdp_scale = EOS%kg_m3_to_R * EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0) .or. (dRdp_scale /= 1.0)) then + call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, rho_scale*EOS%Rho_T0_S0, & + dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dRdp_scale*EOS%dRho_dp, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) else call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, EOS%dRho_dp, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case (EOS_WRIGHT) rho_scale = EOS%kg_m3_to_R @@ -1462,20 +1537,24 @@ end function get_EOS_name !> Initializes EOS_type by allocating and reading parameters. The scaling factors in !! US are stored in EOS for later use. -subroutine EOS_init(param_file, EOS, US) +subroutine EOS_init(param_file, EOS, US, use_conT_absS) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), intent(inout) :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in), optional :: use_conT_absS !< True if the model is formulated for + !! conservative temp and absolute salinity optional :: US ! Local variables # include "version_variable.h" character(len=40) :: mdl = "MOM_EOS" ! This module's name. character(len=12) :: TFREEZE_DEFAULT ! The default freezing point expression character(len=40) :: tmpstr - logical :: EOS_quad_default + logical :: EOS_quad_default, EOS_TS_default real :: Rho_Tref_Sref ! Density at Tref degC and Sref ppt [kg m-3] real :: Tref ! Reference temperature [degC] real :: Sref ! Reference salinity [psu] + real :: pref ! Reference pressure [Pa] + real :: rho0 ! Density at T=0, S=0 and p=0 [kg m-3] ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1516,32 +1595,43 @@ 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_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 reference salinity.", units="psu", default=0.0) + ! RHO(T,S) = RHO_REF + DRHO_DT*(T-T_REF) + DRHO_DS*(S-S_REF) + DRHO_DP*(P-P_REF) + ! = RHO_REF - (DRHO_DT*T_REF + DRHO_DS*SREF + DRHO_DP*PREF) + (DRHO_DT*T + DRHO_DS*S + DRHO_DP*P) + ! = RHO_T0_S0 + (DRHO_DT*T + DRHO_DS*S + DRHO_DP*P) + call get_param(param_file, mdl, "RHO_REF_LINEAR_EOS", Rho_Tref_Sref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the density "//& + "at T=T_REF_LINEAR_EOS, S=S_REF_LINEAR_EOS and p=P_REF_LINEAR_EOS", & + units="kg m-3", default=1000.0, old_name="RHO_TREF_SREF") + call get_param(param_file, mdl, "T_REF_LINEAR_EOS", Tref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the reference "//& + "temperature.", units="degC", default=0.0, old_name="TREF") + call get_param(param_file, mdl, "S_REF_LINEAR_EOS", Sref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the reference "//& + "salinity.", units="psu", default=0.0, old_name="SREF") + call get_param(param_file, mdl, "P_REF_LINEAR_EOS", pref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the reference "//& + "pressure.", units="Pa", default=0.0) call get_param(param_file, mdl, "DRHO_DT", EOS%dRho_dT, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the partial derivative of density with "//& - "temperature.", units="kg m-3 K-1", default=-0.2) + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is "//& + "the partial derivative of density with temperature.", & + units="kg m-3 K-1", default=-0.2) call get_param(param_file, mdl, "DRHO_DS", EOS%dRho_dS, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the partial derivative of density with salinity.", & - units="kg m-3 ppt-1", default=0.8) + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is "//& + "the partial derivative of density with salinity.", & + units="kg m-3 ppt-1", default=0.8) + call get_param(param_file, mdl, "DRHO_DP", EOS%dRho_dp, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is "//& + "the partial derivative of density with pressure (the inverse of "//& + "sound speed squared).", units="s2 m-2", default=0.0) + rho0 = Rho_Tref_Sref - ((EOS%dRho_dT * Tref + EOS%dRho_dS * Sref) + EOS%dRho_dp * pref) call get_param(param_file, mdl, "RHO_T0_S0", EOS%Rho_T0_S0, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the density at T=0, S=0.", 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) + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the density "//& + "at T=0, S=0 and p=0. If RHO_TO_SO is specified, RHO_REF_LINEAR_EOS, "//& + "T_REF_LINEAR_EOS, S_REF_LINEAR_EOS and P_REF_LINEAR_EOS are not used.", & + units="kg m-3", default=rho0) + EOS%Compressible = (EOS%dRho_dp/=0.0) + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=EOS%Rho_T0_S0, & + dRho_dT=EOS%dRho_dT, dRho_dS=EOS%dRho_dS, dRho_dp=EOS%dRho_dp) endif if (EOS%form_of_EOS == EOS_WRIGHT) then call get_param(param_file, mdl, "USE_WRIGHT_2ND_DERIV_BUG", EOS%use_Wright_2nd_deriv_bug, & @@ -1551,6 +1641,12 @@ subroutine EOS_init(param_file, EOS, US) call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT, use_Wright_2nd_deriv_bug=EOS%use_Wright_2nd_deriv_bug) endif + if (present(use_conT_absS)) then + EOS%use_conT_absS = use_conT_absS + else + EOS%use_conT_absS = .false. ! Assuming it is not needed, it is set to false + endif + EOS_quad_default = .not.((EOS%form_of_EOS == EOS_LINEAR) .or. & (EOS%form_of_EOS == EOS_WRIGHT) .or. & (EOS%form_of_EOS == EOS_WRIGHT_REDUCED) .or. & @@ -1599,10 +1695,25 @@ subroutine EOS_init(param_file, EOS, US) units="degC Pa-1", default=0.0) endif + if ((EOS%form_of_TFreeze==TFREEZE_TEOSPOLY) .or. (EOS%form_of_TFreeze==TFREEZE_TEOS10)) then + ! Which default is appropriate for Millero? + EOS_TS_default = .false. + else + EOS_TS_default = .true. + endif + call get_param(param_file, mdl, "TFREEZE_S_IS_PRACS", EOS%TFreeze_S_is_pracS, & + "When True, the model will check if the model internal salinity is "//& + "practical salinity. If the model uses absolute salinity, a "//& + "conversion will be applied.", default=EOS_TS_default) + call get_param(param_file, mdl, "TFREEZE_T_IS_POTT", EOS%TFreeze_T_is_potT, & + "When True, the model will check if the model internal temperature is "//& + "potential temperature. If the model uses conservative temperature, a "//& + "conversion will be applied.", default=EOS_TS_default) + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & EOS%form_of_EOS == EOS_ROQUET_SPV) .and. & .not.((EOS%form_of_TFreeze == TFREEZE_TEOS10) .or. (EOS%form_of_TFreeze == TFREEZE_TEOSPOLY)) ) then - call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_ROQUET_RHO or EOS_ROQUET_SPV "//& + call MOM_error(WARNING, "interpret_eos_selection: EOS_TEOS10 or EOS_ROQUET_RHO or EOS_ROQUET_SPV "//& "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 or TFREEZE_TEOSPOLY.") endif @@ -1621,7 +1732,7 @@ end subroutine EOS_init !> Manually initialized an EOS type (intended for unit testing of routines which need a specific EOS) subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & - Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp, & + Rho_T0_S0, drho_dT, dRho_dS, dRho_dp, TFr_S0_P0, dTFr_dS, dTFr_dp, & use_Wright_2nd_deriv_bug) type(EOS_type), intent(inout) :: EOS !< Equation of state structure integer, optional, intent(in) :: form_of_EOS !< A coded integer indicating the equation of state to use. @@ -1635,6 +1746,8 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co !! in [kg m-3 degC-1] real , optional, intent(in) :: dRho_dS !< Partial derivative of density with salinity !! in [kg m-3 ppt-1] + real , optional, intent(in) :: dRho_dp !< Partial derivative of density with pressure + !! in [s2 m-2] real , optional, intent(in) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] real , optional, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity !! in [degC ppt-1] @@ -1667,7 +1780,7 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co end select select type (t => EOS%type) type is (linear_EOS) - call t%set_params_linear(Rho_T0_S0, dRho_dT, dRho_dS) + call t%set_params_linear(Rho_T0_S0, dRho_dT, dRho_dS, dRho_dp) type is (buggy_Wright_EOS) call t%set_params_buggy_Wright(use_Wright_2nd_deriv_bug) end select @@ -1678,6 +1791,7 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co if (present(Rho_T0_S0 )) EOS%Rho_T0_S0 = Rho_T0_S0 if (present(drho_dT )) EOS%drho_dT = drho_dT if (present(dRho_dS )) EOS%dRho_dS = dRho_dS + if (present(dRho_dp )) EOS%dRho_dp = dRho_dp if (present(TFr_S0_P0 )) EOS%TFr_S0_P0 = TFr_S0_P0 if (present(dTFr_dS )) EOS%dTFr_dS = dTFr_dS if (present(dTFr_dp )) EOS%dTFr_dp = dTFr_dp @@ -1685,26 +1799,25 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co end subroutine EOS_manual_init -!> Set equation of state structure (EOS) to linear with given coefficients -!! -!! \note This routine is primarily for testing and allows a local copy of the -!! EOS_type (EOS argument) to be set to use the linear equation of state -!! independent from the rest of the model. -subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) - real, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] - real, intent(in) :: dRho_dT !< Partial derivative of density with temperature [kg m-3 degC-1] - real, intent(in) :: dRho_dS !< Partial derivative of density with salinity [kg m-3 ppt-1] - logical, optional, intent(in) :: use_quadrature !< If true, always use the generic (quadrature) - !! code for the integrals of density. - type(EOS_type), intent(inout) :: EOS !< Equation of state structure - - call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=Rho_T0_S0, dRho_dT=dRho_dT, dRho_dS=dRho_dS) - EOS%Compressible = .false. - EOS%EOS_quadrature = .false. - if (present(use_quadrature)) EOS%EOS_quadrature = use_quadrature - -end subroutine EOS_use_linear - +! !> Set equation of state structure (EOS) to linear with given coefficients +! !! +! !! \note This routine is primarily for testing and allows a local copy of the +! !! EOS_type (EOS argument) to be set to use the linear equation of state +! !! independent from the rest of the model. +! subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) +! real, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] +! real, intent(in) :: dRho_dT !< Partial derivative of density with temperature [kg m-3 degC-1] +! real, intent(in) :: dRho_dS !< Partial derivative of density with salinity [kg m-3 ppt-1] +! logical, optional, intent(in) :: use_quadrature !< If true, always use the generic (quadrature) +! !! code for the integrals of density. +! type(EOS_type), intent(inout) :: EOS !< Equation of state structure + +! call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=Rho_T0_S0, dRho_dT=dRho_dT, dRho_dS=dRho_dS) +! EOS%Compressible = .false. +! EOS%EOS_quadrature = .false. +! if (present(use_quadrature)) EOS%EOS_quadrature = use_quadrature + +! end subroutine EOS_use_linear !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) @@ -2013,9 +2126,9 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_SPV EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail - call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_LINEAR, Rho_T0_S0=1000.0, drho_dT=-0.2, dRho_dS=0.8) + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_LINEAR, Rho_T0_S0=1000.0, drho_dT=-0.2, dRho_dS=0.8, dRho_dp=5.0e-7) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", & - rho_check=1023.0*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + rho_check=1028.0*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) if (verbose .and. fail) call MOM_error(WARNING, "LINEAR EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index 17f2f5156f..b65e887694 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, gsw_sr_from_sp +use gsw_mod_toolbox, only : gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp, gsw_ct_from_pt use gsw_mod_toolbox, only : gsw_rho, gsw_specvol use gsw_mod_toolbox, only : gsw_rho_first_derivatives, gsw_specvol_first_derivatives use gsw_mod_toolbox, only : gsw_rho_second_derivatives @@ -11,7 +11,7 @@ module MOM_EOS_TEOS10 implicit none ; private -public gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp +public gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp, gsw_ct_from_pt public TEOS10_EOS real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar [dbar Pa-1] diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index e443970535..7737004ea7 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -16,9 +16,10 @@ module MOM_EOS_linear !> The EOS_base implementation of a linear equation of state type, extends (EOS_base) :: linear_EOS - real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real :: Rho_T0_S0 !< The density at T=0, S=0 and p=0 [kg m-3]. real :: dRho_dT !< The derivative of density with temperature [kg m-3 degC-1]. real :: dRho_dS !< The derivative of density with salinity [kg m-3 ppt-1]. + real :: dRho_dp !< The derivative of density with pressure [s2 m-2]. contains !> Implementation of the in-situ density as an elemental function [kg m-3] @@ -62,7 +63,7 @@ real elemental function density_elem_linear(this, T, S, pressure) real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] - density_elem_linear = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + density_elem_linear = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + this%dRho_dp*pressure end function density_elem_linear @@ -77,7 +78,8 @@ real elemental function density_anomaly_elem_linear(this, T, S, pressure, rho_re real, intent(in) :: pressure !< Pressure [Pa] real, intent(in) :: rho_ref !< A reference density [kg m-3] - density_anomaly_elem_linear = (this%Rho_T0_S0 - rho_ref) + (this%dRho_dT*T + this%dRho_dS*S) + density_anomaly_elem_linear = & + (this%Rho_T0_S0 - rho_ref) + ((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure) end function density_anomaly_elem_linear @@ -91,7 +93,8 @@ real elemental function spec_vol_elem_linear(this, T, S, pressure) real, intent(in) :: S !< Salinity [ppt]. real, intent(in) :: pressure !< Pressure [Pa]. - spec_vol_elem_linear = 1.0 / ( this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S)) + spec_vol_elem_linear = & + 1.0 / ( this%Rho_T0_S0 + ((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure) ) end function spec_vol_elem_linear @@ -106,15 +109,16 @@ real elemental function spec_vol_anomaly_elem_linear(this, T, S, pressure, spv_r real, intent(in) :: pressure !< Pressure [Pa]. real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - spec_vol_anomaly_elem_linear = ((1.0 - this%Rho_T0_S0*spv_ref) - & - spv_ref*(this%dRho_dT*T + this%dRho_dS*S)) / & - ( this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S)) + spec_vol_anomaly_elem_linear = & + ((1.0 - this%Rho_T0_S0*spv_ref) - & + spv_ref*((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure)) / & + ( this%Rho_T0_S0 + ((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure) ) end function spec_vol_anomaly_elem_linear !> This subroutine calculates the partial derivatives of density !! with potential temperature and salinity. -elemental subroutine calculate_density_derivs_elem_linear(this,T, S, pressure, dRho_dT, dRho_dS) +elemental subroutine calculate_density_derivs_elem_linear(this, T, S, pressure, dRho_dT, dRho_dS) class(linear_EOS), intent(in) :: this !< This EOS real, intent(in) :: T !< Potential temperature relative to the surface [degC]. real, intent(in) :: S !< Salinity [ppt]. @@ -170,7 +174,7 @@ elemental subroutine calculate_specvol_derivs_elem_linear(this, T, S, pressure, real :: I_rho2 ! The inverse of density squared [m6 kg-2] ! Sv = 1.0 / (Rho_T0_S0 + dRho_dT*T + dRho_dS*S) - I_rho2 = 1.0 / (this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S))**2 + I_rho2 = 1.0 / (this%Rho_T0_S0 + ((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure))**2 dSV_dT = -this%dRho_dT * I_rho2 dSV_dS = -this%dRho_dS * I_rho2 @@ -189,13 +193,15 @@ elemental subroutine calculate_compress_elem_linear(this, T, S, pressure, rho, d !! (also the inverse of the square of sound speed) !! [s2 m-2]. - rho = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S - drho_dp = 0.0 + rho = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + this%dRho_dp*pressure + drho_dp = this%dRho_dp end subroutine calculate_compress_elem_linear -!> Calculates the layer average specific volumes. -subroutine avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, start, npts, Rho_T0_S0, dRho_dT, dRho_dS) +!> Calculates the layer average specific volumes. The analytical solution is +!! SpV_avg = 1 / (drho_dp*dp) * ln[(1+eps)/(1-eps)] and the expression here is the first five terms of its +!! Taylor series with a trunction error of O(eps**10). |eps|<0.02 for real ocean parameters. +subroutine avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, start, npts, Rho_T0_S0, dRho_dT, dRho_dS, dRho_dp) real, dimension(:), intent(in) :: T !< Potential temperature [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] @@ -209,17 +215,24 @@ subroutine avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, start, npts, Rho_T0_S0, d !! [kg m-3 degC-1] real, intent(in) :: dRho_dS !< The derivative of density with salinity !! [kg m-3 ppt-1] + real, intent(in) :: dRho_dp !< The derivative of density with pressure + !! [s2 m-2] ! Local variables + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: alpha_p_ave ! The specific volume at pressure mid-point [R-1 ~> m3 kg-1] + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] integer :: j do j=start,start+npts-1 - SpV_avg(j) = 1.0 / (Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) + alpha_p_ave = & + 1.0 / (Rho_T0_S0 + ((dRho_dT*T(j) + dRho_dS*S(j)) + dRho_dp*(p_t(j) + 0.5 * dp(j)))) + eps2 = (0.5 * (dRho_dp * dp(j)) * alpha_p_ave)**2 + SpV_avg(j) = alpha_p_ave * (1.0 + eps2 * (C1_3 + eps2 * (0.2 + eps2 * (C1_7 + C1_9 * eps2)))) enddo end subroutine avg_spec_vol_linear -!> Return the range of temperatures, salinities and pressures for which the reduced-range equation -!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying -!! this equation of state outside of its fit range. +!> Return the range of temperatures, salinities and pressures permitted for linear equation of state. +!! Care should be taken when applying this equation of state outside of its fit range. subroutine EoS_fit_range_linear(this, T_min, T_max, S_min, S_max, p_min, p_max) class(linear_EOS), intent(in) :: this !< This EOS real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] @@ -239,26 +252,29 @@ subroutine EoS_fit_range_linear(this, T_min, T_max, S_min, S_max, p_min, p_max) end subroutine EoS_fit_range_linear !> Set coefficients for the linear equation of state -subroutine set_params_linear(this, Rho_T0_S0, dRho_dT, dRho_dS) +subroutine set_params_linear(this, Rho_T0_S0, dRho_dT, dRho_dS, dRho_dp) class(linear_EOS), intent(inout) :: this !< This EOS real, optional, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] real, optional, intent(in) :: dRho_dT !< The derivative of density with temperature, !! [kg m-3 degC-1] real, optional, intent(in) :: dRho_dS !< The derivative of density with salinity, !! in [kg m-3 ppt-1] + real, optional, intent(in) :: dRho_dp !< The derivative of density with pressure, + !! in [s2 m-2] if (present(Rho_T0_S0)) this%Rho_T0_S0 = Rho_T0_S0 if (present(dRho_dT)) this%dRho_dT = dRho_dT if (present(dRho_dS)) this%dRho_dS = dRho_dS + if (present(dRho_dp)) this%dRho_dp = dRho_dp end subroutine set_params_linear !> This subroutine calculates analytical and nearly-analytical integrals of !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. -subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & - Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, SSH, dz_neglect, MassWghtInterp) +subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + Rho_T0_S0, dRho_dT, dRho_dS, dRho_dp, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -272,9 +288,9 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that !! is subtracted out to reduce the magnitude of !! each of the integrals. - real, intent(in) :: rho_0_pres !< A density [R ~> kg m-3], used to calculate - !! the pressure (as p~=-z*rho_0_pres*G_e) used in - !! the equation of state. rho_0_pres is not used. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], used to calculate + !! the pressure (as p~=-z*rho_0*G_e) used in + !! the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration !! [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] @@ -282,6 +298,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & !! [R C-1 ~> kg m-3 degC-1] real, intent(in) :: dRho_dS !< The derivative of density with salinity, !! in [R S-1 ~> kg m-3 ppt-1] + real, intent(in) :: dRho_dp !< The derivative of density with pressure, + !! in [L-2 T2 ~> m-2 s2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dpa !< The change in the pressure anomaly across the !! layer [R L2 T-2 ~> Pa] @@ -304,11 +322,16 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: rho_anom ! The density anomaly from rho_ref [R ~> kg m-3]. real :: raL, raR ! rho_anom to the left and right [R ~> kg m-3]. real :: dz, dzL, dzR ! Layer thicknesses [Z ~> m]. + real :: GxRho ! The gravitational acceleration times mean ocean density [R L2 Z-1 T-2 ~> Pa m-1] + real :: p_ave ! The layer averaged pressure [R L2 T-2 ~> Pa] real :: hWght ! A pressure-thickness below topography [Z ~> m]. real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. @@ -330,6 +353,16 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & is = HI%isc ; ie = HI%iec js = HI%jsc ; je = HI%jec + GxRho = G_e * rho_0 + + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif + do_massWeight = .false. ; top_massWeight = .false. if (present(MassWghtInterp)) then do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values @@ -338,9 +371,11 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz = z_t(i,j) - z_b(i,j) - rho_anom = (Rho_T0_S0 - rho_ref) + dRho_dT*T(i,j) + dRho_dS*S(i,j) - dpa(i,j) = G_e*rho_anom*dz - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*rho_anom*dz**2 + p_ave = -GxRho * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j)) + rho_anom = (Rho_T0_S0 - rho_ref) + dRho_dT * T(i,j) + dRho_dS * S(i,j) + dRho_dp * p_ave + dpa(i,j) = G_e * rho_anom * dz + if (present(intz_dpa)) & + intz_dpa(i,j) = 0.5 * G_e * (rho_anom - C1_6 * dRho_dp * (GxRho * dz)) * dz**2 enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq @@ -355,8 +390,12 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & if (hWght <= 0.0) then dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i+1,j) - z_b(i+1,j) - raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) - raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) + + p_ave = -GxRho * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j)) + raL = (Rho_T0_S0 - rho_ref) + ((dRho_dT*T(i,j) + dRho_dS*S(i,j)) + dRho_dp*p_ave) + + p_ave = -GxRho * (0.5 * (z_t(i+1,j) + z_b(i+1,j)) - z0pres(i+1,j)) + raR = (Rho_T0_S0 - rho_ref) + ((dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) + dRho_dp*p_ave) intx_dpa(i,j) = G_e*C1_6 * ((dzL*(2.0*raL + raR)) + (dzR*(2.0*raR + raL))) else @@ -373,9 +412,11 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) + p_ave = -GxRho * ((wt_L * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5 * (z_t(i+1,j) + z_b(i+1,j)) - z0pres(i+1,j)))) rho_anom = (Rho_T0_S0 - rho_ref) + & - (dRho_dT * ((wtT_L*T(i,j)) + (wtT_R*T(i+1,j))) + & - dRho_dS * ((wtT_L*S(i,j)) + (wtT_R*S(i+1,j)))) + ((dRho_dT * ((wtT_L*T(i,j)) + (wtT_R*T(i+1,j))) + & + dRho_dS * ((wtT_L*S(i,j)) + (wtT_R*S(i+1,j)))) + dRho_dp * p_ave) intz(m) = G_e*rho_anom*dz enddo ! Use Boole's rule to integrate the values. @@ -396,8 +437,12 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & if (hWght <= 0.0) then dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i,j+1) - z_b(i,j+1) - raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) - raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) + + p_ave = -GxRho * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j)) + raL = (Rho_T0_S0 - rho_ref) + ((dRho_dT*T(i,j) + dRho_dS*S(i,j)) + dRho_dp*p_ave) + + p_ave = -GxRho * (0.5 * (z_t(i,j+1) + z_b(i,j+1)) - z0pres(i,j+1)) + raR = (Rho_T0_S0 - rho_ref) + ((dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) + dRho_dp*p_ave) inty_dpa(i,j) = G_e*C1_6 * ((dzL*(2.0*raL + raR)) + (dzR*(2.0*raR + raL))) else @@ -414,9 +459,11 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) + p_ave = -GxRho * ((wt_L * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5 * (z_t(i,j+1) + z_b(i,j+1)) - z0pres(i,j+1)))) rho_anom = (Rho_T0_S0 - rho_ref) + & - (dRho_dT * ((wtT_L*T(i,j)) + (wtT_R*T(i,j+1))) + & - dRho_dS * ((wtT_L*S(i,j)) + (wtT_R*S(i,j+1)))) + ((dRho_dT * ((wtT_L*T(i,j)) + (wtT_R*T(i,j+1))) + & + dRho_dS * ((wtT_L*S(i,j)) + (wtT_R*S(i,j+1)))) + dRho_dp * p_ave) intz(m) = G_e*rho_anom*dz enddo ! Use Boole's rule to integrate the values. @@ -432,7 +479,7 @@ end subroutine int_density_dz_linear !! calculating the finite-volume form pressure accelerations in a non-Boussinesq !! model. Specific volume is assumed to vary linearly between adjacent points. subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & - dRho_dT, dRho_dS, dza, intp_dza, intx_dza, inty_dza, halo_size, & + dRho_dT, dRho_dS, dRho_dp, dza, intp_dza, intx_dza, inty_dza, halo_size, & bathyP, P_surf, dP_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -453,6 +500,8 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & !! [R C-1 ~> kg m-3 degC-1] real, intent(in) :: dRho_dS !< The derivative of density with salinity, !! in [R S-1 ~> kg m-3 ppt-1] + real, intent(in) :: dRho_dp !< The derivative of density with pressure, + !! in [L-2 T2 ~> m-2 s2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dza !< The change in the geopotential anomaly across !! the layer [L2 T-2 ~> m2 s-2] @@ -480,7 +529,12 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals ! Local variables - real :: dRho_TS ! The density anomaly due to T and S [R ~> kg m-3] + real :: dRho ! The density anomaly due to T, S and p [R ~> kg m-3] + real :: lambda ! The sound speed squared [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: p_ave ! The layer averaged pressure [R L2 T-2 ~> Pa] + real :: alpha_p_ave ! The specific volume at p_ave [R-1 ~> m3 kg-1] real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [R-1 ~> m3 kg-1] real :: aaL, aaR ! The specific volume anomaly to the left and right [R-1 ~> m3 kg-1] real :: dp, dpL, dpR ! Layer pressure thicknesses [R L2 T-2 ~> Pa] @@ -496,6 +550,7 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & logical :: do_massWeight ! Indicates whether to do mass weighting. logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -512,13 +567,28 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set endif + lambda = 0.0 ; if (dRho_dp/=0.0) lambda = 1.0 / dRho_dp do j=jsh,jeh ; do i=ish,ieh dp = p_b(i,j) - p_t(i,j) - dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) - ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref - alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - dza(i,j) = alpha_anom*dp - if (present(intp_dza)) intp_dza(i,j) = 0.5*alpha_anom*dp**2 + p_ave = 0.5 * (p_t(i,j) + p_b(i,j)) + + drho = (dRho_dT * T(i,j) + dRho_dS * S(i,j)) + dRho_dp * p_ave + alpha_p_ave = 1.0 / (Rho_T0_S0 + drho) + + ! A realistic upbound of eps is ~0.02, using dRho_dp ~ (1500 m/s)**(-2), alpha_p_ave ~ 1/(1030 kg/m3) + ! and dp ~ 1e8 Pa [~dz=10000m]. And if we use dp ~ 1e6 [~dz=100m], eps ~ 2e-4. + ! Analytically dza = 1/dRho_dp * ln[(1+eps)/(1-eps)] - alpha_ref * dp, and the expression here gives the first + ! five terms from its Taylor series with a truncation error of O(eps**11), which is beyond double floating + ! point precision. + eps = 0.5 * (dRho_dp * dp) * alpha_p_ave ; eps2 = eps * eps + ! alpha_anom = 1.0/(Rho_T0_S0 + dRho) - alpha_ref + alpha_anom = ((1.0 - Rho_T0_S0 * alpha_ref) - drho * alpha_ref) / (Rho_T0_S0 + drho) + ! The following expression would be more efficient but I suspect it changes answer. + ! alpha_anom = ((1.0 - Rho_T0_S0 * alpha_ref) - drho * alpha_ref) * alpha_p_ave + rem = (lambda * eps2) * (C1_3 + eps2 * (0.2 + eps2 * (C1_7 + C1_9 * eps2))) + dza(i,j) = alpha_anom * dp + 2.0 * eps * rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5 * alpha_anom * dp**2 - dp * ((1.0 - eps) * rem) enddo ; enddo if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq @@ -536,10 +606,14 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i+1,j) - p_t(i+1,j) - dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) - aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - dRho_TS = dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j) - aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + + p_ave = 0.5 * (p_b(i,j) + p_t(i,j)) + drho = (dRho_dT*T(i,j) + dRho_dS*S(i,j)) + dRho_dp * p_ave + aaL = ((1.0 - Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) + + p_ave = 0.5 * (p_b(i+1,j) + p_t(i+1,j)) + drho = (dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) + dRho_dp * p_ave + aaR = ((1.0 - Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) intx_dza(i,j) = C1_6 * (2.0*((dpL*aaL) + (dpR*aaR)) + ((dpL*aaR) + (dpR*aaL))) else @@ -558,11 +632,12 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & ! T, S, and p are interpolated in the horizontal. The p interpolation ! is linear, but for T and S it may be thickness weighted. dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i+1,j)+p_b(i+1,j)))) - dRho_TS = dRho_dT*((wtT_L*T(i,j)) + (wtT_R*T(i+1,j))) + & - dRho_dS*((wtT_L*S(i,j)) + (wtT_R*S(i+1,j))) - ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref - alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + drho = (dRho_dT*((wtT_L*T(i,j)) + (wtT_R*T(i+1,j))) + & + dRho_dS*((wtT_L*S(i,j)) + (wtT_R*S(i+1,j)))) + dRho_dp * p_ave + ! alpha_anom = 1.0/(Rho_T0_S0 + drho)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) intp(m) = alpha_anom*dp enddo ! Use Boole's rule to integrate the interface height anomaly values in y. @@ -586,10 +661,14 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i,j+1) - p_t(i,j+1) - dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) - aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - dRho_TS = dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1) - aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + + p_ave = 0.5 * (p_b(i,j) + p_t(i,j)) + dRho_dp * p_ave + drho = (dRho_dT*T(i,j) + dRho_dS*S(i,j)) + dRho_dp * p_ave + aaL = ((1.0 - Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) + + p_ave = 0.5 * (p_b(i,j+1) + p_t(i,j+1)) + dRho_dp * p_ave + drho = (dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) + dRho_dp * p_ave + aaR = ((1.0 - Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) inty_dza(i,j) = C1_6 * (2.0*((dpL*aaL) + (dpR*aaR)) + ((dpL*aaR) + (dpR*aaL))) else @@ -608,11 +687,12 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & ! T, S, and p are interpolated in the horizontal. The p interpolation ! is linear, but for T and S it may be thickness weighted. dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i,j+1)+p_b(i,j+1)))) - dRho_TS = dRho_dT*((wtT_L*T(i,j)) + (wtT_R*T(i,j+1))) + & - dRho_dS*((wtT_L*S(i,j)) + (wtT_R*S(i,j+1))) - ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref - alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + drho = (dRho_dT*((wtT_L*T(i,j)) + (wtT_R*T(i,j+1))) + & + dRho_dS*((wtT_L*S(i,j)) + (wtT_R*S(i,j+1)))) + dRho_dp * p_ave + ! alpha_anom = 1.0/(Rho_T0_S0 + drho)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) intp(m) = alpha_anom*dp enddo ! Use Boole's rule to integrate the interface height anomaly values in y. @@ -624,7 +704,7 @@ end subroutine int_spec_vol_dp_linear !> Calculate the in-situ density for 1D arraya inputs and outputs. subroutine calculate_density_array_linear(this, T, S, pressure, rho, start, npts, rho_ref) - class(linear_EOS), intent(in) :: this !< This EOS + class(linear_EOS), intent(in) :: this !< This EOS real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 8a172ce0c8..95079316af 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -2191,15 +2191,16 @@ end subroutine chksum_v_3d ! into account. !> chksum1d does a checksum of a 1-dimensional array. -subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) +subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs, logunit) real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1) [abitrary]. character(len=*), intent(in) :: mesg !< An identifying message. integer, optional, intent(in) :: start_i !< The starting index for the sum (default 1) integer, optional, intent(in) :: end_i !< The ending index for the sum (default all) logical, optional, intent(in) :: compare_PEs !< If true, compare across PEs instead of summing !! and list the root_PE value (default true) + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - integer :: is, ie, i, bc, sum1, sum_bc + integer :: is, ie, i, bc, sum1, sum_bc, ioUnit real :: sum ! The global sum of the array [arbitrary] real, allocatable :: sum_here(:) ! The sum on each PE [arbitrary] logical :: compare @@ -2210,6 +2211,7 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) if (present(start_i)) is = start_i if (present(end_i)) ie = end_i compare = .true. ; if (present(compare_PEs)) compare = compare_PEs + iounit = error_unit ; if (present(logunit)) iounit = logunit sum = 0.0 ; sum_bc = 0 do i=is,ie @@ -2231,17 +2233,17 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) sum_bc = sum1 elseif (is_root_pe()) then if (sum1 /= nPEs*sum_bc) & - write(0, '(A40," bitcounts do not match across PEs: ",I12,1X,I12)') & + write(iounit, '(A40," bitcounts do not match across PEs: ",I12,1X,I12)') & mesg, sum1, nPEs*sum_bc do i=1,nPEs ; if (sum /= sum_here(i)) then - write(0, '(A40," PE ",i4," sum mismatches root_PE: ",3(ES22.13,1X))') & + write(iounit, '(A40," PE ",i4," sum mismatches root_PE: ",3(ES22.13,1X))') & mesg, i, sum_here(i), sum, sum_here(i)-sum endif ; enddo endif deallocate(sum_here) if (is_root_pe()) & - write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum_bc + write(iounit,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum_bc end subroutine chksum1d @@ -2249,14 +2251,17 @@ end subroutine chksum1d ! into account. !> chksum2d does a checksum of all data in a 2-d array. -subroutine chksum2d(array, mesg) +subroutine chksum2d(array, mesg, logunit) real, dimension(:,:), intent(in) :: array !< The array to be checksummed [arbitrary] character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - integer :: xs,xe,ys,ye,i,j,sum1,bc + integer :: xs, xe, ys, ye, i, j, sum1, bc, iounit real :: sum ! The global sum of the array [arbitrary] + iounit = error_unit ; if (present(logunit)) iounit = logunit + xs = LBOUND(array,1) ; xe = UBOUND(array,1) ys = LBOUND(array,2) ; ye = UBOUND(array,2) @@ -2270,21 +2275,24 @@ subroutine chksum2d(array, mesg) sum = reproducing_sum(array(:,:)) if (is_root_pe()) & - write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 -! write(0,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & + write(iounit,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 +! write(iounit,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & ! mesg, sum, sum1, sum, sum1 end subroutine chksum2d !> chksum3d does a checksum of all data in a 2-d array. -subroutine chksum3d(array, mesg) +subroutine chksum3d(array, mesg, logunit) real, dimension(:,:,:), intent(in) :: array !< The array to be checksummed [arbitrary] character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - integer :: xs,xe,ys,ye,zs,ze,i,j,k, bc,sum1 + integer :: xs, xe, ys, ye, zs, ze, i, j, k, bc, sum1, iounit real :: sum ! The global sum of the array [arbitrary] + iounit = error_unit ; if (present(logunit)) iounit = logunit + xs = LBOUND(array,1) ; xe = UBOUND(array,1) ys = LBOUND(array,2) ; ye = UBOUND(array,2) zs = LBOUND(array,3) ; ze = UBOUND(array,3) @@ -2299,8 +2307,8 @@ subroutine chksum3d(array, mesg) sum = reproducing_sum(array(:,:,:)) if (is_root_pe()) & - write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 -! write(0,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & + write(iounit, '(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 +! write(iounit, '(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & ! mesg, sum, sum1, sum, sum1 end subroutine chksum3d diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index ea5e632039..4f2c08d491 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -23,6 +23,7 @@ module MOM_coms public :: EFP_plus, EFP_minus, EFP_to_real, real_to_EFP, EFP_real_diff public :: operator(+), operator(-), assignment(=) public :: query_EFP_overflow_error, reset_EFP_overflow_error +public :: max_count_prec ! This module provides interfaces to the non-domain-oriented communication subroutines. diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 64b0508fe0..16bf798b0a 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -35,6 +35,7 @@ module MOM_domains public :: MOM_domain_type, domain2D, domain1D public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain public :: MOM_thread_affinity_set, set_MOM_thread_affinity +public :: MOM_define_layout ! Domain query routines public :: get_domain_extent, get_domain_components, get_global_shape, same_domain public :: PE_here, root_PE, num_PEs diff --git a/src/framework/numerical_testing_type.F90 b/src/framework/numerical_testing_type.F90 index 0947ed3141..22b069491c 100644 --- a/src/framework/numerical_testing_type.F90 +++ b/src/framework/numerical_testing_type.F90 @@ -6,7 +6,7 @@ module numerical_testing_type implicit none ; private public testing -public testing_type_unit_test +public numerical_testing_type_unit_tests !> Class to assist in unit tests, not to be used outside of Recon1d types type :: testing @@ -272,100 +272,136 @@ subroutine int_arr(this, n, i_test, i_true, label, ignore) end subroutine int_arr !> Tests the testing type itself -logical function testing_type_unit_test(verbose) +logical function numerical_testing_type_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables - type(testing) :: test ! The instance to be tested + type(testing) :: tester ! An instance to record tests + type(testing) :: test ! The instance used for testing (is mutable) 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 ============" + numerical_testing_type_unit_tests = .false. ! Assume all is well at the outset + if (verbose) write(test%stdout,*) " ===== testing_type: numerical_testing_type_unit_tests =====" + call tester%set( verbose=verbose ) ! Sets the verbosity flag in tester call test%set( verbose=verbose ) ! Sets the verbosity flag in test - call test%set( stderr=0 ) ! Sets stderr + call test%set( stderr=6 ) ! Sets stderr (redirect errors for "test" since they are not real) call test%set( stdout=6 ) ! Sets stdout call test%set( stop_instantly=.false. ) ! Sets stop_instantly call test%set( ignore_fail=.false. ) ! Sets ignore_fail - 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 + ! Check that %summary() reports nothing when %state is unset + ! (note this has to be confirmed visually since everything is in stdout) + tmpflag = test%summarize("Summary is for a passing state") + call tester%test(tmpflag, "test%summarize() with no fails") + + ! Check that %test(.false.,...) leaves %state unchanged + call test%test( .false., "test(F) should pass" ) + call tester%test(test%state, "test%test(F)") + + ! Check that %test(.true.,...,ignore=.true.) leaves %state unchanged + call test%test( .true., "test(T) should fail but be ignored", ignore=.true. ) + call tester%test(test%state, "test%test(T,ignore)") + ! Check that %test(.true.,...) sets %state + call test%test( .true., "test(T) should fail" ) + call tester%test(.not. test%state, "test%test(T,ignore)") test%state = .false. ! reset + + ! Check that %real_scalar(a,a,...) leaves %state unchanged + call test%real_scalar(1., 1., "real_scalar(s,s) should pass", robits=0, tol=0.) + call tester%test(test%state, "test%real_scalar(s,s)") + + ! Check that %real_scalar(a,b,...,ignore=.true.) leaves %state unchanged + call test%real_scalar(1., 2., "real_scalar(s,t) should fail but be ignored", ignore=.true.) + call tester%test(test%state, "test%real_scalar(s,t,ignore)") + + ! Check that %real_scalar(a,a,...) sets %state call test%real_scalar(1., 2., "s != t should fail") - 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 + call tester%test(.not. test%state, "test%real_scalar(s,t)") + test%state = .false. ! reset + + ! Check that %real_arr(a,a,...) leaves %state unchanged + call test%real_arr(2, (/1.,2./), (/1.,2./), "real_arr(a,a) should pass", robits=0, tol=0.) + call tester%test(test%state, "test%real_arr(a,a)") + ! Check that %real_arr(a,b,...,ignore=.true.) leaves %state unchanged + call test%real_arr(2, (/1.,2./), (/3.,4./), "real_arr(a,b) should fail but be ignored", ignore=.true.) + call tester%test(test%state, "test%real_arr(a,b,ignore)") + + ! Check that %real_arr(a,b,...) sets %state + call test%real_arr(2, (/1.,2./), (/3.,4./), "real(a,b) should fail") + call tester%test(.not. test%state, "test%real_arr(a,b)") test%state = .false. ! reset - 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 + ! Check that %int_arr(a,a,...) leaves %state unchanged + call test%int_arr(2, (/1,2/), (/1,2/), "int_arr(i,i) should pass") + call tester%test(test%state, "test%int_arr(i,i)") + + ! Check that %int_arr(a,b,...,ignore=.true.) leaves %state unchanged + call test%int_arr(2, (/1,2/), (/3,4/), "int_arr(i,j) should fail but be ignored", ignore=.true.) + call tester%test(test%state, "test%int_arr(i,j,ignore)") + + ! Check that %int_arr(a,b,...) sets %state + call test%int_arr(2, (/1,2/), (/3,4/), "int(arr(i,j) should fail") + call tester%test(.not. test%state, "test%int_arr(i,j)") test%state = .false. ! reset - 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 + ! Check that %summary() reports nothing when %state is set + ! (note this has to be confirmed visually since everything is in stdout) + test%state = .true. ! reset to fail for testing %summary() + tmpflag = test%summarize("This summary should report 4 fails") + call tester%test(.not. tmpflag, "test%summarize() with fails") - if (verbose .and. .not. testing_type_unit_test) write(test%stdout,*) "testing_type_unit_test passed" + numerical_testing_type_unit_tests = tester%summarize("numerical_testing_type_unit_tests") -end function testing_type_unit_test +end function numerical_testing_type_unit_tests !> \namespace numerical_testing_type !! +!! numerical_testing_type is a helper class to facilitate implementing +!! tests of a numerical nature. +!! The class helps hide the logic and code associated with handling the +!! results of a test, essentially reducing the multiple lines of `if +!! ... then ... print ... else ... error_mesg ...` into one line. +!! +!! The class is light weight, meaning is does not depend on anything else, +!! allowing to be particularly useful in unit tests and small drivers. +!! However, this means it is up to the user to do something with the results, +!! e.g. `call MOM_error()` appropriately. +!! +!! Each test, e.g. real_scalar(), is expected to pass. +!! If a fail is encountered, it is immediately reported to stderr and stdour, +!! recorded internally, but does not terminate execuation unless +!! `set(stop_instantly=.true.)` was called previously. +!! Most tests take the form of `f(a,b)` where `a` should equal `b`. +!! Only test() takes a single input (boolean) which is expected to +!! be false for the test to pass. +!! +!! summarize() is used to "finalize" the tests. +!! It prints a summary of how many and which tests faield, and returns a logical +!! that is set to .true. if any test failed. +!! +!! Usage by example: +!! \verbatim +!! use numerical_testing_type, only : testing +!! ... +!! +!! !> Runs my unit_tests. Returns .true. if a test fails, .false. otherwise +!! logical function my_unit_tests(verbose) +!! logical, intent(in) :: verbose !< If true, write results to stdout +!! ... +!! type(testing) :: test ! An instance of the numerical_testing_type +!! ... +!! call test%set( verbose=.true. ) ! Show intermediate results rather than just the fails +!! ... +!! +!! call test%test(flag, 'Flag is not set') ! Check flag=.false. +!! call test%real_scalar(a, 1., 'u = 1') ! Check a=1 +!! call test%real_arr(3, u, (/1.,2.,3./), 'u = [1,2,3]') ! Check u(:)=[1,2,3] +!! call test%int_arr(2, iv, (/1,2/), 'iv = [1,2]') ! Check that iv(:)=[1,2] +!! +!! my_unit_tests = test%summarize('my_unit_tests') ! Return true if a fail occurs +!! end function my_unit_tests(verbose) +!! \endverbatim + end module numerical_testing_type diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index f54eb8a638..b6153a1091 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -24,7 +24,7 @@ module MOM_fixed_initialization use MOM_shared_initialization, only : reset_face_lengths_named, reset_face_lengths_file, reset_face_lengths_list use MOM_shared_initialization, only : read_face_length_list, set_velocity_depth_max, set_velocity_depth_min use MOM_shared_initialization, only : set_subgrid_topo_at_vel_from_file -use MOM_shared_initialization, only : compute_global_grid_integrals, write_ocean_geometry_file +use MOM_shared_initialization, only : compute_global_grid_integrals use MOM_unit_scaling, only : unit_scale_type use user_initialization, only : user_initialize_topography @@ -51,14 +51,12 @@ module MOM_fixed_initialization ! ----------------------------------------------------------------------------- !> MOM_initialize_fixed sets up time-invariant quantities related to MOM6's !! horizontal grid, bathymetry, and the Coriolis parameter. -subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) +subroutine MOM_initialize_fixed(G, US, OBC, PF) type(dyn_horgrid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure. type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. - logical, intent(in) :: write_geom !< If true, write grid geometry files. - character(len=*), intent(in) :: output_dir !< The directory into which to write files. ! Local variables character(len=200) :: inputdir ! The directory where NetCDF input files are. @@ -175,9 +173,6 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) ! Compute global integrals of grid values for later use in scalar diagnostics ! call compute_global_grid_integrals(G, US=US) -! Write out all of the grid data used by this run. - if (write_geom) call write_ocean_geometry_file(G, PF, output_dir, US=US) - call callTree_leave('MOM_initialize_fixed()') end subroutine MOM_initialize_fixed diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ded9557d97..2238f95e74 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -20,14 +20,9 @@ module MOM_state_initialization use MOM_interface_heights, only : find_eta, dz_to_thickness, dz_to_thickness_simple use MOM_interface_heights, only : calc_derived_thermo use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher -use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data -use MOM_open_boundary, only : OBC_NONE -use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data, initialize_segment_data -use MOM_open_boundary, only : open_boundary_test_extern_h -use MOM_open_boundary, only : fill_temp_salt_segments -use MOM_open_boundary, only : update_OBC_segment_data -!use MOM_open_boundary, only : set_3D_OBC_data +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_test_extern_h +use MOM_open_boundary, only : fill_temp_salt_segments, setup_OBC_tracer_reservoirs +use MOM_open_boundary, only : set_initialized_OBC_tracer_reservoirs use MOM_grid_initialize, only : initialize_masks, set_grid_metrics 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 @@ -103,7 +98,7 @@ module MOM_state_initialization #include -public MOM_initialize_state +public MOM_initialize_state, MOM_initialize_OBCs ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -143,6 +138,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & type(sponge_CS), pointer :: sponge_CSp !< The layerwise sponge control structure. type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< The ALE sponge control structure. type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure. + ! OBC is only used in MOM_initialize_state if OBC_RESERVOIR_INIT_BUG is true. type(oda_incupd_CS), pointer :: oda_incupd_CSp !< The oda_incupd control structure. type(time_type), optional, intent(in) :: Time_in !< Time at the start of the run segment. real, dimension(SZI_(G),SZJ_(G)), & @@ -162,8 +158,11 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & logical :: from_Z_file, useALE logical :: new_sim, rotate_index - logical :: use_temperature, use_sponge, use_OBC, use_oda_incupd + logical :: use_temperature, use_sponge, use_oda_incupd logical :: verify_restart_time + logical :: OBC_reservoir_init_bug ! If true, set the OBC tracer reservoirs at the startup of a new + ! run from the interior tracer concentrations regardless of properties that + ! may be explicitly specified for the reservoir concentrations. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. logical :: depress_sfc ! If true, remove the mass that would be displaced ! by a large surface pressure by squeezing the column. @@ -176,8 +175,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! is a run from a restart file; this option ! allows the use of Fatal unused parameters. type(EOS_type), pointer :: eos => NULL() + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: debug ! If true, write debugging output. - logical :: debug_obc ! If true, do debugging calls related to OBCs. logical :: debug_layers = .false. logical :: use_ice_shelf character(len=80) :: mesg @@ -194,7 +194,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call callTree_enter("MOM_initialize_state(), MOM_state_initialization.F90") call log_version(PF, mdl, version, "") call get_param(PF, mdl, "DEBUG", debug, default=.false.) - call get_param(PF, mdl, "DEBUG_OBC", debug_obc, default=.false.) new_sim = is_new_run(restart_CS) just_read = .not.new_sim @@ -206,7 +205,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & use_temperature = associated(tv%T) useALE = associated(ALE_CSp) use_EOS = associated(tv%eqn_of_state) - use_OBC = associated(OBC) if (use_EOS) eos => tv%eqn_of_state use_ice_shelf = PRESENT(frac_shelf_h) @@ -433,8 +431,23 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & end select endif endif ! not from_Z_file. - if (use_temperature .and. use_OBC) & - call fill_temp_salt_segments(G, GV, US, OBC, tv) + + if (use_temperature .and. associated(OBC)) then + call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + ! Log this parameter later with the other OBC parameters. + call get_param(PF, mdl, "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, & + "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& + "interior tracer concentrations regardless of properties that may be explicitly "//& + "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.) + if (OBC_reservoir_init_bug) then + ! These calls should be moved down to join the OBC code, but doing so changes answers because + ! the temperatures and salinities can change due to the remapping and reading from the restarts. + call pass_var(tv%T, G%Domain, complete=.false.) + call pass_var(tv%S, G%Domain, complete=.true.) + call fill_temp_salt_segments(G, GV, US, OBC, tv) + endif + endif ! Convert thicknesses from geometric distances in depth units to thickness units or mass-per-unit-area. if (new_sim .and. convert) call dz_to_thickness(dz, tv, h, G, GV, US) @@ -483,6 +496,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (new_sim .and. debug) & call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) + ! In this call, OBC is only used for the directions of OBCs when setting thicknesses at + ! velocity points. call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & dt=dt, initial=.true.) endif @@ -617,19 +632,72 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & end select endif - ! Reads OBC parameters not pertaining to the location of the boundaries - call open_boundary_init(G, GV, US, PF, OBC, restart_CS) + ! Set-up of data Assimilation with incremental update + if (use_oda_incupd) then + call initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, & + PF, oda_incupd_CSp, restart_CS, Time) + endif + + call callTree_leave('MOM_initialize_state()') + +end subroutine MOM_initialize_state + +subroutine MOM_initialize_OBCs(h, tv, OBC, Time, G, GV, US, PF, restart_CS, tracer_Reg) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic + !! variables + type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure. + type(time_type), intent(in) :: Time !< Time at the start of the run segment. + type(param_file_type), intent(in) :: PF !< A structure indicating the open file to parse + !! for model parameter values. + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry + + ! Local variables + character(len=200) :: config + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: debug ! If true, write debugging output. + logical :: debug_obc ! If true, do additional calls resetting values to help debug the correctness + ! of the open boundary condition code. + logical :: OBC_reservoir_init_bug ! If true, set the OBC tracer reservoirs at the startup of a new + ! run from the interior tracer concentrations regardless of properties that + ! may be explicitly specified for the reservoir concentrations. - ! This controls user code for setting open boundary data + call callTree_enter('MOM_initialize_OBCs()') if (associated(OBC)) then - call initialize_segment_data(G, GV, US, OBC, PF) -! call open_boundary_config(G, US, PF, OBC) - ! Call this once to fill boundary arrays from fixed values - if (OBC%some_need_no_IO_for_data) then - call calc_derived_thermo(tv, h, G, GV, US) - call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + call get_param(PF, mdl, "DEBUG", debug, default=.false.) + call get_param(PF, mdl, "OBC_DEBUGGING_TESTS", debug_obc, & + "If true, do additional calls resetting values to help verify the correctness "//& + "of the open boundary condition code.", default=.false., & + do_not_log=.true., old_name="DEBUG_OBC", debuggingParam=.true.) + call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(PF, mdl, "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, & + "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& + "interior tracer concentrations regardless of properties that may be explicitly "//& + "specified for the reservoir concentrations.", default=enable_bugs) + if (associated(tv%T)) then + if (OBC_reservoir_init_bug) then + if (is_new_run(restart_CS)) then + ! Set up OBC%trex_x and OBC%tres_y as they have not been read from a restart file. + call setup_OBC_tracer_reservoirs(G, GV, OBC) + ! Ensure that the values of the tracer reservoirs that have just been set will not be revised. + call set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS) + endif + else + ! Store the updated temperatures and salinities at the open boundaries, noting that they may + ! still be updated by the calls in the next 50 lines, so the code setting the tracer + ! reservoir values will come later in the calling routine. + call fill_temp_salt_segments(G, GV, US, OBC, tv) + endif endif + ! This controls user code for setting open boundary data call get_param(PF, mdl, "OBC_USER_CONFIG", config, & "A string that sets how the user code is invoked to set open boundary data: \n"//& " DOME - specified inflow on northern boundary\n"//& @@ -661,30 +729,18 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call MOM_error(FATAL, "The open boundary conditions specified by "//& "OBC_USER_CONFIG = "//trim(config)//" have not been fully implemented.") endif - if (open_boundary_query(OBC, apply_open_OBC=.true.)) then - call set_tracer_data(OBC, tv, h, G, GV, PF) + + if (debug) then + call hchksum(G%mask2dT, 'MOM_initialize_OBCs: mask2dT ', G%HI) + call uvchksum('MOM_initialize_OBCs: mask2dC[uv]', G%mask2dCu, G%mask2dCv, G%HI) + call qchksum(G%mask2dBu, 'MOM_initialize_OBCs: mask2dBu ', G%HI) endif - endif -! if (open_boundary_query(OBC, apply_nudged_OBC=.true.)) then -! call set_3D_OBC_data(OBC, tv, h, G, PF, tracer_Reg) -! endif - ! Still need a way to specify the boundary values - if (debug.and.associated(OBC)) then - call hchksum(G%mask2dT, 'MOM_initialize_state: mask2dT ', G%HI) - call uvchksum('MOM_initialize_state: mask2dC[uv]', G%mask2dCu, & - G%mask2dCv, G%HI) - call qchksum(G%mask2dBu, 'MOM_initialize_state: mask2dBu ', G%HI) + if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h) endif - if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h) - call callTree_leave('MOM_initialize_state()') + call callTree_leave('MOM_initialize_OBCs()') - ! Set-up of data Assimilation with incremental update - if (use_oda_incupd) then - call initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, & - PF, oda_incupd_CSp, restart_CS, Time) - endif -end subroutine MOM_initialize_state +end subroutine MOM_initialize_OBCs !> Reads the layer thicknesses or interface heights from a file. subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, file_has_thickness, & diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 4826477ad8..882296be99 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -47,7 +47,7 @@ module MOM_oda_driver_mod use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid -use MOM_fixed_initialization, only : MOM_initialize_fixed, MOM_initialize_topography +use MOM_fixed_initialization, only : MOM_initialize_topography use MOM_coord_initialization, only : MOM_initialize_coord use MOM_file_parser, only : read_param, get_param, param_file_type use MOM_string_functions, only : lowercase @@ -143,6 +143,7 @@ module MOM_oda_driver_mod !! remapping invoked by the ODA driver. Values below 20190101 recover !! the answers from the end of 2018, while higher values use updated !! and more robust forms of the same expressions. + logical :: reproduce_2018_nmme !< true if reproducing older NMME answers. end type ODA_CS @@ -174,6 +175,8 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) type(param_file_type) :: PF integer :: n integer :: isd, ied, jsd, jed + integer :: is_oda, ie_oda, js_oda, je_oda + integer :: isd_oda, ied_oda, jsd_oda, jed_oda integer, dimension(4) :: fld_sz character(len=32) :: assim_method integer :: npes_pm, ens_info(6) @@ -257,6 +260,12 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) "values use updated and more robust forms of the same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + call get_param(PF, mdl, "REPRODUCE_2018_NMME_ANSWERS", CS%reproduce_2018_nmme, & + "Logical flag needed to reproduce older NMME forecast answers."//& + "True gives old answers, the default of false gives different answers.", & + default=.false.) + inputdir = slasher(inputdir) select case(lowercase(trim(assim_method))) @@ -332,7 +341,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) h_neglect = set_h_neglect(GV, CS%answer_date, h_neglect_edge) call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells, & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge, answer_date=CS%answer_date) call set_regrid_params(CS%regridCS, min_thickness=0.) isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed @@ -362,7 +371,9 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) basin_file = trim(inputdir) // trim(basin_file) call get_param(PF, 'oda_driver', "BASIN_VAR", basin_var, & "The basin mask variable in BASIN_FILE.", default="basin") - allocate(CS%oda_grid%basin_mask(isd:ied,jsd:jed), source=0.0) + ! Need different data domain indices for the ODA ensemble basin mask. + call get_domain_extent(CS%Grid%Domain, is_oda, ie_oda, js_oda, je_oda, isd_oda, ied_oda, jsd_oda, jed_oda) + allocate(CS%oda_grid%basin_mask(isd_oda:ied_oda,jsd_oda:jed_oda), source=0.0) call MOM_read_data(basin_file, basin_var, CS%oda_grid%basin_mask, CS%Grid%domain, timelevel=1) endif @@ -492,17 +503,16 @@ subroutine get_posterior_tracer(Time, CS, increment) if (present(increment)) get_inc = increment if (get_inc) then - allocate(Ocean_increment) - Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T - Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S + CS%Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T + CS%Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S endif ! It may be necessary to check whether the increment and ocean state have the ! same dimensionally rescaled units. do m=1,CS%ensemble_size if (get_inc) then - call redistribute_array(CS%mpp_domain, Ocean_increment%T(:,:,:,m),& + call redistribute_array(CS%mpp_domain, CS%Ocean_increment%T(:,:,:,m),& CS%domains(m)%mpp_domain, CS%T_tend, complete=.true.) - call redistribute_array(CS%mpp_domain, Ocean_increment%S(:,:,:,m),& + call redistribute_array(CS%mpp_domain, CS%Ocean_increment%S(:,:,:,m),& CS%domains(m)%mpp_domain, CS%S_tend, complete=.true.) else call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m),& @@ -568,25 +578,38 @@ subroutine get_bias_correction_tracer(Time, US, CS) call cpu_clock_begin(id_clock_bias_adjustment) call horiz_interp_and_extrap_tracer(CS%INC_CS%T, Time, CS%G, T_bias, & - valid_flag, z_in, z_edges_in, missing_value, scale=US%degC_to_C*US%s_to_T, spongeOngrid=.true.) + valid_flag, z_in, z_edges_in, missing_value, scale=US%degC_to_C*US%s_to_T, spongeOngrid=.true., & + answer_date=CS%answer_date) call horiz_interp_and_extrap_tracer(CS%INC_CS%S, Time, CS%G, S_bias, & - valid_flag, z_in, z_edges_in, missing_value, scale=US%ppt_to_S*US%s_to_T, spongeOngrid=.true.) + valid_flag, z_in, z_edges_in, missing_value, scale=US%ppt_to_S*US%s_to_T, spongeOngrid=.true., & + answer_date=CS%answer_date) ! This should be replaced to use mask_z instead of the following lines ! which are intended to zero land values using an arbitrary limit. fld_sz=shape(T_bias) - do i=1,fld_sz(1) - do j=1,fld_sz(2) - do k=1,fld_sz(3) -! if (T_bias(i,j,k) > 1.0E-3*US%degC_to_C) T_bias(i,j,k) = 0.0 -! if (S_bias(i,j,k) > 1.0E-3*US%ppt_to_S) S_bias(i,j,k) = 0.0 - if (valid_flag(i,j,k)==0.) then - T_bias(i,j,k)=0.0 - S_bias(i,j,k)=0.0 - endif + if (CS%reproduce_2018_nmme) then + do i=1,fld_sz(1) + do j=1,fld_sz(2) + do k=1,fld_sz(3) + ! The following two lines are needed for backward compatibility for NMME answers (2018 vintage) + ! These were implemented to catch missing values, so large values are excluded. + if (T_bias(i,j,k) > 1.0E-3*US%degC_to_C) T_bias(i,j,k) = 0.0 + if (S_bias(i,j,k) > 1.0E-3*US%ppt_to_S) S_bias(i,j,k) = 0.0 + enddo enddo enddo - enddo + else + do i=1,fld_sz(1) + do j=1,fld_sz(2) + do k=1,fld_sz(3) + if (valid_flag(i,j,k)==0.) then + T_bias(i,j,k)=0.0 + S_bias(i,j,k)=0.0 + endif + enddo + enddo + enddo + endif CS%T_bc_tend = T_bias * CS%bias_adjustment_multiplier CS%S_bc_tend = S_bias * CS%bias_adjustment_multiplier diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index f6e45cffb0..c61b4bf54a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -138,7 +138,7 @@ module MOM_hor_visc !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_2d + real, allocatable :: Kh_bg_2d(:,:) !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. @@ -149,12 +149,13 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx !< The amount by which stresses through h points are reduced !! due to partial barriers [nondim]. + real, allocatable :: Kh_Max_xx(:,:) !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. + real, allocatable :: Ah_Max_xx(:,:) !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + real, allocatable :: Ah_Max_xx_KS(:,:) !< The maximum permitted biharmonic viscosity for + !! the kill switch [L4 T-1 ~> m4 s-1]. + real, allocatable :: n1n2_h(:,:) !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim] + real, allocatable :: n1n1_m_n2n2_h(:,:) !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. - Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. - Ah_Max_xx_KS, & !< The maximum permitted biharmonic viscosity for kill switch [L4 T-1 ~> m4 s-1]. - n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim] - n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points [nondim] grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2] grid_sp_h3 !< Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Kh_bg_xy @@ -168,20 +169,20 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy !< The amount by which stresses through q points are reduced !! due to partial barriers [nondim]. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - Kh_Max_xy, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. - Ah_Max_xy, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. - Ah_Max_xy_KS, & !< The maximum permitted biharmonic viscosity for kill switch [L4 T-1 ~> m4 s-1]. - n1n2_q, & !< Factor n1*n2 in the anisotropic direction tensor at q-points [nondim] - n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] + real, allocatable :: Kh_Max_xy(:,:) !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. + real, allocatable :: Ah_Max_xy(:,:) !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + real, allocatable :: Ah_Max_xy_KS(:,:) !< The maximum permitted biharmonic viscosity for + !! the kill switch [L4 T-1 ~> m4 s-1]. + real, allocatable :: n1n2_q(:,:) !< Factor n1*n2 in the anisotropic direction tensor at q-points [nondim] + real, allocatable :: n1n1_m_n2n2_q(:,:) !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2] dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] - dy_dxT, & !< Pre-calculated dy/dx at h points [nondim] - m_const_leithy, & !< Pre-calculated .5*sqrt(c_K)*max{dx,dy} [L ~> m] - m_leithy_max !< Pre-calculated 4./max(dx,dy)^2 at h points [L-2 ~> m-2] + dy_dxT !< Pre-calculated dy/dx at h points [nondim] + real, allocatable :: m_const_leithy(:,:) !< Pre-calculated .5*sqrt(c_K)*max{dx,dy} [L ~> m] + real, allocatable :: m_leithy_max(:,:) !< Pre-calculated 4./max(dx,dy)^2 at h points [L-2 ~> m-2] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & dx2q, & !< Pre-calculated dx^2 at q points [L2 ~> m2] dy2q, & !< Pre-calculated dy^2 at q points [L2 ~> m2] @@ -196,21 +197,19 @@ module MOM_hor_visc ! The following variables are precalculated time-invariant combinations of ! parameters and metric terms. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - Laplac2_const_xx, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm6_const_xx, & !< Biharmonic metric-dependent constants [L6 ~> m6] - Laplac3_const_xx, & !< Laplacian metric-dependent constants [L3 ~> m3] - Biharm_const_xx, & !< Biharmonic metric-dependent constants [L4 ~> m4] - Biharm_const2_xx, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] - Re_Ah_const_xx !< Biharmonic metric-dependent constants [L3 ~> m3] - - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - Laplac2_const_xy, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm6_const_xy, & !< Biharmonic metric-dependent constants [L6 ~> m6] - Laplac3_const_xy, & !< Laplacian metric-dependent constants [L3 ~> m3] - Biharm_const_xy, & !< Biharmonic metric-dependent constants [L4 ~> m4] - Biharm_const2_xy, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] - Re_Ah_const_xy !< Biharmonic metric-dependent constants [L3 ~> m3] + real, allocatable :: Laplac2_const_xx(:,:) !< Laplacian metric-dependent constants [L2 ~> m2] + real, allocatable :: Biharm6_const_xx(:,:) !< Biharmonic metric-dependent constants [L6 ~> m6] + real, allocatable :: Laplac3_const_xx(:,:) !< Laplacian metric-dependent constants [L3 ~> m3] + real, allocatable :: Biharm_const_xx(:,:) !< Biharmonic metric-dependent constants [L4 ~> m4] + real, allocatable :: Biharm_const2_xx(:,:) !< Biharmonic metric-dependent constants [T L4 ~> s m4] + real, allocatable :: Re_Ah_const_xx(:,:) !< Biharmonic metric-dependent constants [L3 ~> m3] + + real, allocatable :: Laplac2_const_xy(:,:) !< Laplacian metric-dependent constants [L2 ~> m2] + real, allocatable :: Biharm6_const_xy(:,:) !< Biharmonic metric-dependent constants [L6 ~> m6] + real, allocatable :: Laplac3_const_xy(:,:) !< Laplacian metric-dependent constants [L3 ~> m3] + real, allocatable :: Biharm_const_xy(:,:) !< Biharmonic metric-dependent constants [L4 ~> m4] + real, allocatable :: Biharm_const2_xy(:,:) !< Biharmonic metric-dependent constants [T L4 ~> s m4] + real, allocatable :: Re_Ah_const_xy(:,:) !< Biharmonic metric-dependent constants [L3 ~> m3] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics @@ -2370,6 +2369,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. logical :: use_MEKE ! If true, the MEKE parameterization is in use. + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. real :: backscatter_Ro_c ! Coefficient in Rossby number function for backscatter [nondim] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags character(len=200) :: inputdir, filename ! Input file names and paths @@ -2664,10 +2665,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, retain an answer-changing horizontal indexing bug in setting "//& "the corner-point viscosities when USE_KH_BG_2D=True. This is "//& "not recommended.", default=.false., do_not_log=.not.CS%use_Kh_bg_2d) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "FRICTWORK_BUG", CS%FrictWork_bug, & - "If true, retain an answer-changing bug in calculating "//& - "the FrictWork, which cancels the h in thickness flux and the h at velocity point. This is"//& - "not recommended.", default=.true.) + "If true, retain an answer-changing bug in calculating the FrictWork, "//& + "which cancels the h in thickness flux and the h at velocity point. This is"//& + "not recommended.", default=enable_bugs) call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& @@ -2742,16 +2745,16 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 if (CS%bound_Kh .or. CS%better_bound_Kh .or. CS%EY24_EBT_BS) then - ALLOC_(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed)) ; CS%Kh_Max_xx(:,:) = 0.0 - ALLOC_(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_Max_xy(:,:) = 0.0 + allocate(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed), source=0.0) + allocate(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif if (CS%Smagorinsky_Kh .or. CS%EY24_EBT_BS) then - ALLOC_(CS%Laplac2_const_xx(isd:ied,jsd:jed)) ; CS%Laplac2_const_xx(:,:) = 0.0 - ALLOC_(CS%Laplac2_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Laplac2_const_xy(:,:) = 0.0 + allocate(CS%Laplac2_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Laplac2_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif if (CS%Leith_Kh) then - ALLOC_(CS%Laplac3_const_xx(isd:ied,jsd:jed)) ; CS%Laplac3_const_xx(:,:) = 0.0 - ALLOC_(CS%Laplac3_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Laplac3_const_xy(:,:) = 0.0 + allocate(CS%Laplac3_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Laplac3_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif endif ALLOC_(CS%reduction_xx(isd:ied,jsd:jed)) ; CS%reduction_xx(:,:) = 0.0 @@ -2759,10 +2762,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%dynamic_aniso = .false. if (CS%anisotropic) then - ALLOC_(CS%n1n2_h(isd:ied,jsd:jed)) ; CS%n1n2_h(:,:) = 0.0 - ALLOC_(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed)) ; CS%n1n1_m_n2n2_h(:,:) = 0.0 - ALLOC_(CS%n1n2_q(IsdB:IedB,JsdB:JedB)) ; CS%n1n2_q(:,:) = 0.0 - ALLOC_(CS%n1n1_m_n2n2_q(IsdB:IedB,JsdB:JedB)) ; CS%n1n1_m_n2n2_q(:,:) = 0.0 + allocate(CS%n1n2_h(isd:ied,jsd:jed), source=0.0) + allocate(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed), source=0.0) + allocate(CS%n1n2_q(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%n1n1_m_n2n2_q(IsdB:IedB,JsdB:JedB), source=0.0) select case (aniso_mode) case (0) call align_aniso_tensor_to_grid(CS, aniso_grid_dir(1), aniso_grid_dir(2)) @@ -2786,7 +2789,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) if (CS%use_Kh_bg_2d) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - ALLOC_(CS%Kh_bg_2d(isd:ied,jsd:jed)) ; CS%Kh_bg_2d(:,:) = 0.0 + allocate(CS%Kh_bg_2d(isd:ied,jsd:jed), source=0.0) call MOM_read_data(trim(inputdir)//trim(filename), Kh_var, CS%Kh_bg_2d, & G%domain, timelevel=1, scale=US%m_to_L**2*US%T_to_s) call pass_var(CS%Kh_bg_2d, G%domain) @@ -2800,32 +2803,32 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 ALLOC_(CS%grid_sp_h3(isd:ied,jsd:jed)) ; CS%grid_sp_h3(:,:) = 0.0 if (CS%bound_Ah .or. CS%better_bound_Ah) then - ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 - ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 + allocate(CS%Ah_Max_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif if (CS%EY24_EBT_BS) then - ALLOC_(CS%Ah_Max_xx_KS(isd:ied,jsd:jed)) ; CS%Ah_Max_xx_KS(:,:) = 0.0 - ALLOC_(CS%Ah_Max_xy_KS(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy_KS(:,:) = 0.0 + allocate(CS%Ah_Max_xx_KS(isd:ied,jsd:jed), source=0.0) + allocate(CS%Ah_Max_xy_KS(IsdB:IedB,JsdB:JedB), source=0.0) endif if (CS%Smagorinsky_Ah) then - ALLOC_(CS%Biharm_const_xx(isd:ied,jsd:jed)) ; CS%Biharm_const_xx(:,:) = 0.0 - ALLOC_(CS%Biharm_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const_xy(:,:) = 0.0 + allocate(CS%Biharm_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Biharm_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) if (CS%bound_Coriolis) then - ALLOC_(CS%Biharm_const2_xx(isd:ied,jsd:jed)) ; CS%Biharm_const2_xx(:,:) = 0.0 - ALLOC_(CS%Biharm_const2_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const2_xy(:,:) = 0.0 + allocate(CS%Biharm_const2_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Biharm_const2_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif endif if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then - ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 - ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 + allocate(CS%biharm6_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif if (CS%use_Leithy) then - ALLOC_(CS%m_const_leithy(isd:ied,jsd:jed)) ; CS%m_const_leithy(:,:) = 0.0 - ALLOC_(CS%m_leithy_max(isd:ied,jsd:jed)) ; CS%m_leithy_max(:,:) = 0.0 + allocate(CS%m_const_leithy(isd:ied,jsd:jed), source=0.0) + allocate(CS%m_leithy_max(isd:ied,jsd:jed), source=0.0) endif if (CS%Re_Ah > 0.0) then - ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)) ; CS%Re_Ah_const_xx(:,:) = 0.0 - ALLOC_(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Re_Ah_const_xy(:,:) = 0.0 + allocate(CS%Re_Ah_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif endif do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 @@ -3519,48 +3522,42 @@ subroutine hor_visc_end(CS) if (CS%Laplacian) then DEALLOC_(CS%Kh_bg_xx) ; DEALLOC_(CS%Kh_bg_xy) DEALLOC_(CS%grid_sp_h2) - if (CS%bound_Kh) then - DEALLOC_(CS%Kh_Max_xx) ; DEALLOC_(CS%Kh_Max_xy) - endif - if (CS%Smagorinsky_Kh) then - DEALLOC_(CS%Laplac2_const_xx) ; DEALLOC_(CS%Laplac2_const_xy) - endif - if (CS%Leith_Kh) then - DEALLOC_(CS%Laplac3_const_xx) ; DEALLOC_(CS%Laplac3_const_xy) - endif + if (allocated(CS%Kh_bg_2d)) deallocate(CS%Kh_bg_2d) + + if (allocated(CS%Kh_Max_xx)) deallocate(CS%Kh_Max_xx) + if (allocated(CS%Kh_Max_xy)) deallocate(CS%Kh_Max_xy) + if (allocated(CS%Laplac2_const_xx)) deallocate(CS%Laplac2_const_xx) + if (allocated(CS%Laplac2_const_xy)) deallocate(CS%Laplac2_const_xy) + if (allocated(CS%Laplac3_const_xx)) deallocate(CS%Laplac3_const_xx) + if (allocated(CS%Laplac3_const_xy)) deallocate(CS%Laplac3_const_xy) endif if (CS%biharmonic) then DEALLOC_(CS%grid_sp_h3) DEALLOC_(CS%Idx2dyCu) ; DEALLOC_(CS%Idx2dyCv) DEALLOC_(CS%Idxdy2u) ; DEALLOC_(CS%Idxdy2v) DEALLOC_(CS%Ah_bg_xx) ; DEALLOC_(CS%Ah_bg_xy) - if (CS%bound_Ah) then - DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) - endif - if (CS%EY24_EBT_BS) then - DEALLOC_(CS%Ah_Max_xx_KS) ; DEALLOC_(CS%Ah_Max_xy_KS) - endif - if (CS%Smagorinsky_Ah) then - DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) - endif - if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then - DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) - endif - if (CS%use_Leithy) then - DEALLOC_(CS%m_const_leithy) - DEALLOC_(CS%m_leithy_max) - endif - if (CS%Re_Ah > 0.0) then - DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) - endif - endif - if (CS%anisotropic) then - DEALLOC_(CS%n1n2_h) - DEALLOC_(CS%n1n2_q) - DEALLOC_(CS%n1n1_m_n2n2_h) - DEALLOC_(CS%n1n1_m_n2n2_q) + + if (allocated(CS%Ah_Max_xx)) deallocate(CS%Ah_Max_xx) + if (allocated(CS%Ah_Max_xy)) deallocate(CS%Ah_Max_xy) + if (allocated(CS%Ah_Max_xx_KS)) deallocate(CS%Ah_Max_xx_KS) + if (allocated(CS%Ah_Max_xy_KS)) deallocate(CS%Ah_Max_xy_KS) + if (allocated(CS%Biharm_const_xx)) deallocate(CS%Biharm_const_xx) + if (allocated(CS%Biharm_const_xy)) deallocate(CS%Biharm_const_xy) + if (allocated(CS%Biharm_const2_xx)) deallocate(CS%Biharm_const2_xx) + if (allocated(CS%Biharm_const2_xy)) deallocate(CS%Biharm_const2_xy) + if (allocated(CS%Biharm6_const_xx)) deallocate(CS%Biharm6_const_xx) + if (allocated(CS%Biharm6_const_xy)) deallocate(CS%Biharm6_const_xy) + if (allocated(CS%m_const_leithy)) deallocate(CS%m_const_leithy) + if (allocated(CS%m_leithy_max)) deallocate(CS%m_leithy_max) + if (allocated(CS%Re_Ah_const_xx)) deallocate(CS%Re_Ah_const_xx) + if (allocated(CS%Re_Ah_const_xy)) deallocate(CS%Re_Ah_const_xy) endif + if (allocated(CS%n1n2_h)) deallocate(CS%n1n2_h) + if (allocated(CS%n1n2_q)) deallocate(CS%n1n2_q) + if (allocated(CS%n1n1_m_n2n2_h)) deallocate(CS%n1n1_m_n2n2_h) + if (allocated(CS%n1n1_m_n2n2_q)) deallocate(CS%n1n1_m_n2n2_q) + if (CS%use_ZB2020) then call ZB2020_end(CS%ZB2020) endif diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 794de22636..0525dcd05b 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -12,7 +12,7 @@ module MOM_internal_tides use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_diag_mediator, only : axes_grp, define_axes_group use MOM_domains, only : AGRID, To_South, To_West, To_All, CGRID_NE -use MOM_domains, only : create_group_pass, pass_var, pass_vector +use MOM_domains, only : create_group_pass, do_group_pass, pass_var, pass_vector use MOM_domains, only : group_pass_type, start_group_pass, complete_group_pass use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type @@ -47,6 +47,7 @@ module MOM_internal_tides integer :: nMode = 1 !< The number of internal tide vertical modes integer :: nAngle = 24 !< The number of internal tide angular orientations integer :: energized_angle = -1 !< If positive, only this angular band is energized for debugging purposes + real :: dt_itides !< The timestep for internal tides ray-tracing [s ~> T] real :: uniform_test_cg !< Uniform group velocity of internal tide !! for testing internal tides [L T-1 ~> m s-1] logical :: corner_adv !< If true, use a corner advection rather than PPM. @@ -151,6 +152,7 @@ module MOM_internal_tides real :: En_underflow !< A minuscule amount of energy [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: En_restart_power !< A power factor of 2 by which to multiply the energy in restart [nondim] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. + type(group_pass_type) :: pass_En !< Pass 5d array Energy as a group of 3d arrays character(len=200) :: inputdir !< directory to look for coastline angle file real, allocatable, dimension(:,:,:,:) :: decay_rate_2d !< rate at which internal tide energy is !! lost to the interior ocean internal wave field @@ -314,6 +316,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C real :: I_D_here ! The inverse of the local water column thickness [H-1 ~> m-1 or m2 kg-1] real :: I_mass ! The inverse of the local water mass [R-1 Z-1 ~> m2 kg-1] real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: dt_sub ! The effective timestep use to subcycle the propagation [T ~> s] real :: En_restart_factor ! A multiplicative factor of the form 2**En_restart_power [nondim] real :: I_En_restart_factor ! The inverse of the restart mult factor [nondim] real :: freq2 ! The frequency squared [T-2 ~> s-2] @@ -337,9 +340,10 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! 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 + integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle, nc integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) - type(group_pass_type), save :: pass_test, pass_En + integer :: subcycles ! number of subcycles for the propagation + type(group_pass_type), save :: pass_test type(time_type) :: time_end logical:: avg_enabled @@ -356,6 +360,13 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C En_restart_factor = 2**CS%En_restart_power I_En_restart_factor = 1.0 / En_restart_factor + if (CS%dt_itides <= 0.) then + subcycles = 1 + else + subcycles = CEILING(dt/CS%dt_itides - 0.0001) + endif + dt_sub = dt / subcycles + ! initialize local arrays TKE_itidal_input(:,:,:) = 0. vel_btTide(:,:,:) = 0. @@ -513,147 +524,155 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C enddo ; enddo endif - ! Apply half the refraction. - if (CS%apply_refraction) then - do m=1,CS%nMode ; do fr=1,CS%nFreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%nAngle, CS%use_PPMang) - enddo ; enddo - endif - ! A this point, CS%En is only valid on the computational domain. + call complete_group_pass(pass_test, G%domain) - if (CS%force_posit_En) then - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=jsd,jed ; do i=isd,ied - if (CS%En(i,j,a,fr,m)<0.0) then - CS%En(i,j,a,fr,m) = 0.0 - endif + ! TKE_slope_loss need to be accumulated but since it is + ! passed as inout and accumulated within propagate_x/propagate_y + ! it does not need temp array for accumulation + CS%TKE_slope_loss(:,:,:,:,:) = 0. + + ! Start subcycling + do nc=1,subcycles + + ! Apply half the refraction. + if (CS%apply_refraction) then + do m=1,CS%nMode ; do fr=1,CS%nFreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt_sub, & + G, US, CS%nAngle, CS%use_PPMang) enddo ; enddo - enddo ; enddo ; enddo - endif + endif + ! A this point, CS%En is only valid on the computational domain. - if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 1/2 refraction') - if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 1/2 refraction', CS%En_sum - enddo ; enddo - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 1/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 1/2 refraction', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo - endif + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - call complete_group_pass(pass_test, G%domain) + ! Set the halo size to work on, using similar logic to that used in propagate. This may need + ! to be adjusted depending on the advection scheme and whether teleport is used. + if (CS%upwind_1st) then ; En_halo_ij_stencil = 2 + else ; En_halo_ij_stencil = 3 ; endif - ! Set the halo size to work on, using similar logic to that used in propagate. This may need - ! to be adjusted depending on the advection scheme and whether teleport is used. - if (CS%upwind_1st) then ; En_halo_ij_stencil = 2 - else ; En_halo_ij_stencil = 3 ; endif + ! Rotate points in the halos as necessary. + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) - ! Rotate points in the halos as necessary. - call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo R", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after correct halo rotation') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after correct halo rotation', CS%En_sum + enddo ; enddo + endif - if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo R", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after correct halo rotation') - if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after correct halo rotation', CS%En_sum - enddo ; enddo - endif - ! Propagate the waves. - do m=1,CS%nMode ; do fr=1,CS%Nfreq + if (CS%apply_propagation) then + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt_sub, & + G, GV, US, CS, CS%NAngle, CS%TKE_slope_loss(:,:,:,fr,m)) + endif + enddo ; enddo - ! initialize residual loss, will be computed in propagate - CS%TKE_residual_loss(:,:,:,fr,m) = 0. - CS%TKE_slope_loss(:,:,:,fr,m) = 0. + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - if (CS%apply_propagation) then - call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & - G, GV, US, CS, CS%NAngle, CS%TKE_slope_loss(:,:,:,fr,m)) - endif - enddo ; enddo + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after propagate') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after propagate', CS%En_sum + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + if (abs(CS%En(i,j,a,fr,m))>CS%En_check_tol) then ! only print if large + write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + ! RD propagate produces very little negative energy (diff 2 large numbers), needs fix + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - if (CS%force_posit_En) then - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=jsd,jed ; do i=isd,ied - if (CS%En(i,j,a,fr,m)<0.0) then - CS%En(i,j,a,fr,m) = 0.0 - endif + if (CS%apply_refraction) then + ! Apply the other half of the refraction. + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt_sub, & + G, US, CS%NAngle, CS%use_PPMang) enddo ; enddo - enddo ; enddo ; enddo - endif + ! A this point, CS%En is only valid on the computational domain. + endif - if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after propagate') - if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after propagate', CS%En_sum - enddo ; enddo - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - if (abs(CS%En(i,j,a,fr,m))>CS%En_check_tol) then ! only print if large - write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 2/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 2/2 refraction', CS%En_sum + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - ! RD propagate produces very little negative energy (diff 2 large numbers), needs fix !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") endif - endif - enddo ; enddo - enddo ; enddo ; enddo - endif - - if (CS%apply_refraction) then - ! Apply the other half of the refraction. - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%NAngle, CS%use_PPMang) - enddo ; enddo - ! A this point, CS%En is only valid on the computational domain. - endif + enddo ; enddo + enddo ; enddo ; enddo + endif - if (CS%force_posit_En) then - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=jsd,jed ; do i=isd,ied - if (CS%En(i,j,a,fr,m)<0.0) then - CS%En(i,j,a,fr,m) = 0.0 - endif - enddo ; enddo - enddo ; enddo ; enddo - endif + call do_group_pass(CS%pass_En, G%domain) - if (CS%debug) then - call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 2/2 refraction') - if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 2/2 refraction', CS%En_sum - enddo ; enddo - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif - enddo ; enddo - enddo ; enddo ; enddo - endif + enddo ! end subcycling ! Apply various dissipation mechanisms. if (CS%apply_background_drag .or. CS%apply_bottom_drag & @@ -1757,7 +1776,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 if (k>1) Kd_leak(i,K) = 0.5*Kd_leak_lay(k-1) if (k1) Kd_itidal(i,K) = 0.5*Kd_itidal_lay(k-1) if (k1) Kd_Froude(i,K) = 0.5*Kd_Froude_lay(k-1) if (k1) Kd_slope(i,K) = 0.5*Kd_slope_lay(k-1) if (k1) Kd_quad(i,K) = 0.5*Kd_quad_lay(k-1) if (k= 6 are dissipated locally and do not propagate ! so we only allow for 5 vertical modes and each has its own variable @@ -3188,6 +3209,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_ANGLES", num_angle, & "The number of angular resolution bands for the internal "//& "tide calculations.", default=24) + call get_param(param_file, mdl, "DT_ITIDES", CS%dt_itides, & + "The timestep for internal tides ray-tracing scheme"//& + "If set to -1 (default), it uses the same value as DT_THERM", & + units="s", default=-1., scale=US%s_to_T) if (use_int_tides) then if ((num_freq <= 0) .and. (num_mode <= 0) .and. (num_angle <= 0)) then diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index f2f476b0c8..b67ebaad86 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -9,6 +9,7 @@ module MOM_lateral_mixing_coeffs use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled use MOM_domains, only : create_group_pass, do_group_pass use MOM_domains, only : group_pass_type, pass_var, pass_vector +use MOM_EOS, only : calculate_density_derivs, EOS_domain use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_isopycnal_slopes, only : calc_isoneutral_slopes @@ -17,10 +18,10 @@ module MOM_lateral_mixing_coeffs use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init -use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_MEKE_types, only : MEKE_type - implicit none ; private #include @@ -80,10 +81,13 @@ module MOM_lateral_mixing_coeffs !! in its denominator, rather than just the nominal depth of !! the bathymetry. This only applies when using the model !! interface heights as a proxy for isopycnal slopes. + logical :: OBC_friendly !< If true, use only interior data for thickness weighting and + !! to calculate stratification and other fields at open boundary + !! condition faces. real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or !! incropped interfaces for the Eady growth rate calc [Z ~> m] real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the - !! bouyancy frequency used in the slope calculation [H ~> m or kg m-2] + !! buoyancy frequency used in the slope calculation [H ~> m or kg m-2] real, allocatable :: SN_u(:,:) !< S*N at u-points [T-1 ~> s-1] real, allocatable :: SN_v(:,:) !< S*N at v-points [T-1 ~> s-1] @@ -130,20 +134,16 @@ module MOM_lateral_mixing_coeffs real, allocatable :: kdgl90_struct(:,:,:) !< Vertical structure function used in GL90 diffusivity [nondim] real :: BS_EBT_power !< Power to raise EBT vertical structure to. Default 0.0. real :: sqg_expo !< Exponent for SQG vertical structure [nondim]. Default 1.0 + logical :: interpolated_sqg_struct !< If true, interpolate properties to velocity points and then + !! interpolate the buoyancy frequencies and layer thicknesses + !! back to tracer points when calculating the SQG vertical + !! structure. logical :: BS_use_sqg_struct !< If true, use sqg_stuct for backscatter vertical structure. - - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & - Laplac3_const_u !< Laplacian metric-dependent constants [L3 ~> m3] - - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & - Laplac3_const_v !< Laplacian metric-dependent constants [L3 ~> m3] - - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - KH_u_QG !< QG Leith GM coefficient at u-points [L2 T-1 ~> m2 s-1] - - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - KH_v_QG !< QG Leith GM coefficient at v-points [L2 T-1 ~> m2 s-1] + real, allocatable :: Laplac3_const_u(:,:) !< Laplacian metric-dependent constants at u-points [L3 ~> m3] + real, allocatable :: Laplac3_const_v(:,:) !< Laplacian metric-dependent constants at u-points [L3 ~> m3] + real, allocatable :: KH_u_QG(:,:,:) !< QG Leith GM coefficient at u-points [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_v_QG(:,:,:) !< QG Leith GM coefficient at v-points [L2 T-1 ~> m2 s-1] ! Parameters logical :: use_Visbeck !< Use Visbeck formulation for thickness diffusivity @@ -232,7 +232,7 @@ subroutine calc_depth_function(G, CS) end subroutine calc_depth_function !> Calculates and stores the non-dimensional resolution functions -subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt) +subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, OBC, dt) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -240,6 +240,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure type(MEKE_type), intent(in) :: MEKE !< MEKE struct + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure real, intent(in) :: dt !< Time increment [T ~> s] ! Local variables @@ -284,7 +285,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt) endif if (CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct & .or. CS%kdgl90_use_sqg_struct .or. CS%id_sqg_struct>0) then - call calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) + call calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE, OBC) call pass_var(CS%sqg_struct, G%Domain) endif @@ -536,21 +537,21 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt) end subroutine calc_resoln_function !> Calculates and stores functions of SQG mode -subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) +subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv ! s] + type(thermo_var_ptrs), intent(in) :: tv ! s] type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct - type(MEKE_type), intent(in) :: MEKE !< MEKE struct + type(MEKE_type), intent(in) :: MEKE !< MEKE struct + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure ! Local variables - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & - e ! The interface heights relative to mean sea level [Z ~> m]. - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: e ! The interface heights relative to mean sea level [Z ~> m] + real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of buoyancy frequency at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of buoyancy frequency at v-points [L2 Z-2 T-2 ~> s-2] real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] @@ -560,6 +561,23 @@ subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) real :: dzc ! Spacing between two adjacent layers in stretched vertical coordinate [Z ~> m] real :: f_subround ! The minimal resolved value of Coriolis parameter to prevent division by zero [T-1 ~> s-1] real, dimension(SZI_(G), SZJ_(G)) :: Le ! Eddy length scale [L ~> m] + + real :: dz(SZI_(G), SZJ_(G), SZK_(GV)) ! Geometric layer thicknesses in height units [Z ~> m] + real :: I_f_Le(SZI_(G), SZJ_(G)) ! The inverse of the absolute value of f times the Eddy + ! length scale [T L-1 ~> s m-1] + real :: p_i(SZI_(G), SZJ_(G)) ! Pressure at the interface [R L2 T-2 ~> Pa] + real :: T_i(SZI_(G)) ! Temperature at the interface [C ~> degC] + real :: S_i(SZI_(G)) ! Salinity at the interface [S ~> ppt] + real :: dRho_dS(SZI_(G)) ! Local change in density with salinity using the model EOS and + ! state interpolated to an interface [R C-1 ~> kg m-3 ppt-1] + real :: dRho_dT(SZI_(G)) ! Local change in density with salinity using the model EOS and + ! state interpolated [R C-1 ~> kg m-3 degC-1] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real :: GxSpV ! Gravitiational acceleration times the specific volume at an interface + ! [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + real :: drdk ! Vertical density differences across an interface [R ~> kg m-3] + real :: dz_int ! Average of thicknesses around an interface in height units [Z ~> m] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -568,43 +586,97 @@ subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE) if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions: "//& "Module must be initialized before it is used.") - call find_eta(h, tv, G, GV, US, e, halo_size=2) - call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & - CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v,dzu=dzu, dzv=dzv, & - dzSxN=dzSxN, dzSyN=dzSyN, halo=1) - - if (CS%sqg_expo<=0.) then + if (CS%sqg_expo <= 0.) then CS%sqg_struct(:,:,:) = 1. else - do j=js,je ; do i=is,ie - CS%sqg_struct(i,j,1) = 1.0 - enddo ; enddo if (allocated(MEKE%Le)) then do j=js,je ; do i=is,ie Le(i,j) = MEKE%Le(i,j) - f(i,j) = max(0.25 * abs((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & - (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))), f_subround) enddo ; enddo else do j=js,je ; do i=is,ie Le(i,j) = sqrt(G%areaT(i,j)) + enddo ; enddo + endif + + do j=js,je ; do i=is,ie + ! Setting the structure averaged over the top layer to 1 is consistent with it being well mixed. + CS%sqg_struct(i,j,1) = 1.0 + enddo ; enddo + + if (CS%interpolated_sqg_struct) then + do j=js,je ; do i=is,ie f(i,j) = max(0.25 * abs((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))), f_subround) enddo ; enddo + call find_eta(h, tv, G, GV, US, e, halo_size=2) !### Could be halo_size=1? + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, dzu=dzu, dzv=dzv, & + dzSxN=dzSxN, dzSyN=dzSyN, halo=1, OBC=OBC, OBC_N2=CS%OBC_friendly) + do k=2,nz ; do j=js,je ; do i=is,ie + N2 = max(0.25 * ((N2_u(I-1,j,K) + N2_u(I,j,K)) + (N2_v(i,J-1,K) + N2_v(i,J,K))), 0.0) + dzc = 0.25 * ((dzu(I-1,j,K) + dzu(I,j,K)) + (dzv(i,J-1,K) + dzv(i,J,K))) + CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + exp(-CS%sqg_expo * (dzc * sqrt(N2)/(f(i,j) * Le(i,j)))) + enddo ; enddo ; enddo + else + do j=js,je ; do i=is,ie + I_f_Le(i,j) = 1.0 / & + (Le(i,j) * max(0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))), f_subround)) + enddo ; enddo + + call thickness_to_dz(h, tv, dz, G, GV, US) + + if (associated(tv%eqn_of_state)) then + EOSdom(:) = EOS_domain(G%HI) + H_to_pres = GV%H_to_RZ * GV%g_Earth + ! Set the pressure at the topmost interior interface. + p_i(:,:) = 0.0 + if (associated(tv%p_surf)) then + do j=js,je ; do i=is,ie ; p_i(i,j) = tv%p_surf(i,j) ; enddo ; enddo + endif + if (.not.allocated(tv%SpV_avg)) GxSpV = GV%g_Earth / GV%Rho0 + do K=2,nz ; do j=js,je + ! Find the derivatives of density with T and S at the interface. + do i=is,ie + p_i(i,j) = p_i(i,j) + H_to_pres * h(i,j,k-1) + T_i(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) + S_i(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) + enddo + call calculate_density_derivs(T_i, S_i, p_i(:,j), dRho_dT, dRho_dS, tv%eqn_of_state, EOSdom) + + do i=is,ie + if (allocated(tv%SpV_avg)) & ! GxSpV is in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + GxSpV = GV%g_Earth * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j,k-1)) + + drdk = max(dRho_dT(i) * (tv%T(i,j,k)-tv%T(i,j,k-1)) + & + dRho_dS(i) * (tv%S(i,j,k)-tv%S(i,j,k-1)), 0.0) ! Density difference [R ~> kg m-3] + dz_int = 0.5*(dz(i,j,k-1) + dz(i,j,k)) ! Thickness around interface [Z ~> m] + CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + exp(-CS%sqg_expo * (sqrt((GxSpV * drdk) * dz_int) * I_f_Le(i,j)) ) + ! To derive the expression above, note that + ! N2 = GxSpV * drdk / dzh(i,j,K) ! Square of positive buoyancy freq. [L2 Z-2 T-2 ~> s-2] + ! CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + ! exp(-CS%sqg_expo * (dz_int(i,j,K) * sqrt(N2) * I_f_Le(i,j)) ) + enddo + enddo ; enddo + else ! (GV%Boussinesq .and. .not.use_EOS) then + do K=2,nz ; do j=js,je ; do i=is,ie + dz_int = 0.5*(dz(i,j,k-1) + dz(i,j,k)) ! Thickness around interface [Z ~> m] + CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + exp(-CS%sqg_expo * (sqrt(GV%g_prime(K) * dz_int) * I_f_Le(i,j)) ) + enddo ; enddo ; enddo + endif endif - do k=2,nz ; do j=js,je ; do i=is,ie - N2 = max(0.25 * ((N2_u(I-1,j,k) + N2_u(I,j,k)) + (N2_v(i,J-1,k) + N2_v(i,J,k))), 0.0) - dzc = 0.25 * ((dzu(I-1,j,k) + dzu(I,j,k)) + (dzv(i,J-1,k) + dzv(i,J,k))) - CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & - exp(-CS%sqg_expo * (dzc * sqrt(N2)/(f(i,j) * Le(i,j)))) - enddo ; enddo ; enddo endif - if (query_averaging_enabled(CS%diag)) then if (CS%id_sqg_struct > 0) call post_data(CS%id_sqg_struct, CS%sqg_struct, CS%diag) - if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) - if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + if (CS%interpolated_sqg_struct .and. (CS%sqg_expo > 0.)) then + if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) + if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + endif endif end subroutine calc_sqg_struct @@ -620,10 +692,11 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) real, intent(in) :: dt !< Time increment [T ~> s] type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! The interface heights relative to mean sea level [Z ~> m] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of buoyancy frequency at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of buoyancy frequency at v-points [L2 Z-2 T-2 ~> s-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] @@ -637,12 +710,13 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) if (CS%use_simpler_Eady_growth_rate) then call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, dzu=dzu, dzv=dzv, & - dzSxN=dzSxN, dzSyN=dzSyN, halo=1, OBC=OBC) + dzSxN=dzSxN, dzSyN=dzSyN, halo=1, OBC=OBC, OBC_N2=CS%OBC_friendly) call calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, CS%SN_u, CS%SN_v) elseif (CS%use_stored_slopes) then call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & - CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) - call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC, & + OBC_N2=CS%OBC_friendly) + call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC) else call calc_slope_functions_using_just_e(h, G, GV, US, CS, e) endif @@ -666,7 +740,7 @@ end subroutine calc_slope_functions !> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al., 1997. !! This is on older implementation that is susceptible to large values of Eady growth rate !! for incropping layers. -subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) +subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -679,6 +753,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C !! at v-points [L2 Z-2 T-2 ~> s-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. ! Local variables real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] @@ -697,8 +772,15 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C real :: S2_v(SZI_(G),SZJB_(G)) ! At first the thickness-weighted depth integral of the squared ! slope [H Z2 L-2 ~> m or kg m-2] and then the average of the ! squared slope [Z2 L-2 ~> nondim] at v points. - - integer :: i, j, k, is, ie, js, je, nz, l_seg + integer :: OBC_dir_u(SZIB_(G),SZJ_(G)) ! An integer indicating where there are u OBCs: +1 for + ! eastern OBCs, -1 for western OBCs and 0 at points with no OBCs. + integer :: OBC_dir_v(SZI_(G),SZJB_(G)) ! An integer indicating where there are v OBCs: +1 for + ! northern OBCs, -1 for southern OBCs and 0 at points with no OBCs. + real :: h4_u(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! The product of the 4 thicknesses surrounding a u-point + ! interface or the inward equivalent with OBCs [H4 ~> m4 or kg2 m-4] + real :: h4_v(SZI_(G),SZJB_(G),SZK_(GV)+1) ! The product of the 4 thicknesses surrounding a v-point + ! interface or the inward equivalent with OBCs [H4 ~> m4 or kg2 m-4] + integer :: i, j, k, is, ie, js, je, nz if (.not. CS%initialized) call MOM_error(FATAL, "calc_Visbeck_coeffs_old: "// & "Module must be initialized before it is used.") @@ -713,11 +795,59 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C S2max = CS%Visbeck_S_max**2 - !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 - CS%SN_u(i,j) = 0.0 - CS%SN_v(i,j) = 0.0 - enddo ; enddo + CS%SN_u(:,:) = 0.0 + CS%SN_v(:,:) = 0.0 + + ! These settings apply where there are not open boundary conditions. + OBC_dir_u(:,:) = 0 ; OBC_dir_v(:,:) = 0 + + if (associated(OBC).and. CS%OBC_friendly) then + ! Store the direction of any OBC faces. + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segnum_u(I,j) > 0) OBC_dir_u(I,j) = 1 ! OBC_DIRECTION_E + if (OBC%segnum_u(I,j) < 0) OBC_dir_u(I,j) = -1 ! OBC_DIRECTION_W + endif ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is-1,ie+1 ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segnum_v(i,J) > 0) OBC_dir_v(i,J) = 1 ! OBC_DIRECTION_N + if (OBC%segnum_v(i,J) < 0) OBC_dir_v(i,J) = -1 ! OBC_DIRECTION_S + endif ; enddo ; enddo + + ! Use the masked product of the 4 (or 2) thicknesses around a velocity-point interface for weights. + !$OMP parallel do default(shared) + do K=2,nz + do j=js-1,je+1 ; do I=is-1,ie + if (OBC_dir_u(I,j) == 0) then + h4_u(I,j,K) = G%mask2dCu(I,j) * ( (h(i,j,k)*h(i+1,j,k)) * (h(i,j,k-1)*h(i+1,j,k-1)) ) + elseif (OBC_dir_u(I,j) == 1) then ! OBC_DIRECTION_E + h4_u(I,j,K) = G%mask2dCu(I,j) * ( (h(i,j,k)**2) * (h(i,j,k-1)**2) ) + elseif (OBC_dir_u(I,j) == -1) then ! OBC_DIRECTION_W + h4_u(I,j,K) = G%mask2dCu(I,j) * ( (h(i+1,j,k)**2) * (h(i+1,j,k-1)**2) ) + endif + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + if (OBC_dir_v(i,J) == 0) then + h4_v(i,J,K) = G%mask2dCv(i,J) * ( (h(i,j,k)*h(i,j+1,k)) * (h(i,j,k-1)*h(i,j+1,k-1)) ) + elseif (OBC_dir_v(i,J) == 1) then ! OBC_DIRECTION_N + h4_v(i,J,K) = G%mask2dCv(i,J) * ( (h(i,j,k)**2) * (h(i,j,k-1)**2) ) + elseif (OBC_dir_v(i,J) == -1) then ! OBC_DIRECTION_S + h4_v(i,J,K) = G%mask2dCv(i,J) * ( (h(i,j+1,k)**2) * (h(i,j+1,k-1)**2) ) + endif + enddo ; enddo + enddo + else ! The land mask is sufficient and there are no special considerations taken at OBC points. + ! Use the masked product of the 4 thicknesses around a velocity-point interface for weights. + !$OMP parallel do default(shared) + do K=2,nz + do j=js-1,je+1 ; do I=is-1,ie + h4_u(I,j,K) = G%mask2dCu(I,j) * ( (h(i,j,k)*h(i+1,j,k)) * (h(i,j,k-1)*h(i+1,j,k-1)) ) + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + h4_v(i,J,K) = G%mask2dCv(i,J) * ( (h(i,j,k)*h(i,j+1,k)) * (h(i,j,k-1)*h(i,j+1,k-1)) ) + enddo ; enddo + enddo + endif ! To set the length scale based on the deformation radius, use wave_speed to ! calculate the first-mode gravity wave speed and then blend the equatorial @@ -734,10 +864,17 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C H_geom = sqrt( Hdn * Hup ) !H_geom = H_geom * sqrt(N2) ! WKB-ish !H_geom = H_geom * N2 ! WKB-ish - wSE = G%mask2dCv(i+1,J-1) * ( (h(i+1,j,k)*h(i+1,j-1,k)) * (h(i+1,j,k-1)*h(i+1,j-1,k-1)) ) - wNW = G%mask2dCv(i ,J ) * ( (h(i ,j,k)*h(i ,j+1,k)) * (h(i ,j,k-1)*h(i ,j+1,k-1)) ) - wNE = G%mask2dCv(i+1,J ) * ( (h(i+1,j,k)*h(i+1,j+1,k)) * (h(i+1,j,k-1)*h(i+1,j+1,k-1)) ) - wSW = G%mask2dCv(i ,J-1) * ( (h(i ,j,k)*h(i ,j-1,k)) * (h(i ,j,k-1)*h(i ,j-1,k-1)) ) + wSE = h4_v(i+1,J-1,K) + wNW = h4_v(i,J,K) + wNE = h4_v(i+1,J,K) + wSW = h4_v(i,J-1,K) + if (OBC_dir_u(I,j) == 1) then ! OBC_DIRECTION_E + wSE = 0.0 ; wNE = 0.0 + H_geom = sqrt( h(i,j,k) * h(i,j,k-1) ) + elseif (OBC_dir_u(I,j) == -1) then ! OBC_DIRECTION_W + wSW = 0.0 ; wNW = 0.0 + H_geom = sqrt( h(i+1,j,k) * h(i+1,j,k-1) ) + endif S2 = slope_x(I,j,K)**2 + & (((wNW*slope_y(i,J,K)**2) + (wSE*slope_y(i+1,J-1,K)**2)) + & ((wNE*slope_y(i+1,J,K)**2) + (wSW*slope_y(i,J-1,K)**2)) ) / & @@ -770,10 +907,17 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C H_geom = sqrt( Hdn * Hup ) !H_geom = H_geom * sqrt(N2) ! WKB-ish !H_geom = H_geom * N2 ! WKB-ish - wSE = G%mask2dCu(I,j) * ( (h(i,j ,k)*h(i+1,j ,k)) * (h(i,j ,k-1)*h(i+1,j ,k-1)) ) - wNW = G%mask2dCu(I-1,j+1) * ( (h(i,j+1,k)*h(i-1,j+1,k)) * (h(i,j+1,k-1)*h(i-1,j+1,k-1)) ) - wNE = G%mask2dCu(I,j+1) * ( (h(i,j+1,k)*h(i+1,j+1,k)) * (h(i,j+1,k-1)*h(i+1,j+1,k-1)) ) - wSW = G%mask2dCu(I-1,j) * ( (h(i,j ,k)*h(i-1,j ,k)) * (h(i,j ,k-1)*h(i-1,j ,k-1)) ) + wSE = h4_u(I,j,K) + wNW = h4_u(I-1,j+1,K) + wNE = h4_u(I,j+1,K) + wSW = h4_u(I-1,j,K) + if (OBC_dir_v(i,J) == 1) then ! OBC_DIRECTION_N + wNW = 0.0 ; wNE = 0.0 + H_geom = sqrt( h(i,j,k) * h(i,j,k-1) ) + elseif (OBC_dir_v(i,J) == -1) then ! OBC_DIRECTION_S + wSW = 0.0 ; wSE = 0.0 + H_geom = sqrt( h(i,j+1,k) * h(i,j+1,k-1) ) + endif S2 = slope_y(i,J,K)**2 + & (((wSE*slope_x(I,j,K)**2) + (wNW*slope_x(I-1,j+1,K)**2)) + & ((wNE*slope_x(I,j+1,K)**2) + (wSW*slope_x(I-1,j,K)**2)) ) / & @@ -804,6 +948,8 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C if (CS%debug) then call uvchksum("calc_Visbeck_coeffs_old slope_[xy]", slope_x, slope_y, G%HI, & unscale=US%Z_to_L, haloshift=1) + ! call uvchksum("calc_Visbeck_coeffs_old S2_[uv]", S2_u, S2_v, G%HI, & + ! unscale=US%Z_to_L**2, scalar_pair=.true.) call uvchksum("calc_Visbeck_coeffs_old N2_u, N2_v", N2_u, N2_v, G%HI, & unscale=US%L_to_Z**2*US%s_to_T**2, scalar_pair=.true.) call uvchksum("calc_Visbeck_coeffs_old SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & @@ -1149,7 +1295,7 @@ subroutine calc_QG_slopes(h, tv, dt, G, GV, US, slope_x, slope_y, CS, OBC) call find_eta(h, tv, G, GV, US, e, halo_size=3) call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & - slope_x, slope_y, halo=2, OBC=OBC) + slope_x, slope_y, halo=2, OBC=OBC, OBC_N2=CS%OBC_friendly) end subroutine calc_QG_slopes @@ -1337,10 +1483,17 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! mode wave speed as the starting point for iterations. real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] - logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure + logical :: use_SQG ! This is true if the SQG structure will be used for any parameterizations. + logical :: om4_remap_via_sub_cells ! Use the OM4-era remap_via_sub_cells for calculating the EBT structure + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: mixing_coefs_OBC_bug ! If false, use only interior data for thickness weighting in + ! lateral mixing coefficient calculations and to calculate stratification + ! and other fields at open boundary condition faces. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. + integer :: number_of_OBC_segments integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1403,9 +1556,6 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, the SQG vertical structure is used for backscatter "//& "on the condition that BS_EBT_power=0", & default=.false.) - call get_param(param_file, mdl, "SQG_EXPO", CS%sqg_expo, & - "Nondimensional exponent coeffecient of the SQG mode "// & - "that is used for the vertical struture of diffusivities.", units="nondim", default=1.0) call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", CS%khth_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of thickness diffusivity.",& @@ -1471,6 +1621,16 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (Stanley_coeff < 0.0) call MOM_error(FATAL, & "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") endif + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", number_of_OBC_segments, & + default=0, do_not_log=.true.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "MIXING_COEFS_OBC_BUG", mixing_coefs_OBC_bug, & + "If false, use only interior data for thickness weighting in lateral mixing "//& + "coefficient calculations and to calculate stratification and other fields at "//& + "open boundary condition faces.", & + default=enable_bugs, do_not_log=(number_of_OBC_segments<=0)) + CS%OBC_friendly = .not. MIXING_COEFS_OBC_BUG if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & .or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) then @@ -1483,30 +1643,30 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif + use_SQG = CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct .or. & + CS%kdgl90_use_sqg_struct + call get_param(param_file, mdl, "SQG_EXPO", CS%sqg_expo, & + "Nondimensional exponent coeffecient of the SQG mode that is used for the "//& + "vertical struture of diffusivities.", & + units="nondim", default=1.0, do_not_log=.not.use_SQG) + call get_param(param_file, mdl, "INTERPOLATED_SQG_STRUCTURE", CS%interpolated_sqg_struct, & + "If true, interpolate properties to velocity points and then interpolate the "//& + "buoyancy frequencies and layer thicknesses back to tracer points when "//& + "calculating the SQG vertical structure.", & + default=.true., do_not_log=.not.use_SQG) + !### Consider changing the default for INTERPOLATED_SQG_STRUCTURE to false. - if (CS%BS_EBT_power>0. .and. CS%BS_use_sqg_struct) then - call MOM_error(FATAL, & - "calc_resoln_function: BS_EBT_POWER>0. & - & and BS_USE_SQG=True cannot be set together") - endif + if ((CS%BS_EBT_power>0.) .and. CS%BS_use_sqg_struct) call MOM_error(FATAL, & + "calc_resoln_function: BS_EBT_POWER>0. and BS_USE_SQG=True cannot be set together") - if (CS%khth_use_ebt_struct .and. CS%khth_use_sqg_struct) then - call MOM_error(FATAL, & - "calc_resoln_function: Only one of KHTH_USE_EBT_STRUCT & - & and KHTH_USE_SQG_STRUCT can be true") - endif + if (CS%khth_use_ebt_struct .and. CS%khth_use_sqg_struct) call MOM_error(FATAL, & + "calc_resoln_function: Only one of KHTH_USE_EBT_STRUCT and KHTH_USE_SQG_STRUCT can be true") - if (CS%khtr_use_ebt_struct .and. CS%khtr_use_sqg_struct) then - call MOM_error(FATAL, & - "calc_resoln_function: Only one of KHTR_USE_EBT_STRUCT & - & and KHTR_USE_SQG_STRUCT can be true") - endif + if (CS%khtr_use_ebt_struct .and. CS%khtr_use_sqg_struct) call MOM_error(FATAL, & + "calc_resoln_function: Only one of KHTR_USE_EBT_STRUCT and KHTR_USE_SQG_STRUCT can be true") - if (CS%kdgl90_use_ebt_struct .and. CS%kdgl90_use_sqg_struct) then - call MOM_error(FATAL, & - "calc_resoln_function: Only one of KD_GL90_USE_EBT_STRUCT & - & and KD_GL90_USE_SQG_STRUCT can be true") - endif + if (CS%kdgl90_use_ebt_struct .and. CS%kdgl90_use_sqg_struct) call MOM_error(FATAL, & + "calc_resoln_function: Only one of KD_GL90_USE_EBT_STRUCT and KD_GL90_USE_SQG_STRUCT can be true") if (CS%BS_EBT_power>0. .or. CS%BS_use_sqg_struct) then allocate(CS%BS_struct(isd:ied,jsd:jed,GV%ke), source=0.0) @@ -1536,7 +1696,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) endif endif - if (CS%use_stored_slopes .or. CS%sqg_expo>0.0) then + if (CS%use_stored_slopes .or. (CS%interpolated_sqg_struct .and. (CS%sqg_expo>0.0))) then ! CS%calculate_Eady_growth_rate=.true. in_use = .true. allocate(CS%slope_x(IsdB:IedB,jsd:jed,GV%ke+1), source=0.0) @@ -1860,12 +2020,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, include the beta term in the Leith nonlinear eddy viscosity.", & default=.true.) - ALLOC_(CS%Laplac3_const_u(IsdB:IedB,jsd:jed)) ; CS%Laplac3_const_u(:,:) = 0.0 - ALLOC_(CS%Laplac3_const_v(isd:ied,JsdB:JedB)) ; CS%Laplac3_const_v(:,:) = 0.0 - ALLOC_(CS%KH_u_QG(IsdB:IedB,jsd:jed,GV%ke)) ; CS%KH_u_QG(:,:,:) = 0.0 - ALLOC_(CS%KH_v_QG(isd:ied,JsdB:JedB,GV%ke)) ; CS%KH_v_QG(:,:,:) = 0.0 - ! register diagnostics + allocate(CS%Laplac3_const_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%Laplac3_const_v(isd:ied,JsdB:JedB), source=0.0) + allocate(CS%KH_u_QG(IsdB:IedB,jsd:jed,GV%ke), source=0.0) + allocate(CS%KH_v_QG(isd:ied,JsdB:JedB,GV%ke), source=0.0) + ! register diagnostics CS%id_KH_u_QG = register_diag_field('ocean_model', 'KH_u_QG', diag%axesCuL, Time, & 'Horizontal viscosity from Leith QG, at u-points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) CS%id_KH_v_QG = register_diag_field('ocean_model', 'KH_v_QG', diag%axesCvL, Time, & @@ -1897,61 +2057,47 @@ end subroutine VarMix_init subroutine VarMix_end(CS) type(VarMix_CS), intent(inout) :: CS - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & - .or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) deallocate(CS%ebt_struct) - if (allocated(CS%sqg_struct)) deallocate(CS%sqg_struct) - if (allocated(CS%BS_struct)) deallocate(CS%BS_struct) - if (CS%khth_use_ebt_struct .or. CS%khth_use_sqg_struct) deallocate(CS%khth_struct) - if (CS%khtr_use_ebt_struct .or. CS%khtr_use_sqg_struct) deallocate(CS%khtr_struct) - if (CS%kdgl90_use_ebt_struct .or. CS%kdgl90_use_sqg_struct) deallocate(CS%kdgl90_struct) - - if (CS%use_stored_slopes .or. CS%sqg_expo>0.0) then - deallocate(CS%slope_x) - deallocate(CS%slope_y) - endif + if (allocated(CS%ebt_struct)) deallocate(CS%ebt_struct) + if (allocated(CS%sqg_struct)) deallocate(CS%sqg_struct) + if (allocated(CS%BS_struct)) deallocate(CS%BS_struct) + if (allocated(CS%khth_struct)) deallocate(CS%khth_struct) + if (allocated(CS%khtr_struct)) deallocate(CS%khtr_struct) + if (allocated(CS%kdgl90_struct)) deallocate(CS%kdgl90_struct) - if (CS%calculate_Eady_growth_rate) then - deallocate(CS%SN_u) - deallocate(CS%SN_v) - endif + if (allocated(CS%slope_x)) deallocate(CS%slope_x) + if (allocated(CS%slope_y)) deallocate(CS%slope_y) + + if (allocated(CS%SN_u)) deallocate(CS%SN_u) + if (allocated(CS%SN_v)) deallocate(CS%SN_v) if (allocated(CS%L2u)) deallocate(CS%L2u) if (allocated(CS%L2v)) deallocate(CS%L2v) - if (CS%Resoln_scaling_used) then - deallocate(CS%Res_fn_h) - deallocate(CS%Res_fn_q) - deallocate(CS%Res_fn_u) - deallocate(CS%Res_fn_v) - deallocate(CS%beta_dx2_q) - deallocate(CS%beta_dx2_u) - deallocate(CS%beta_dx2_v) - deallocate(CS%f2_dx2_q) - deallocate(CS%f2_dx2_u) - deallocate(CS%f2_dx2_v) - endif + if (allocated(CS%Res_fn_h)) deallocate(CS%Res_fn_h) + if (allocated(CS%Res_fn_q)) deallocate(CS%Res_fn_q) + if (allocated(CS%Res_fn_u)) deallocate(CS%Res_fn_u) + if (allocated(CS%Res_fn_v)) deallocate(CS%Res_fn_v) + if (allocated(CS%beta_dx2_q)) deallocate(CS%beta_dx2_q) + if (allocated(CS%beta_dx2_u)) deallocate(CS%beta_dx2_u) + if (allocated(CS%beta_dx2_v)) deallocate(CS%beta_dx2_v) + if (allocated(CS%f2_dx2_q)) deallocate(CS%f2_dx2_q) + if (allocated(CS%f2_dx2_u)) deallocate(CS%f2_dx2_u) + if (allocated(CS%f2_dx2_v)) deallocate(CS%f2_dx2_v) - if (CS%Depth_scaled_KhTh) then - deallocate(CS%Depth_fn_u) - deallocate(CS%Depth_fn_v) - endif + if (allocated(CS%Depth_fn_u)) deallocate(CS%Depth_fn_u) + if (allocated(CS%Depth_fn_v)) deallocate(CS%Depth_fn_v) - if (CS%calculate_Rd_dx) then - deallocate(CS%Rd_dx_h) - deallocate(CS%beta_dx2_h) - deallocate(CS%f2_dx2_h) - endif + if (allocated(CS%Rd_dx_h)) deallocate(CS%Rd_dx_h) + if (allocated(CS%beta_dx2_h)) deallocate(CS%beta_dx2_h) + if (allocated(CS%f2_dx2_h)) deallocate(CS%f2_dx2_h) - if (CS%calculate_cg1) then - deallocate(CS%cg1) - endif + if (allocated(CS%cg1)) deallocate(CS%cg1) + + if (allocated(CS%Laplac3_const_u)) deallocate(CS%Laplac3_const_u) + if (allocated(CS%Laplac3_const_v)) deallocate(CS%Laplac3_const_v) + if (allocated(CS%KH_u_QG)) deallocate(CS%KH_u_QG) + if (allocated(CS%KH_v_QG)) deallocate(CS%KH_v_QG) - if (CS%Use_QG_Leith_GM) then - DEALLOC_(CS%Laplac3_const_u) - DEALLOC_(CS%Laplac3_const_v) - DEALLOC_(CS%KH_u_QG) - DEALLOC_(CS%KH_v_QG) - endif end subroutine VarMix_end !> \namespace mom_lateral_mixing_coeffs @@ -2027,7 +2173,7 @@ end subroutine VarMix_end !! \section section_vertical_structure_khth Vertical structure function for KhTh !! !! The thickness diffusivity can be prescribed a vertical distribution with the shape of the equivalent barotropic -!! velocity mode. The structure function is stored in the control structure for thie module (varmix_cs) but is +!! velocity mode. The structure function is stored in the control structure for this module (varmix_cs) but is !! calculated using subroutines in mom_wave_speed. !! !! | Symbol | Module parameter | diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index 5b2ba9bad1..045027f05c 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -1,18 +1,22 @@ module MOM_self_attr_load -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE -use MOM_domains, only : pass_var -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_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_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : find_col_mass +use MOM_io, only : MOM_infra_file, MOM_field, vardesc, slasher +use MOM_io, only : create_MOM_file, MOM_read_data, MOM_write_field, var_desc +use MOM_load_love_numbers, only : Love_Data +use MOM_restart, only : is_new_run, MOM_restart_CS use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse use MOM_spherical_harmonics, only : sht_CS, order2index, calc_lmax -use MOM_unit_scaling, only : unit_scale_type -use MOM_verticalGrid, only : verticalGrid_type +use MOM_string_functions, only : lowercase +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -39,8 +43,8 @@ module MOM_self_attr_load !< 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 :: pbot_ref(:,:) + !< Reference bottom pressure [R L2 T-2 ~> Pa] real, allocatable :: Love_scaling(:) !< Dimensional coefficients for harmonic SAL, which are functions of Love numbers !! [nondim] or [Z T2 L-2 R-1 ~> m Pa-1], depending on the value of use_ppa. @@ -79,7 +83,7 @@ subroutine calc_SAL(eta, eta_sal, G, CS, tmp_scale) 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) + bpa(i,j) = eta(i,j) - CS%pbot_ref(i,j) enddo ; enddo ; else ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 bpa(i,j) = eta(i,j) enddo ; enddo ; endif @@ -176,20 +180,30 @@ subroutine calc_love_scaling(rhoW, rhoE, grav, CS) end subroutine calc_love_scaling !> This subroutine initializes the self-attraction and loading control structure. -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 - +subroutine SAL_init(h, tv, G, GV, US, param_file, CS, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(SAL_CS), intent(inout) :: CS !< Self-attraction and loading control structure + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(MOM_restart_CS), optional, intent(in) :: restart_CS !< MOM restart control structure ! Local variables # include "version_variable.h" character(len=40) :: mdl = "MOM_self_attr_load" ! This module's name. integer :: lmax ! Total modes of the real spherical harmonics [nondim] real :: rhoE ! The average density of Earth [R ~> kg m-3]. - character(len=200) :: filename, ebot_ref_file, inputdir ! Strings for file/path - character(len=200) :: ebot_ref_varname ! Variable name in file + character(len=20) :: bpa_config ! String for reference bottom pressure config option + real :: tmp(G%isd:G%ied, G%jsd:G%jed) ! Temporary field storing mass returned by find_col_mass + ! [R Z ~> kg m-2] + logical :: restart_sim ! If true, this is a restart run + character(len=200) :: filename, ref_pbot_file, inputdir ! Strings for file/path + character(len=200) :: ref_pbot_varname ! Variable name in file + type(MOM_infra_file) :: IO_handle ! used to write ref_pbot file + type(vardesc) :: vars(1) ! used to write ref_pbot file + type(MOM_field) :: fields(1) ! used to write ref_pbot file logical :: calculate_sal, tides, use_tidal_sal_file integer :: tides_answer_date ! Recover old answers with tides real :: sal_scalar_value ! Scaling SAL factors [nondim] @@ -204,40 +218,62 @@ subroutine SAL_init(G, GV, US, param_file, CS) call get_param(param_file, '', "CALCULATE_SAL", calculate_sal, default=tides, do_not_log=.True.) if (.not. calculate_sal) return - if (tides) then - call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & - 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.) + "only accurate for uniform density fluid.", default=.False.) if (CS%use_bpa) then + allocate(CS%pbot_ref(isd:ied, jsd:jed), source=0.0) + call get_param(param_file, mdl, "SAL_REF_PBOT_CONFIG", bpa_config, default="file", & + do_not_log=.True.) + restart_sim = .False. ; if (present(restart_CS)) restart_sim = (.not. is_new_run(restart_CS)) + if (restart_sim .and. (trim(lowercase(bpa_config))/='file')) then + call MOM_error(WARNING, "SAL_init: 'file' is not used by SAL_PBOT_REF_CONFIG for a restart "//& + "run, SAL_PBOT_REF_CONFIG is reset to 'file'.") + bpa_config = 'file' + endif + call get_param(param_file, mdl, "SAL_REF_PBOT_CONFIG", bpa_config, & + "A string that determines how the reference bottom pressure for SAL "//& + "is specified:\n"//& + "\t init - calculated by thickness, temperature and salinity from \n"//& + "\t initialization and assuming surface pressure is zero.\n"//& + "\t This option can only be used by new simulations.\n"//& + "\t file - read from the file specified by REF_PBOT_FILE.", & + default="file", do_not_read=.True.) call get_param(param_file, '', "INPUTDIR", inputdir, default=".", do_not_log=.True.) - inputdir = slasher(inputdir) - call get_param(param_file, mdl, "REF_BOT_PRES_FILE", ebot_ref_file, & + call get_param(param_file, mdl, "REF_PBOT_FILE", ref_pbot_file, & "Reference bottom pressure file used by self-attraction and loading (SAL).", & default="pbot.nc") - call get_param(param_file, mdl, "REF_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) + call get_param(param_file, mdl, "REF_PBOT_VARNAME", ref_pbot_varname, & + "The name of the variable in REF_PBOT_FILE with reference bottom "//& + "pressure. The variable should have the unit of Pa.", default="pbot") + filename = trim(slasher(inputdir))//trim(ref_pbot_file) + call log_param(param_file, mdl, "INPUTDIR/REF_PBOT_FILE", filename) + select case (trim(lowercase(bpa_config))) + case ("file") + call MOM_read_data(filename, trim(ref_pbot_varname), CS%pbot_ref, G%Domain,& + scale=US%Pa_to_RL2_T2) + case ("init") + call find_col_mass(h, tv, G, GV, US, tmp, CS%pbot_ref) + ! Write reference bottom pressure file + vars(1) = var_desc(trim(ref_pbot_varname), units="Pa", & + longname="Reference bottom pressure", & + hor_grid='h', z_grid='1', t_grid='1') + call create_MOM_file(IO_handle, trim(filename), vars, 1, fields, G=G) + call MOM_write_field(IO_handle, fields(1), G%Domain, CS%pbot_ref, unscale=US%RL2_T2_to_Pa) + call IO_handle%close() + case default + call MOM_error(FATAL, "SAL_init: Unsupported SAL_PBOT_REF_CONFIG option "//trim(bpa_config)) + end select + call pass_var(CS%pbot_ref, G%Domain) endif + call get_param(param_file, '', "TIDES_ANSWER_DATE", tides_answer_date, default=20230630, & + do_not_log=.True.) ! used to check SAL_USE_BPA if (tides_answer_date<=20250131 .and. CS%use_bpa) & call MOM_error(FATAL, trim(mdl) // ", SAL_init: SAL_USE_BPA needs to be false to recover "//& "tide answers before 20250131.") + call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", use_tidal_sal_file, default=.false., & + do_not_log=.True.) ! used to set default of SAL_SCALAR_APPROX call get_param(param_file, mdl, "SAL_SCALAR_APPROX", CS%use_sal_scalar, & "If true, use the scalar approximation to calculate self-attraction and "//& "loading.", default=tides .and. (.not. use_tidal_sal_file)) @@ -250,6 +286,8 @@ subroutine SAL_init(G, GV, US, param_file, CS) "SAL_SCALAR_APPROX is true or USE_PREVIOUS_TIDES is true.", default=0.0, & units="m m-1", do_not_log=.not.(CS%use_sal_scalar .or. CS%use_tidal_sal_prev), & old_name='TIDE_SAL_SCALAR_VALUE') + call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & + default=.false., do_not_log=.True.) call get_param(param_file, mdl, "SAL_HARMONICS", CS%use_sal_sht, & "If true, use the online spherical harmonics method to calculate "//& "self-attraction and loading.", default=.false.) @@ -300,7 +338,7 @@ 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 (allocated(CS%pbot_ref)) deallocate(CS%pbot_ref) if (CS%use_sal_sht) then if (allocated(CS%Love_scaling)) deallocate(CS%Love_scaling) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index cf06be4ed2..cc21e20e00 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2193,6 +2193,8 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) ! as the vertical structure of thickness diffusivity. ! Used to determine if FULL_DEPTH_KHTH_MIN should be ! available. + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: use_meke = .false. ! If true, use the MEKE formulation for the thickness diffusivity. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. integer :: i, j @@ -2354,11 +2356,13 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "original implementation, while higher values use expressions that satisfy "//& "rotational symmetry.", & default=20240101, do_not_log=.not.CS%GM_src_alt) ! ### Change default to default_answer_date. + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "MEKE_GM_SRC_ALT_SLOPE_BUG", CS%MEKE_src_slope_bug, & "If true, use a bug that limits the positive values, but not the negative values, "//& "of the slopes used when MEKE_GM_SRC_ALT is true. When this is true, it breaks "//& "all of the symmetry rules that MOM6 is supposed to obey.", & - default=.true., do_not_log=.not.CS%GM_src_alt) ! ### Change default to False. + default=enable_bugs, do_not_log=.not.CS%GM_src_alt) call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & "If true, uses the GM coefficient formulation from the GEOMETRIC "//& diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index ddc34fdbaa..66f9dec0ea 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -65,12 +65,10 @@ module MOM_stochastics type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the ! Taper array to smoothly zero out the SKEBS velocity increment near land - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: taperCu !< Taper applied to u component of - !! stochastic velocity increment - !! range [0,1], [nondim] - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: taperCv !< Taper applied to v component of - !! stochastic velocity increment - !! range [0,1], [nondim] + real, allocatable :: taperCu(:,:) !< Taper applied to u component of stochastic + !! velocity increment range [0,1], [nondim] + real, allocatable :: taperCv(:,:) !< Taper applied to v component of stochastic + !! velocity increment range [0,1], [nondim] end type stochastic_CS @@ -204,8 +202,8 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) ! Initialize the "taper" fields. These fields multiply the components of the stochastic ! velocity increment in such a way as to smoothly taper them to zero at land boundaries. if ((CS%do_skeb) .or. (CS%id_skeb_taperu > 0) .or. (CS%id_skeb_taperv > 0)) then - ALLOC_(CS%taperCu(grid%IsdB:grid%IedB,grid%jsd:grid%jed)) - ALLOC_(CS%taperCv(grid%isd:grid%ied,grid%JsdB:grid%JedB)) + allocate(CS%taperCu(grid%IsdB:grid%IedB,grid%jsd:grid%jed)) + allocate(CS%taperCv(grid%isd:grid%ied,grid%JsdB:grid%JedB)) ! Initialize taper from land mask do j=grid%jsd,grid%jed ; do I=grid%isdB,grid%iedB CS%taperCu(I,j) = grid%mask2dCu(I,j) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index b6d4dfa489..8dc8edd2b9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -120,7 +120,6 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa]. integer, optional, intent(in) :: halo !< Halo width over which to calculate frazil - ! Local variables real, dimension(SZI_(G)) :: & fraz_col, & ! The accumulated heat requirement due to frazil [Q R Z ~> J m-2]. @@ -223,6 +222,9 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) tv%frazil(i,j) = tv%frazil(i,j) + fraz_col(i) enddo enddo + + tv%frazil_was_reset = .false. + call cpu_clock_end(id_clock_frazil) end subroutine make_frazil diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 95c1d3d265..63470312f3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -178,6 +178,9 @@ module MOM_diabatic_driver real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the !! average stratification at the base of the mixed layer [Z ~> m]. real :: MLD_En_vals(3) !< Energy values for energy mixed layer diagnostics [R Z3 T-2 ~> J m-2] + real :: BMLD_En_vals(3) !< Energy values for energy bottom mixed layer diagnostics [R Z3 T-2 ~> J m-2] + logical :: use_OM4_MLD_En_iter !< If true, uses an older iteration in the energetics MLD calculation to bitwise + !! reproduce OM4 era models real :: ref_h_mld = 0.0 !< The depth of the "surface" density used in a difference mixed based !! MLD calculation [Z ~> m]. logical :: Use_KdWork_diag = .false. !< Logical flag to indicate if any Kd_work diagnostics are on. @@ -193,6 +196,7 @@ module MOM_diabatic_driver integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 integer :: id_MLD_003_zr = -1, id_MLD_003_rr = -1 integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 + integer :: id_BMLD_EN1 = -1, id_BMLD_EN2 = -1, id_BMLD_EN3 = -1 ! These are handles to diagnostics that are only available in non-ALE layered mode. integer :: id_wd = -1 @@ -502,10 +506,15 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & ref_H_MLD=0.0, id_ref_z=-1, id_ref_rho=-1) endif if ((CS%id_MLD_EN1 > 0) .or. (CS%id_MLD_EN2 > 0) .or. (CS%id_MLD_EN3 > 0)) then - call diagnoseMLDbyEnergy((/CS%id_MLD_EN1, CS%id_MLD_EN2, CS%id_MLD_EN3/),& - h, tv, G, GV, US, CS%MLD_En_vals, CS%diag) + ! Surface Mixed Layer diagnostic + call diagnoseMLDbyEnergy((/CS%id_MLD_EN1, CS%id_MLD_EN2, CS%id_MLD_EN3/), h, tv, G, GV, US, CS%MLD_En_vals, & + (/1,nz/), CS%diag, OM4_iteration=CS%use_OM4_MLD_En_iter) + endif + if ((CS%id_BMLD_EN1 > 0) .or. (CS%id_BMLD_EN2 > 0) .or. (CS%id_BMLD_EN3 > 0)) then + ! Bottom Mixed Layer diagnostic + call diagnoseMLDbyEnergy((/CS%id_BMLD_EN1, CS%id_BMLD_EN2, CS%id_BMLD_EN3/), h, tv, G, GV, US, CS%BMLD_En_vals, & + (/nz,1/), CS%diag, OM4_iteration=.false.) endif - if (stoch_CS%do_sppt .and. stoch_CS%id_sppt_wts > 0) & call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) @@ -580,7 +589,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim U_star, & ! The friction velocity [Z T-1 ~> m s-1]. KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + SkinBuoyFlux, & ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + BBL_BuoyFlux ! 2d bottom buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL real, dimension(SZI_(G)) :: & p_i ,& ! Pressure at the interface [R L2 T-2 ~> Pa] @@ -644,7 +654,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, halo=CS%halo_TS_diff) + call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, BBL_BuoyFlux, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) @@ -896,7 +906,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim 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, visc, dt, Kd_ePBL, G, GV, US, & - CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, BBL_BuoyFlux, waves=waves) call energetic_PBL_get_MLD(CS%ePBL, BLD(:,:), G, US) ! If visc%MLD or visc%h_ML exist, copy ePBL's BLD into them with appropriate conversions. @@ -1292,7 +1302,8 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, U_star, & ! The friction velocity [Z T-1 ~> m s-1]. KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + SkinBuoyFlux, & ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + BBL_BuoyFlux ! 2d bottom buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL logical, dimension(SZI_(G)) :: & in_boundary ! True if there are no massive layers below, where massive is defined as @@ -1359,7 +1370,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, halo=CS%halo_TS_diff) + call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, BBL_buoyflux, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) @@ -1547,7 +1558,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, 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, visc, dt, Kd_ePBL, G, GV, US, & - CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, BBL_BuoyFlux, waves=waves) call energetic_PBL_get_MLD(CS%ePBL, BLD(:,:), G, US) ! If visc%MLD or visc%h_ML exist, copy ePBL's BLD into them with appropriate conversions. @@ -2928,7 +2939,6 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: ppt2mks ! Conversion factor from S to kg/kg [S-1 ~> ppt-1]. integer :: i, j, k, is, ie, js, je, nz logical :: do_saln_tend ! Calculate salinity-based tendency diagnostics @@ -2978,9 +2988,8 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, ! salt tendency if (CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then - ppt2mks = US%S_to_ppt*0.001 do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = h(i,j,k)*GV%H_to_RZ * ppt2mks * work_3d(i,j,k) + work_3d(i,j,k) = h(i,j,k) * work_3d(i,j,k) enddo ; enddo ; enddo if (CS%id_diabatic_diff_salt_tend > 0) then call post_data(CS%id_diabatic_diff_salt_tend, work_3d, CS%diag, alt_h=h) @@ -3023,7 +3032,6 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: ppt2mks ! Conversion factor from S to kg/kg [S-1 ~> ppt-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 @@ -3074,9 +3082,8 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, ! salt tendency if (CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then - ppt2mks = US%S_to_ppt*0.001 do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_RZ * ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) + work_3d(i,j,k) = Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) enddo ; enddo ; enddo if (CS%id_boundary_forcing_salt_tend > 0) then call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h=h_old) @@ -3478,6 +3485,29 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_MLD_EN3 = register_diag_field('ocean_model', 'MLD_EN3', diag%axesT1, Time, & 'Mixed layer depth for energy value set to '//trim(EN3)//' J/m2 (Energy set by 3rd MLD_EN_VALS)', & units='m', conversion=US%Z_to_m) + call get_param(param_file, mdl, "BMLD_EN_VALS", CS%BMLD_En_vals, & + "The energy values used to compute Bottom MLDs. If not set (or all set to 0.), the "//& + "default will overwrite to 25., 2500., 250000.", units='J/m2', & + defaults=(/25., 2500., 250000./), scale=US%W_m2_to_RZ3_T3*US%s_to_T) + write(EN1,'(F10.2)') CS%BMLD_En_vals(1)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN2,'(F10.2)') CS%BMLD_En_vals(2)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN3,'(F10.2)') CS%BMLD_En_vals(3)*US%RZ3_T3_to_W_m2*US%T_to_s + CS%id_BMLD_EN1 = register_diag_field('ocean_model', 'BMLD_EN1', diag%axesT1, Time, & + 'Bottom mixed layer depth for energy value set to '//trim(EN1)//' J/m2 (Energy set by 1st MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + CS%id_BMLD_EN2 = register_diag_field('ocean_model', 'BMLD_EN2', diag%axesT1, Time, & + 'Bottom mixed layer depth for energy value set to '//trim(EN2)//' J/m2 (Energy set by 2nd MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + CS%id_BMLD_EN3 = register_diag_field('ocean_model', 'BMLD_EN3', diag%axesT1, Time, & + 'Bottom mixed layer depth for energy value set to '//trim(EN3)//' J/m2 (Energy set by 3rd MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + if ((CS%id_MLD_EN1>0).or. (CS%id_MLD_EN2>0).or. (CS%id_MLD_EN3>0).or. & + (CS%id_BMLD_EN1>0).or.(CS%id_BMLD_EN2>0).or.(CS%id_BMLD_EN3>0)) then + call get_param(param_file, mdl, "USE_OM4_MLD_EN_ITER", CS%use_OM4_MLD_En_iter, & + "If true, uses an older set of iteration coefficients in computing the PE based "//& + "surface MLD to reproduce OM4 era models. False uses an updated (general) method.",& + default=.true.) + endif CS%id_subMLN2 = register_diag_field('ocean_model', 'subML_N2', diag%axesT1, Time, & 'Squared buoyancy frequency below mixed layer', units='s-2', conversion=US%s_to_T**2) CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & @@ -3587,7 +3617,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_salt_tend = register_diag_field('ocean_model', & 'diabatic_salt_tendency', diag%axesTL, Time, & 'Diabatic diffusion of salt tendency', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, cmor_field_name='osaltdiff', & + 'kg m-2 s-1', conversion=US%S_to_ppt*0.001*GV%H_to_RZ*US%RZ_T_to_kg_m2s, & + cmor_field_name='osaltdiff', & cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & 'due_to_parameterized_dianeutral_mixing', & cmor_long_name='Tendency of sea water salinity expressed as salt content '// & @@ -3614,7 +3645,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_salt_tend_2d = register_diag_field('ocean_model', & 'diabatic_salt_tendency_2d', diag%axesT1, Time, & 'Depth integrated diabatic diffusion salt tendency', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, cmor_field_name='osaltdiff_2d', & + 'kg m-2 s-1', conversion=US%S_to_ppt*0.001*GV%H_to_RZ*US%RZ_T_to_kg_m2s, & + cmor_field_name='osaltdiff_2d', & cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & 'due_to_parameterized_dianeutral_mixing_depth_integrated', & cmor_long_name='Tendency of sea water salinity expressed as salt content '// & @@ -3661,7 +3693,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_salt_tend = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency', diag%axesTL, Time, & - 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + 'Boundary forcing salt tendency', & + 'kg m-2 s-1', conversion=US%S_to_ppt*0.001*GV%H_to_RZ*US%RZ_T_to_kg_m2s, & v_extensive = .true.) if (CS%id_boundary_forcing_salt_tend > 0) then CS%boundary_forcing_tendency_diag = .true. @@ -3680,7 +3713,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_salt_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency_2d', diag%axesT1, Time, & 'Depth integrated boundary forcing of ocean salt', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + 'kg m-2 s-1', conversion=US%S_to_ppt*0.001*GV%H_to_RZ*US%RZ_T_to_kg_m2s) if (CS%id_boundary_forcing_salt_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index c94e1032fe..7a67cbb5a5 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -105,8 +105,8 @@ module MOM_energetic_PBL !mstar related options integer :: mstar_scheme !< An encoded integer to determine which formula is used to set mstar - logical :: MSTAR_FLATCAP=.true. !< Set false to use asymptotic mstar cap. - real :: mstar_cap !< Since MSTAR is restoring undissipated energy to mixing, + integer :: BBL_mstar_scheme !< An encoded integer to determine which formula is used to set mstar + real :: mstar_cap !< Since mstar is restoring undissipated energy to mixing, !! there must be a cap on how large it can be [nondim]. This !! is definitely a function of latitude (Ekman limit), !! but will be taken as constant for now. @@ -115,31 +115,32 @@ module MOM_energetic_PBL real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE decay scale [nondim]. !/ mstar_scheme == 0 - real :: fixed_mstar !< Mstar is the ratio of the friction velocity cubed to the TKE available to + real :: fixed_mstar !< mstar is the ratio of the friction velocity cubed to the TKE available to !! drive entrainment [nondim]. This quantity is the vertically !! integrated shear production minus the vertically integrated !! dissipation of TKE produced by shear. This value is used if the option !! for using a fixed mstar is used. + real :: BBL_fixed_mstar !< Similar to fixed_mstar, but for the bottom boundary layer !/ mstar_scheme == 2 - real :: C_EK = 0.17 !< MSTAR Coefficient in rotation limit for mstar_scheme=OM4 [nondim] - real :: MSTAR_COEF = 0.3 !< MSTAR coefficient in rotation/stabilizing balance for mstar_scheme=OM4 [nondim] + real :: C_Ek = 0.17 !< mstar Coefficient in rotation limit for EPBL_MSTAR_SCHEME=OM4 [nondim] + real :: mstar_coef = 0.3 !< mstar coefficient in rotation/stabilizing balance for EPBL_MSTAR_SCHEME=OM4 [nondim] !/ mstar_scheme == 3 - real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outer-most coefficient for fit) [nondim]. + real :: RH18_mstar_cN1 !< mstar_N coefficient 1 (outer-most coefficient for fit) [nondim]. !! Value of 0.275 in RH18. Increasing this !! coefficient increases mechanical mixing for all values of Hf/ust, !! but is most effective at low values (weakly developed OSBLs). - real :: RH18_mstar_cN2 !< MSTAR_N coefficient 2 (coefficient outside of exponential decay) [nondim]. - !! Value of 8.0 in RH18. Increasing this coefficient increases MSTAR + real :: RH18_mstar_cN2 !< mstar_N coefficient 2 (coefficient outside of exponential decay) [nondim]. + !! Value of 8.0 in RH18. Increasing this coefficient increases mstar !! for all values of HF/ust, with a consistent affect across !! a wide range of Hf/ust. - real :: RH18_mstar_cN3 !< MSTAR_N coefficient 3 (exponential decay coefficient) [nondim]. Value of + real :: RH18_mstar_cN3 !< mstar_N coefficient 3 (exponential decay coefficient) [nondim]. Value of !! -5.0 in RH18. Increasing this increases how quickly the value - !! of MSTAR decreases as Hf/ust increases. - real :: RH18_mstar_cS1 !< MSTAR_S coefficient for RH18 in stabilizing limit [nondim]. + !! of mstar decreases as Hf/ust increases. + real :: RH18_mstar_cS1 !< mstar_S coefficient for RH18 in stabilizing limit [nondim]. !! Value of 0.2 in RH18. - real :: RH18_mstar_cS2 !< MSTAR_S exponent for RH18 in stabilizing limit [nondim]. + real :: RH18_mstar_cS2 !< mstar_S exponent for RH18 in stabilizing limit [nondim]. !! Value of 0.4 in RH18. !/ Coefficient for shear/convective turbulence interaction @@ -147,21 +148,40 @@ module MOM_energetic_PBL !/ Langmuir turbulence related parameters logical :: Use_LT = .false. !< Flag for using LT in Energy calculation - integer :: LT_ENHANCE_FORM !< Integer for Enhancement functional form (various options) - real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancement [nondim] - real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement [nondim] - real :: LaC_MLDoEK !< Coefficient for Langmuir number modification based on the ratio of + integer :: LT_enhance_form !< Integer for Enhancement functional form (various options) + real :: LT_enhance_coef !< Coefficient in fit for Langmuir Enhancement [nondim] + real :: LT_enhance_exp !< Exponent in fit for Langmuir Enhancement [nondim] + real :: LaC_MLD_Ek !< Coefficient for Langmuir number modification based on the ratio of !! the mixed layer depth over the Ekman depth [nondim]. - real :: LaC_MLDoOB_stab !< Coefficient for Langmuir number modification based on the ratio of + real :: LaC_MLD_Ob_stab !< Coefficient for Langmuir number modification based on the ratio of !! the mixed layer depth over the Obukhov depth with stabilizing forcing [nondim]. - real :: LaC_EKoOB_stab !< Coefficient for Langmuir number modification based on the ratio of + real :: LaC_Ek_Ob_stab !< Coefficient for Langmuir number modification based on the ratio of !! the Ekman depth over the Obukhov depth with stabilizing forcing [nondim]. - real :: LaC_MLDoOB_un !< Coefficient for Langmuir number modification based on the ratio of + real :: LaC_MLD_Ob_un !< Coefficient for Langmuir number modification based on the ratio of !! the mixed layer depth over the Obukhov depth with destabilizing forcing [nondim]. - real :: LaC_EKoOB_un !< Coefficient for Langmuir number modification based on the ratio of + real :: LaC_Ek_Ob_un !< Coefficient for Langmuir number modification based on the ratio of !! the Ekman depth over the Obukhov depth with destabilizing forcing [nondim]. real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing [nondim]. + !/ Machine learned equation discovery model paramters + logical :: eqdisc !< Uses machine learned shape function + logical :: eqdisc_v0 !< Uses machine learned velocity scale + logical :: eqdisc_v0h !< Uses machine learned velocity scale that uses boundary layer depth as input + real :: v0_lower_cap !< Lower cap to prevent v0 from attaining anomlously low values [Z T-1 ~> m s-1] + real :: v0_upper_cap !< Upper cap to prevent v0 from attaining anomlously high values [Z T-1 ~> m s-1] + real :: f_lower !< Lower cap of |f| i.e. absolute of Coriolis parameter [T-1 ~> s-1] + !! Used only in get_eqdisc_v0 subroutine. Default is 0.1deg Lat + real :: bflux_lower_cap !< Lower cap for capping blfux [Z2 T-3 ~> m2 s-3] + real :: bflux_upper_cap !< Upper cap for capping blfux [Z2 T-3 ~> m2 s-3] + real :: sigma_max_lower_cap !< Lower cap to prevent sigma_max from attaining low values [nondim] + real :: sigma_max_upper_cap !< Upper cap to prevent sigma_max from attaining high values [nondim] + real :: Eh_upper_cap !< Upper cap to prevent Eh = hf/(u__*) from attaining high values [nondim] + real :: Lh_cap !< Cap to prevent Lh = h/Monin_Obukhov_depth from attaining beyond extreme values [nondim] + real, allocatable, dimension(:) :: shape_function !< shape function used in machine learned diffusivity [nondim] + !/ Coefficients used for Machine learned diffusivity + real :: ML_c(18) !< Array of non-dimensional constants used in machine learned (ML) diffusivity [nondim] + real :: shape_function_epsilon !< An small value of shape_function below the boundary layer depth [nondim] + !/ Bottom boundary layer mixing related options real :: ePBL_BBL_effic !< The efficiency of bottom boundary layer mixing via ePBL driven by !! the bottom drag dissipation of mean kinetic energy, times @@ -202,6 +222,9 @@ module MOM_energetic_PBL logical :: BBL_effic_bug !< If true, overestimate the efficiency of the non-tidal ePBL bottom boundary !! layer diffusivity by a factor of 1/sqrt(CDRAG), which is often a factor of !! about 18.3. + logical :: ePBL_BBL_use_mstar !< If true, use an mstar*ustar^3 paramaterization to get the TKE available + !! to drive mixing in the bottom boundary layer version of ePBL. Otherwise, + !! use the meanflow energy loss to bottom drag scaled by a constant efficiency. !/ Options for documenting differences from parameter choices integer :: options_diff !< If positive, this is a coded integer indicating a pair of @@ -239,27 +262,28 @@ module MOM_energetic_PBL !>@{ Diagnostic IDs integer :: id_ML_depth = -1, id_hML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1 + integer :: id_ustar_ePBL = -1, id_bflx_ePBL = -1 integer :: id_TKE_MKE = -1, id_TKE_conv = -1, id_TKE_forcing = -1 integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_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 + integer :: id_ustar_BBL = -1, id_bflx_BBL = -1, id_BBL_decay_scale = -1, id_BBL_depth = -1 + integer :: id_mstar_sfc = -1, id_mstar_BBL = -1, id_LA_mod = -1, id_LA = -1, id_mstar_LT = -1 ! The next options are used when passively diagnosing sensitivities from parameter choices integer :: id_opt_diff_Kd_ePBL = -1, id_opt_maxdiff_Kd_ePBL = -1, id_opt_diff_hML_depth = -1 !>@} end type energetic_PBL_CS -!>@{ Enumeration values for mstar_Scheme -integer, parameter :: Use_Fixed_MStar = 0 !< The value of mstar_scheme to use a constant mstar -integer, parameter :: MStar_from_Ekman = 2 !< The value of mstar_scheme to base mstar on the ratio +!>@{ Enumeration values for mstar_scheme +integer, parameter :: Use_Fixed_mstar = 0 !< The value of mstar_scheme to use a constant mstar +integer, parameter :: mstar_from_Ekman = 2 !< The value of mstar_scheme to base mstar on the ratio !! of the Ekman layer depth to the Obukhov depth -integer, parameter :: MStar_from_RH18 = 3 !< The value of mstar_scheme to base mstar of of RH18 -integer, parameter :: No_Langmuir = 0 !< The value of LT_ENHANCE_FORM not use Langmuir turbulence. -integer, parameter :: Langmuir_rescale = 2 !< The value of LT_ENHANCE_FORM to use a multiplicative +integer, parameter :: mstar_from_RH18 = 3 !< The value of mstar_scheme to base mstar of of RH18 +integer, parameter :: No_Langmuir = 0 !< The value of LT_enhance_form not use Langmuir turbulence. +integer, parameter :: Langmuir_rescale = 2 !< The value of LT_enhance_form to use a multiplicative !! rescaling of mstar to account for Langmuir turbulence. -integer, parameter :: Langmuir_add = 3 !< The value of LT_ENHANCE_FORM to add a contribution to +integer, parameter :: Langmuir_add = 3 !< The value of LT_enhance_form to add a contribution to !! mstar from Langmuir turbulence to other contributions. integer, parameter :: wT_from_cRoot_TKE = 0 !< Use a constant times the cube root of remaining TKE !! to calculate the turbulent velocity. @@ -287,6 +311,7 @@ module MOM_energetic_PBL real :: LA !< The value of the Langmuir number [nondim] real :: LAmod !< The modified Langmuir number by convection [nondim] real :: mstar !< The value of mstar used in ePBL [nondim] + real :: mstar_BBL !< The value of mstar used in ePBL BBL [nondim] real :: mstar_LT !< The portion of mstar due to Langmuir turbulence [nondim] integer :: OBL_its !< The number of iterations used to find a self-consistent surface boundary layer depth integer :: BBL_its !< The number of iterations used to find a self-consistent bottom boundary layer depth @@ -299,7 +324,7 @@ module MOM_energetic_PBL !! 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, visc, dt, Kd_int, G, GV, US, CS, & - stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, Waves ) + stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, BBL_buoy_flux, Waves ) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -337,6 +362,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: BBL_buoy_flux !< The bottom buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous @@ -354,7 +381,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, ! mixing. ! ! The key parameters for the mixed layer are found in the control structure. -! To use the classic constant mstar mixed layers choose MSTAR_SCHEME=CONSTANT. +! To use the classic constant mstar mixed layers choose EPBL_MSTAR_SCHEME=CONSTANT. ! The key parameters then include mstar, nstar, TKE_decay, and conv_decay. ! For the Oberhuber (1993) mixed layer,the values of these are: ! mstar = 1.25, nstar = 1, TKE_decay = 2.5, conv_decay = 0.5 @@ -408,6 +435,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, real :: mech_TKE ! The mechanically generated turbulent kinetic energy available for mixing over a ! timestep before the application of the efficiency in mstar [R Z3 T-2 ~> J m-2] real :: u_star_BBL ! The bottom boundary layer friction velocity [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: u_star_BBL_z_t ! The bottom boundary layer friction velocity converted to Z T-1 [Z T-1 ~> m s-1]. real :: BBL_TKE ! The mechanically generated turbulent kinetic energy available for bottom ! boundary layer mixing within a timestep [R Z3 T-2 ~> J m-2] real :: I_rho ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1] @@ -444,11 +472,13 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, ! 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_mstar_sfc, & ! mstar used in EPBL [nondim] + diag_mstar_BBL, & ! mstar used in EPBL BBL [nondim] + diag_mstar_LT, & ! mstar due to Langmuir turbulence [nondim] diag_LA, & ! Langmuir number [nondim] - diag_LA_MOD ! Modified Langmuir number [nondim] + diag_LA_mod, & ! Modified Langmuir number [nondim] + diag_ustar, & ! The surface boundary layer friction velocity [Z T-1 ~> m s-1] + diag_bflx ! The surface boundary layer buoyancy flux [Z2 T-3 ~> m2 s-3] ! The following variables are only used for diagnosing sensitivities to ePBL settings real, dimension(SZK_(GV)+1) :: & @@ -495,7 +525,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, 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)) + BBL_mixing = ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0) .or. CS%ePBL_BBL_use_mstar) ! Zero out diagnostics before accumulation. if (CS%TKE_diagnostics) then @@ -612,6 +642,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, mech_TKE = dt * GV%Rho0 * u_star**3 ! The line above is equivalent to: mech_TKE = dt * u_star * fluxes%tau_mag(i,j) endif + diag_ustar(i,j) = u_star if (allocated(tv%SpV_avg) .and. .not.GV%Boussinesq) then SpV_dt(1) = tv%SpV_avg(i,j,1) * I_dt @@ -665,20 +696,30 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, 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) + u_star_BBL = max(visc%ustar_BBL(i,j), CS%ustar_min*GV%Z_to_H) ! units are H T-1 + if (GV%Boussinesq) then + u_star_BBL_z_t = u_star_BBL*GV%H_to_Z else - BBL_TKE = CS%ePBL_BBL_effic * GV%H_to_RZ * dt * visc%BBL_meanKE_loss(i,j) + u_star_BBL_z_t = u_star_BBL*GV%H_to_RZ*tv%SpV_avg(i,j,1) 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) + if (CS%ePBL_BBL_use_mstar) then + BBL_TKE = dt * ((u_star_BBL*GV%H_to_RZ) * u_star_BBL_z_t**2) + else + if (CS%BBL_effic_bug) then + BBL_TKE = CS%ePBL_BBL_effic * GV%H_to_RZ * dt * visc%BBL_meanKE_loss_sqrtCd(i,j) + else + BBL_TKE = CS%ePBL_BBL_effic * GV%H_to_RZ * dt * visc%BBL_meanKE_loss(i,j) + endif + ! Add in tidal dissipation energy at the bottom, noting that fluxes%BBL_tidal_dis is + ! in [R Z L2 T-3 ~> W m-2], unlike visc%BBL_meanKE_loss. + if ((CS%ePBL_tidal_effic > 0.0) .and. associated(fluxes%BBL_tidal_dis)) & + BBL_TKE = BBL_TKE + CS%ePBL_tidal_effic * dt * fluxes%BBL_tidal_dis(i,j) + endif call ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, absf, dt, Kd, BBL_TKE, & - u_star_BBL, Kd_BBL, BBLD_io, mixvel_BBL, mixlen_BBL, GV, US, CS, eCD) + u_star_BBL, u_star_BBL_z_t, BBL_buoy_flux(i,j), Kd_BBL, BBLD_io, mixvel_BBL, mixlen_BBL, & + GV, US, CS, eCD) do K=1,nz+1 ; Kd(K) = Kd(K) + Kd_BBL(K) ; enddo if (CS%id_Kd_BBL > 0) then ; do K=1,nz+1 @@ -723,10 +764,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, 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_mstar_sfc > 0) diag_mstar_sfc(i,j) = eCD%mstar + if (CS%id_mstar_bbl > 0) diag_mstar_BBL(i,j) = eCD%mstar_BBL + if (CS%id_mstar_LT > 0) diag_mstar_lt(i,j) = eCD%mstar_LT if (CS%id_LA > 0) diag_LA(i,j) = eCD%LA - if (CS%id_LA_MOD > 0) diag_LA_mod(i,j) = eCD%LAmod + if (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) @@ -755,10 +797,13 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, if ((CS%ePBL_tidal_effic > 0.0) .and. associated(fluxes%BBL_tidal_dis)) & BBL_TKE = BBL_TKE + CS%ePBL_tidal_effic * dt * fluxes%BBL_tidal_dis(i,j) u_star_BBL = max(visc%ustar_BBL(i,j), CS%ustar_min*GV%Z_to_H) + u_star_BBL_z_t = u_star_bbl*GV%H_to_Z call ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, absf, dt, Kd, BBL_TKE, & - u_star_BBL, Kd_1, BLD_1, mixvel_BBL, mixlen_BBL, GV, US, CS_tmp1, eCD_tmp) + u_star_BBL, u_star_BBL_z_t, BBL_buoy_flux(i,j), Kd_1, BLD_1, mixvel_BBL, mixlen_BBL, & + GV, US, CS_tmp1, eCD_tmp) call ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, absf, dt, Kd, BBL_TKE, & - u_star_BBL, Kd_2, BLD_2, mixvel_BBL, mixlen_BBL, GV, US, CS_tmp2, eCD_tmp) + u_star_BBL, u_star_BBL_z_t, BBL_buoy_flux(i,j), Kd_2, BLD_2, mixvel_BBL, mixlen_BBL, & + GV, US, CS_tmp2, eCD_tmp) endif if (CS%id_opt_diff_Kd_ePBL > 0) then @@ -794,6 +839,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, endif if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_ustar_ePBL > 0) call post_data(CS%id_ustar_ePBL, diag_ustar, CS%diag) + if (CS%id_bflx_ePBL > 0) call post_data(CS%id_bflx_ePBL, buoy_flux, CS%diag) if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, diag_TKE_wind, CS%diag) if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, diag_TKE_MKE, CS%diag) @@ -806,7 +853,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, 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 (CS%id_mstar_sfc > 0) call post_data(CS%id_mstar_sfc, diag_mstar_sfc, CS%diag) if (BBL_mixing) then if (CS%id_Kd_BBL > 0) call post_data(CS%id_Kd_BBL, Kd_BBL_3d, CS%diag) if (CS%id_BBL_Mix_Length > 0) call post_data(CS%id_BBL_Mix_Length, BBL_Mix_Length, CS%diag) @@ -817,10 +864,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, if (CS%id_TKE_BBL_mixing > 0) call post_data(CS%id_TKE_BBL_mixing, diag_TKE_BBL_mixing, CS%diag) if (CS%id_TKE_BBL_decay > 0) call post_data(CS%id_TKE_BBL_decay, diag_TKE_BBL_decay, CS%diag) if (CS%id_BBL_depth > 0) call post_data(CS%id_BBL_depth, CS%BBL_depth, CS%diag) + if (CS%id_mstar_BBL > 0) call post_data(CS%id_mstar_BBL, diag_mstar_BBL, CS%diag) endif if (CS%id_LA > 0) call post_data(CS%id_LA, diag_LA, CS%diag) - if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, diag_LA_MOD, CS%diag) - if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, diag_mStar_LT, CS%diag) + if (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) @@ -1104,12 +1152,15 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, ! during this timestep for each layer [R Z3 T-2 ~> J m-2]. real, dimension(SZK_(GV)) :: nstar_k ! The fraction of conv_PErel that can be converted to mixing ! for each layer [nondim]. - real, dimension(SZK_(GV)) :: dT_expect !< Expected temperature changes [C ~> degC] - real, dimension(SZK_(GV)) :: dS_expect !< Expected salinity changes [S ~> ppt] + real, dimension(SZK_(GV)) :: dT_expect ! Expected temperature changes [C ~> degC] + real, dimension(SZK_(GV)) :: dS_expect ! Expected salinity changes [S ~> ppt] integer, dimension(SZK_(GV)) :: num_itts integer :: k, nz, itt, max_itt + ! variables for ML based diffusivity + real :: v0_ML_turb_vel_scale ! turbulence vel scale from ML in diffusivity [Z T-1 ~> m s-1] + nz = GV%ke debug = .false. ! Change this hard-coded value for debugging. @@ -1191,19 +1242,19 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, MLD_output = dz(1) sfc_connected = .true. - !/ Here we get MStar, which is the ratio of convective TKE driven mixing to UStar**3 + !/ 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, & + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, .false., & mstar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& mstar_LT=mstar_LT) else - call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, mstar_total) + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, .false., mstar_total) endif - !/ Apply MStar to get mech_TKE - if ((CS%answer_date < 20190101) .and. (CS%mstar_scheme==Use_Fixed_MStar)) then + !/ 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 @@ -1256,16 +1307,27 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, 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) * & + if (CS%eqdisc) then ! update Kd as per Machine Learning equation discovery + call kappa_eqdisc(MixLen_shape, CS, GV, h, absf, B_flux, u_star, MLD_guess) + else + 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) * & + 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 + enddo + endif + endif + + v0_ML_turb_vel_scale = 0.0 ! a variable that gets passed on to get_eqdisc_v0 & get_eqdisc_v0h + if (CS%eqdisc_v0) then + call get_eqdisc_v0(CS,absf,B_flux,u_star,v0_ML_turb_vel_scale) + elseif (CS%eqdisc_v0h) then + call get_eqdisc_v0h(CS,B_flux,u_star,MLD_guess,v0_ML_turb_vel_scale) endif Kd(1) = 0.0 ; Kddt_h(1) = 0.0 @@ -1485,6 +1547,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, if (.not.CS%Use_MLD_iteration) then Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) + elseif (CS%eqdisc) then ! ML-eqdisc line1/2 + Kd_guess0 = MixLen_shape(K) * v0_ML_turb_vel_scale * MLD_guess ! ML-eqdisc else Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) endif @@ -1558,6 +1622,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, ! instead of redoing the computation will change answers... Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) + elseif (CS%eqdisc) then ! ML-eqdisc line2/2 + Kd(K) = MixLen_shape(K) * v0_ML_turb_vel_scale * MLD_guess ! ML-eqdisc else Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) endif @@ -1824,11 +1890,11 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, 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 + ! 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 + ! 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. @@ -1887,7 +1953,8 @@ 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) + dt, Kd, BBL_TKE_in, u_star_BBL, u_star_BBL_z_t, b_flux_BBL, Kd_BBL, BBLD_io, mixvel_BBL, & + mixlen_BBL, GV, US, CS, eCD) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m]. @@ -1917,7 +1984,10 @@ subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, & !! 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] + !! in thickness flux units [H T-1 ~> m s-1 or kg m-2 s-1] + real, intent(in) :: u_star_BBL_z_t !< The bottom boundary layer friction velocity + !! converted to length flux units [Z T-1 ~> m s-1] + real, intent(in) :: b_flux_BBL !< The bottom boundary layer buoyancy flux real, dimension(SZK_(GV)+1), & intent(out) :: Kd_BBL !< The bottom boundary layer contribution to diffusivities !! at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. @@ -2092,6 +2162,7 @@ subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, & real :: Surface_Scale ! Surface decay scale for vstar [nondim] logical :: debug ! This is used as a hard-coded value for debugging. logical :: no_MKE_conversion ! If true, there is conversion of MKE to TKE in this routine. + real :: mstar_BBL !< the value of mstar for the bottom boundary layer [nondim] ! The following arrays are used only for debugging purposes. real :: dPE_debug ! An estimate of the potential energy change [R Z3 T-2 ~> J m-2] @@ -2115,7 +2186,8 @@ subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, & 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 + if (((CS%ePBL_BBL_effic <= 0.0) .and. (CS%ePBL_tidal_effic <= 0.0) .and. (.not.CS%ePBL_BBL_use_mstar)) & + .or. (BBL_TKE_in <= 0.0)) then ! There is no added bottom boundary layer mixing. BBLD_io = 0.0 Kd_BBL(:) = 0.0 @@ -2232,8 +2304,14 @@ subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, & BBLD_output = dz(nz) bot_connected = .true. - mech_BBL_TKE = BBL_TKE_in - + if (CS%ePBL_BBL_use_mstar) then + call find_mstar(CS, US, B_flux_BBL, u_star_BBL_z_t, BBLD_guess, absf, .true., mstar_BBL) + eCD%mstar_BBL = mstar_BBL + mech_BBL_TKE = mstar_BBL * BBL_TKE_in + else + mech_BBL_TKE = BBL_TKE_in + eCD%mstar_BBL = 0.0 + endif if (CS%TKE_diagnostics) then ! eCD%dTKE_BBL_MKE = 0.0 eCD%dTKE_BBL_mixing = 0.0 @@ -2667,12 +2745,256 @@ subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, & enddo ! Iteration loop for converged boundary layer thickness. eCD%BBL_its = min(BBL_it, CS%max_BBLD_its) - BBLD_io = BBLD_output endif end subroutine ePBL_BBL_column +!> Gives shape function that sets the vertical structure of OSBL diffusivity +!! as described in Sane et al. 2025 +subroutine kappa_eqdisc(shape_func, CS, GV, dz, absf, B_flux, u_star, MLD_guess) + + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + real, dimension(SZK_(GV)+1), intent(inout) :: shape_func !< shape function, [nondim] + real, intent(in) :: absf !< The absolute value of f [T-1 ~> s-1] + real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: B_Flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] + real, dimension(SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] + real, intent(in) :: MLD_guess !< Mixing Layer depth guessed/found for iteration [Z ~> m]. + real, dimension(SZK_(GV)+1) :: hz !< depth variable, only used in this routine [H ~> m] + + ! local variables for this subroutine + integer :: nz + integer :: K, n ! integers for looping + real :: Lh ! ((B_flux * h))/(u_star^3), boundary layer depth by M-O depth, [nondim] + real :: Eh ! ((h f)/u_star ), boundary layer depth by Ekman depth, [nondim] + real :: sm ! sigma_max: location of maximum of shape function in sigma coordinate [nondim] + real :: hbl ! Boundary layer depth, same as MLD_guess [Z ~> m] + real :: F ! function, used in asymptotic model for sm, Equation 7 in Sane et al. 2024 [nondim] + real :: F_Eh ! F multiplied by Eh [nondim] + real :: u_star_I ! inverse of u_star [Z-1 T ~> m-1 s] + + ! variables used for optimizing computations: + real :: sm_h ! sigma_max multiplied by boundary layer depth [Z ~> m] + real :: sm_h_I ! inverse of sm_h,[Z-1 ~> m-1] + real :: sm_h_I2 ! An inverse variable given by 1.0/(h - sm_h), [Z-1 ~> m-1] + real :: hz_n ! z depth to avoid calling hz multiple times [Z ~> m] + real :: z_minus_sm_h ! depth z minus \sigma_m * MLD_Guess [Z ~> m] + real :: z_minus_sm_h2 ! (depth z minus \sigma_m * MLD_Guess)^2 [Z2 ~> m2] + real :: z_minus_sm_h3 ! (depth z minus \sigma_m * MLD_Guess)^3 [Z3 ~> m3] + real :: h_minus_smh_I ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) [Z-1 ~> m-1] + real :: h_minus_smh_I2 ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) ^ 2 [Z-2 ~> m-2] + real :: h_minus_smh_I3 ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) ^ 3 [Z-3 ~> m-3] + real :: z_sm_h_I ! depth divided by (\sigma_m * MLD_Guess) [nondim] + real :: coef_c2 ! = 2.98 * h_minus_smh_I2 ! [Z-2 ~> m-2] + real :: coef_c3 ! = 2.98 * h_minus_smh_I2 ! [Z-3 ~> m-3] + + nz = SZK_(GV)+1 + hz(1) = 0.0 + do K=2,nz + hz(K) = hz(K-1) + dz(K-1) + end do + hbl = MLD_Guess ! hbl is boundary layer depth. + + u_star_I = 1.0/u_star + Lh = (-B_flux * hbl) * ((u_star_I * u_star_I) * u_star_I) ! Boundary layer depth divided by Monin-Obukhov depth + Eh = (hbl * absf) * u_star_I ! Boundary layer depth divided by Ekman depth + + ! B_flux given negative sign to follow convention used in Sane et al. 2023 + ! Lh < 0 --> surface stabilizing i.e. heating, and Lh > 0 --> surface destabilizing i.e. cooling + ! This capping does not matter because these equations have asymptotes. Not sensitive beyond the caps. + Eh = min(Eh, CS%Eh_upper_cap) ! capping p1 to less than 2.0. It is always >0.0. + Lh = min(max(Lh, -CS%Lh_cap), CS%Lh_cap) ! capping Lh between -8 and 8 + + ! Empirical model to predict sm: + ! F is Equation (6) in Sane et al. 2025, and needs to be computed before sigma_m: + ! \mathcal{F} = \frac{1}{c_3 + c_4 \cdot e^{-\left( \text{sgn}(B) \cdot {c_5} \cdot {{L_h}^3} \right)}} + c_6 + ! Equation (5) in Sane et al. 2025: + ! \sigma_{m} = \frac{1}{c_1 + \frac{c_2}{\mathcal{F} \cdot E_h}} + ! Note: Lh over here is ((Bh)/ustar^3), whereas in Sane et al. 2025, L_h = (((Bh)^{1/3})/(ustar)) + + F = (1.0/ ( CS%ML_c(3) + CS%ML_c(4) * exp(-CS%ML_c(5) * Lh) ) ) + CS%ML_c(6) + F_Eh = F * Eh + sm = F_Eh / (CS%ML_c(1)*F_Eh +CS%ML_c(2)) + sm = min(max(sm, CS%sigma_max_lower_cap), CS%sigma_max_upper_cap) ! makes sure 0.1 hbl) then + shape_func(n) = CS%shape_function_epsilon ! set an arbitrary low constant value below hbl, default 0.01 + endif + end do +end subroutine kappa_eqdisc + +!> Gives velocity scale (v_0) using equations that approximate neural network of Sane et al. 2023 +subroutine get_eqdisc_v0(CS, absf, B_flux, u_star, v0_dummy) + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] + real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: absf !< The absolute value of f [T-1 ~> s-1]. + real, intent(inout) :: v0_dummy !< velocity scale v0, local variable [Z T-1 ~> m s-1] + + ! local variables for this subroutine + real :: bflux_c ! capped bflux [Z2 T-3 ~> m2 s-3] + real :: absf_c ! capped absf [T-1 ~> s-1] + real :: root_b_f ! square root of (abs(B_flux) * Coriolis) [Z T-2 ~> m s-2] + real :: f_u2 ! Coriolis X ustar^2 [Z2 T-3 ~> m2 s-3] + real :: den ! denominator, units iof buuyancy flux [Z2 T-3 ~> m2 s-3] + real :: root_B_by_Omega ! sqrt( B / Omega ) [Z T-1 ~> m s-1] + real :: f_prime ! Coriolis divided by Earth's rotation [nondim] + real :: omega_I ! Inverse of the Earth's rotation rate, 1 divided by omega [T ~> s] + + if (B_flux <= CS%bflux_lower_cap) then + bflux_c = CS%bflux_lower_cap + elseif (B_flux >= CS%bflux_upper_cap) then + bflux_c = CS%bflux_upper_cap + else + bflux_c = B_flux + endif + + if (absf <= CS%f_lower) then ! + absf_c = CS%f_lower ! 0.1 deg Latitude, cap avoids zero coriolis, solution insensitive below 0.1 deg. + else + absf_c = absf + endif + + f_u2 = absf_c * (u_star * u_star) ! pre-computing + + ! setting v0_dummy here: + ! \lambda = (1/ustar) \sqrt(bflux_c/absf_c) + + if (bflux_c >= 0.0) then ! surface heating and neutral conditions + ! Equation 7 in Sane et al. 2025: + ! \frac{v_0}{u_*} = \frac{c_{7}}{\lambda + c_{8} + \frac{c_{9}^2}{\lambda + c_{9}} } + + root_b_f = sqrt( bflux_c * absf_c) + den = bflux_c + (CS%ML_c(8) + CS%ML_c(9)) * u_star * root_b_f + & + (CS%ML_c(8) * CS%ML_c(9) + CS%ML_c(9)**2) * f_u2 + v0_dummy = ( ( CS%ML_c(7)*( (u_star * root_b_f) + (CS%ML_c(9)*f_u2) ) ) * u_star) / den + + else ! surface cooling + ! Equation 8 in Sane et al. 2025: + ! \frac{v_0}{u_*}=\frac{c_{10} \cdot \lambda \cdot \sqrt{f'} }{1 + + ! \frac{(c_{11} e^{(-c_{12} \cdot f')} + c_{13}) }{\lambda ^2} } + c_{14} + + omega_I = 1.0 / CS%omega + f_prime = absf_c * omega_I ! Coriolis divided by Earth's rotation + root_B_by_Omega = sqrt( -bflux_c * omega_I ) + den = ( -bflux_c + CS%ML_c(11) * f_u2 * exp(-f_prime * CS%ML_c(12) ) ) + CS%ML_c(13)*f_u2 + v0_dummy = ( CS%ML_c(10) * (-bflux_c * root_B_by_Omega) / den ) + ( CS%ML_c(14) * u_star ) + + endif + + v0_dummy = min( max(v0_dummy, CS%v0_lower_cap), CS%v0_upper_cap ) + ! upper cap kept for safety, but has never hit this cap. + + ! v0_lower_cap has been set to 0.0001 as data below that values does not exist in the training + ! solution was tested for lower cap of 0.00001 and was found to be insensitive. + ! sensitivity arises when lower cap is 0.0. That is when diffusivity attains extremely low values and + ! they go near molecular diffusivity. Boundary layers might become "sub-grid" i.e. < 1 metre + ! some cause issues such as anomlous surface warming. + ! this needs further investigation, our choices are motivated by practicallity for now. +end subroutine get_eqdisc_v0 + +!> Gives velocity scale (v_0^h) using equations that with using boundary layer depth as one of its inputs +!! These equations are different than those set in get_eqdisc_v0 subroutine +subroutine get_eqdisc_v0h(CS, B_flux, u_star, MLD_guess, v0_dummy) + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] + real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: MLD_guess !< boundary layer depth guessed/found for iteration [Z ~> m] + + real, intent(inout) :: v0_dummy !< velocity scale v0, local variable [Z T-1 ~> m s-1] + + ! local variables for this subroutine + real :: bflux_c ! capped bflux [Z2 T-3 ~> m2 s-3] + real :: B_h, den ! Surface buoyancy flux multiplied by boundary layer depth, den is a denominator [Z3 T-3 ~> m3 s-3] + real :: B_h_power1by3 ! cuberoot of (Surface buoyancy flux multiplied by boundary layer depth) [Z T-1 ~> m s-1] + real :: u_star_2 ! u_star squared, [Z2 T-2 ~> m2 s-2] + real :: u_star_3 ! u_star cubed, [Z3 T-3 ~> m3 s-3] + + u_star_2 = u_star * u_star ! pre-multiplying to get ustar ^ 2 + u_star_3 = u_star_2 * u_star ! ustar ^ 3.0 + + if (B_flux <= CS%bflux_lower_cap) then + bflux_c = CS%bflux_lower_cap + elseif (B_flux >= CS%bflux_upper_cap) then + bflux_c = CS%bflux_upper_cap + else + bflux_c = B_flux + endif + + B_h = abs(bflux_c) * MLD_guess + B_h_power1by3 = cuberoot(B_h) + + ! setting v0_dummy here: + + if (bflux_c >= 0.0) then ! surface heating and neutral conditions + ! Equation 9 in Sane et al. 2025: + ! \frac{v_0^h}{u_*} = \frac{C_{14}}{ c_{15} L_h^3 + c_{16} L_h^2 + 1 } + + den = ( CS%ML_c(15) * B_h + CS%ML_c(16)* u_star*(B_h_power1by3*B_h_power1by3)) & + + (u_star*u_star_2) + v0_dummy = ( CS%ML_c(14) * (u_star_2 * u_star_2)) / den + + else + ! Equation 10 in Sane et al. 2025: + ! \frac{v_0^h}{u_*} = \frac{L_h}{c_{17} + \frac{c_{18}}{L_h ^2}} + c_{14} + den = CS%ML_c(17) * (B_h_power1by3*B_h_power1by3) + CS%ML_c(18) * u_star_2 + v0_dummy = (B_h / den ) + CS%ML_c(14) * u_star + endif + + v0_dummy = min( max(v0_dummy, CS%v0_lower_cap), CS%v0_upper_cap ) + ! upper cap kept for safety, but has never hit this cap. + + ! v0_lower_cap has been set to 0.0001 as data below that values does not exist in the training + ! solution was tested for lower cap of 0.00001 and was found to be insensitive. + ! sensitivity arises when lower cap is 0.0. That is when diffusivity attains extremely low values and + ! they go near molecular diffusivity. Boundary layers might become "sub-grid" i.e. < 1 metre + ! some cause issues such as anomlous surface warming. + ! this needs further investigation, our choices are motivated by practicallity for now. +end subroutine get_eqdisc_v0h + !> Determine a scaling factor that accounts for the exponential decay of turbulent kinetic energy !! from a boundary source and the assumption that an increase in the diffusivity at an interface !! causes a linearly increasing buoyancy flux going from 0 at the bottom to a peak at the interface, @@ -3193,103 +3515,115 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & end subroutine find_PE_chg_orig -!> This subroutine finds the Mstar value for ePBL +!> This subroutine finds the mstar value for ePBL subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, & - BLD, Abs_Coriolis, MStar, Langmuir_Number,& - MStar_LT, Convect_Langmuir_Number) + BLD, Abs_Coriolis, Is_BBL, mstar, & + Langmuir_Number, mstar_LT, Convect_Langmuir_Number) type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: UStar !< ustar including gustiness [Z T-1 ~> m s-1] real, intent(in) :: Abs_Coriolis !< absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] - real, intent(out) :: Mstar !< Output mstar (Mixing/ustar**3) [nondim] + logical, intent(in) :: Is_BBL !< Logcal flag to indicate if bottom boundary layer mode + real, intent(out) :: mstar !< Output mstar (Mixing/ustar**3) [nondim] real, optional, intent(in) :: Langmuir_Number !< Langmuir number [nondim] - real, optional, intent(out) :: MStar_LT !< Mstar increase due to Langmuir turbulence [nondim] + real, optional, intent(out) :: mstar_LT !< mstar increase due to Langmuir turbulence [nondim] real, optional, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] !/ Variables used in computing mstar real :: MSN_term ! Temporary terms [nondim] real :: MSCR_term1, MSCR_term2 ! Temporary terms [Z3 T-3 ~> m3 s-3] - real :: MStar_Conv_Red ! Adjustment made to mstar due to convection reducing mechanical mixing [nondim] - real :: MStar_S, MStar_N ! Mstar in (S)tabilizing/(N)ot-stabilizing buoyancy flux [nondim] + real :: mstar_Conv_Red ! Adjustment made to mstar due to convection reducing mechanical mixing [nondim] + real :: mstar_S, mstar_N ! mstar in (S)tabilizing/(N)ot-stabilizing buoyancy flux [nondim] + integer :: mstar_scheme ! Toggles between surface and bottom boundary layer mstar scheme from control structure !/ Integer options for how to find mstar !/ - if (CS%mstar_scheme == Use_Fixed_MStar) then - MStar = CS%Fixed_MStar + if (Is_BBL) then + mstar_scheme = CS%BBL_mstar_scheme + else + mstar_scheme = CS%mstar_scheme + endif + + if (mstar_scheme == Use_Fixed_mstar) then + if (Is_BBL) then + mstar = CS%BBL_Fixed_mstar + else + mstar = CS%Fixed_mstar + endif !/ 1. Get mstar - elseif (CS%mstar_scheme == MStar_from_Ekman) then + elseif (mstar_scheme == mstar_from_Ekman) then if (CS%answer_date < 20190101) then ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) - MStar_S = CS%MStar_coef*sqrt(max(0.0,Buoyancy_Flux) / UStar**2 / & + mstar_S = CS%mstar_coef*sqrt(max(0.0,Buoyancy_Flux) / UStar**2 / & (Abs_Coriolis + 1.e-10*US%T_to_s) ) ! The limit for rotation (Ekman length) limited mixing - MStar_N = CS%C_Ek * log( max( 1., UStar / (Abs_Coriolis + 1.e-10*US%T_to_s) / BLD ) ) + mstar_N = CS%C_Ek * log( max( 1., UStar / (Abs_Coriolis + 1.e-10*US%T_to_s) / BLD ) ) else ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) - MStar_S = CS%MSTAR_COEF*sqrt(max(0.0, Buoyancy_Flux) / (UStar**2 * max(Abs_Coriolis, 1.e-20*US%T_to_s))) + mstar_S = CS%mstar_coef*sqrt(max(0.0, Buoyancy_Flux) / (UStar**2 * max(Abs_Coriolis, 1.e-20*US%T_to_s))) ! The limit for rotation (Ekman length) limited mixing - MStar_N = 0.0 - if (UStar > Abs_Coriolis * BLD) Mstar_N = CS%C_EK * log(UStar / (Abs_Coriolis * BLD)) + mstar_N = 0.0 + if (UStar > Abs_Coriolis * BLD) mstar_N = CS%C_Ek * log(UStar / (Abs_Coriolis * BLD)) endif ! Here 1.25 is about .5/von Karman, which gives the Obukhov limit. - MStar = max(MStar_S, min(1.25, MStar_N)) - if (CS%MStar_Cap > 0.0) MStar = min( CS%MStar_Cap,MStar ) - elseif ( CS%mstar_scheme == MStar_from_RH18 ) then + mstar = max(mstar_S, min(1.25, mstar_N)) + if (CS%mstar_Cap > 0.0) mstar = min( CS%mstar_Cap,mstar ) + elseif ( mstar_scheme == mstar_from_RH18 ) then if (CS%answer_date < 20190101) then - MStar_N = CS%RH18_MStar_cn1 * ( 1.0 - 1.0 / ( 1. + CS%RH18_MStar_cn2 * & + mstar_N = CS%RH18_mstar_cn1 * ( 1.0 - 1.0 / ( 1. + CS%RH18_mstar_cn2 * & exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) ) ) else - MSN_term = CS%RH18_MStar_cn2 * exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) - MStar_N = (CS%RH18_MStar_cn1 * MSN_term) / ( 1. + MSN_term) + MSN_term = CS%RH18_mstar_cn2 * exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) + mstar_N = (CS%RH18_mstar_cn1 * MSN_term) / ( 1. + MSN_term) endif - MStar_S = CS%RH18_MStar_CS1 * ( max(0.0, Buoyancy_Flux)**2 * BLD / & + mstar_S = CS%RH18_mstar_CS1 * ( max(0.0, Buoyancy_Flux)**2 * BLD / & ( UStar**5 * max(Abs_Coriolis,1.e-20*US%T_to_s) ) )**CS%RH18_mstar_cs2 - MStar = MStar_N + MStar_S + mstar = mstar_N + mstar_S endif !/ 2. Adjust mstar to account for convective turbulence if (CS%answer_date < 20190101) then - MStar_Conv_Red = 1. - CS%MStar_Convect_coef * (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) / & + mstar_Conv_Red = 1. - CS%mstar_Convect_coef * (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) / & ( (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) + & - 2.0 *MStar * UStar**3 / BLD ) + 2.0 *mstar * UStar**3 / BLD ) else MSCR_term1 = -BLD * min(0.0, Buoyancy_Flux) - MSCR_term2 = 2.0*MStar * UStar**3 + MSCR_term2 = 2.0*mstar * UStar**3 if ( abs(MSCR_term2) > 0.0) then - MStar_Conv_Red = ((1.-CS%mstar_convect_coef) * MSCR_term1 + MSCR_term2) / (MSCR_term1 + MSCR_term2) + mstar_Conv_Red = ((1.-CS%mstar_convect_coef) * MSCR_term1 + MSCR_term2) / (MSCR_term1 + MSCR_term2) else - MStar_Conv_Red = 1.-CS%mstar_convect_coef + mstar_Conv_Red = 1.-CS%mstar_convect_coef endif endif !/3. Combine various mstar terms to get final value - MStar = MStar * MStar_Conv_Red + mstar = mstar * mstar_Conv_Red - if (present(Langmuir_Number)) then - call mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, MStar, & - MStar_LT, Convect_Langmuir_Number) + if ((.not.Is_BBL) .and. (present(Langmuir_Number))) then + call mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, mstar, & + mstar_LT, Convect_Langmuir_Number) endif -end subroutine Find_Mstar +end subroutine Find_mstar -!> This subroutine modifies the Mstar value if the Langmuir number is present -subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, & - Mstar, MStar_LT, Convect_Langmuir_Number) +!> This subroutine modifies the mstar value if the Langmuir number is present +subroutine mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, & + mstar, mstar_LT, Convect_Langmuir_Number) type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: Abs_Coriolis !< Absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: UStar !< Surface friction velocity with? gustiness [Z T-1 ~> m s-1] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] - real, intent(inout) :: Mstar !< Input/output mstar (Mixing/ustar**3) [nondim] + real, intent(inout) :: mstar !< Input/output mstar (Mixing/ustar**3) [nondim] real, intent(in) :: Langmuir_Number !< Langmuir number [nondim] - real, intent(out) :: MStar_LT !< Mstar increase due to Langmuir turbulence [nondim] + real, intent(out) :: mstar_LT !< mstar increase due to Langmuir turbulence [nondim] real, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] !/ @@ -3315,7 +3649,7 @@ subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langm ! Set default values for no Langmuir effects. enhance_mstar = 1.0 ; mstar_LT_add = 0.0 - if (CS%LT_Enhance_Form /= No_Langmuir) then + if (CS%LT_enhance_form /= No_Langmuir) then ! a. Get parameters for modified LA if (CS%answer_date < 20190101) then iL_Ekman = Abs_Coriolis / Ustar @@ -3349,24 +3683,24 @@ subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langm ! Assumes linear factors based on length scale ratios to adjust LA ! Note when these coefficients are set to 0 recovers simple LA. Convect_Langmuir_Number = Langmuir_Number * & - ( (1.0 + max(-0.5, CS%LaC_MLDoEK * MLD_Ekman)) + & - ((CS%LaC_EKoOB_stab * Ekman_Obukhov_stab + CS%LaC_EKoOB_un * Ekman_Obukhov_un) + & - (CS%LaC_MLDoOB_stab * MLD_Obukhov_stab + CS%LaC_MLDoOB_un * MLD_Obukhov_un)) ) + ( (1.0 + max(-0.5, CS%LaC_MLD_Ek * MLD_Ekman)) + & + ((CS%LaC_Ek_Ob_stab * Ekman_Obukhov_stab + CS%LaC_Ek_Ob_un * Ekman_Obukhov_un) + & + (CS%LaC_MLD_Ob_stab * MLD_Obukhov_stab + CS%LaC_MLD_Ob_un * MLD_Obukhov_un)) ) - if (CS%LT_Enhance_Form == Langmuir_rescale) then + if (CS%LT_enhance_form == Langmuir_rescale) then ! Enhancement is multiplied (added mst_lt set to 0) Enhance_mstar = min(CS%Max_Enhance_M, & - (1. + CS%LT_ENHANCE_COEF * Convect_Langmuir_Number**CS%LT_ENHANCE_EXP) ) - elseif (CS%LT_ENHANCE_Form == Langmuir_add) then + (1. + CS%LT_enhance_coef * Convect_Langmuir_Number**CS%LT_enhance_exp) ) + elseif (CS%LT_enhance_form == Langmuir_add) then ! or Enhancement is additive (multiplied enhance_m set to 1) - mstar_LT_add = CS%LT_ENHANCE_COEF * Convect_Langmuir_Number**CS%LT_ENHANCE_EXP + mstar_LT_add = CS%LT_enhance_coef * Convect_Langmuir_Number**CS%LT_enhance_exp endif endif mstar_LT = (enhance_mstar - 1.0)*mstar + mstar_LT_add ! Diagnose the full increase in mstar. mstar = mstar*enhance_mstar + mstar_LT_add -end subroutine Mstar_Langmuir +end subroutine mstar_Langmuir !> Copies the ePBL active mixed layer depth into MLD, in units of [Z ~> m] unless other units are specified. @@ -3406,12 +3740,15 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) # include "version_variable.h" character(len=40) :: mdl = "MOM_energetic_PBL" ! This module's name. character(len=20) :: tmpstr ! A string that is parsed for parameter settings + character(len=20) :: mstar_scheme ! A string that is parsed for mstar parameter settings character(len=20) :: vel_scale_str ! A string that is parsed for velocity scale parameter settings character(len=120) :: diff_text ! A clause describing parameter setting that differ. real :: omega_frac_dflt ! The default for omega_frac [nondim] integer :: isd, ied, jsd, jed integer :: mstar_mode, LT_enhance, wT_mode integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: use_omega logical :: no_BBL ! If true, EPBL_BBL_EFFIC < 0 and EPBL_BBL_TIDAL_EFFIC < 0, so ! bottom boundary layer mixing is not enabled. @@ -3489,8 +3826,9 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) default=.false., do_not_log=(CS%MKE_to_TKE_effic>0.0)) -!/2. Options related to setting MSTAR - call get_param(param_file, mdl, "EPBL_MSTAR_SCHEME", tmpstr, & +!/2. Options related to setting mstar + + call get_param(param_file, mdl, "EPBL_MSTAR_SCHEME", mstar_scheme, & "EPBL_MSTAR_SCHEME selects the method for setting mstar. Valid values are: \n"//& "\t CONSTANT - Use a fixed mstar given by MSTAR \n"//& "\t OM4 - Use L_Ekman/L_Obukhov in the stabilizing limit, as in OM4 \n"//& @@ -3498,87 +3836,115 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) default=CONSTANT_STRING, do_not_log=.true.) call get_param(param_file, mdl, "MSTAR_MODE", mstar_mode, default=-1) if (mstar_mode == 0) then - tmpstr = CONSTANT_STRING + mstar_scheme = CONSTANT_STRING call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = CONSTANT instead of the archaic MSTAR_MODE = 0.") elseif (mstar_mode == 1) then call MOM_error(FATAL, "You are using a legacy mstar mode in ePBL that has been phased out. "//& "If you need to use this setting please report this error. Also use "//& "EPBL_MSTAR_SCHEME to specify the scheme for mstar.") elseif (mstar_mode == 2) then - tmpstr = OM4_STRING + mstar_scheme = OM4_STRING call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = OM4 instead of the archaic MSTAR_MODE = 2.") elseif (mstar_mode == 3) then - tmpstr = RH18_STRING + mstar_scheme = RH18_STRING call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = REICHL_H18 instead of the archaic MSTAR_MODE = 3.") elseif (mstar_mode > 3) then call MOM_error(FATAL, "An unrecognized value of the obsolete parameter MSTAR_MODE was specified.") endif - call log_param(param_file, mdl, "EPBL_MSTAR_SCHEME", tmpstr, & + call log_param(param_file, mdl, "EPBL_MSTAR_SCHEME", mstar_scheme, & "EPBL_MSTAR_SCHEME selects the method for setting mstar. Valid values are: \n"//& "\t CONSTANT - Use a fixed mstar given by MSTAR \n"//& "\t OM4 - Use L_Ekman/L_Obukhov in the stabilizing limit, as in OM4 \n"//& "\t REICHL_H18 - Use the scheme documented in Reichl & Hallberg, 2018.", & default=CONSTANT_STRING) - tmpstr = uppercase(tmpstr) - select case (tmpstr) + mstar_scheme = uppercase(mstar_scheme) + select case (mstar_scheme) case (CONSTANT_STRING) - CS%mstar_Scheme = Use_Fixed_MStar + CS%mstar_scheme = Use_Fixed_mstar case (OM4_STRING) - CS%mstar_Scheme = MStar_from_Ekman + CS%mstar_scheme = mstar_from_Ekman case (RH18_STRING) - CS%mstar_Scheme = MStar_from_RH18 + CS%mstar_scheme = mstar_from_RH18 case default - call MOM_mesg('energetic_PBL_init: EPBL_MSTAR_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_mesg('energetic_PBL_init: EPBL_MSTAR_SCHEME ="'//trim(mstar_scheme)//'"', 0) call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & - "EPBL_MSTAR_SCHEME = "//trim(tmpstr)//" found in input file.") + "EPBL_MSTAR_SCHEME = "//trim(mstar_scheme)//" found in input file.") end select - call get_param(param_file, mdl, "MSTAR", CS%fixed_mstar, & "The ratio of the friction velocity cubed to the TKE input to the "//& - "mixed layer. This option is used if EPBL_MSTAR_SCHEME = CONSTANT.", & - units="nondim", default=1.2, do_not_log=(CS%mstar_scheme/=Use_Fixed_MStar)) + "surface boundary layer. This option is used if EPBL_MSTAR_SCHEME = CONSTANT.", & + units="nondim", default=1.2, do_not_log=(CS%mstar_scheme/=Use_Fixed_mstar)) + call get_param(param_file, mdl, "MSTAR_CAP", CS%mstar_cap, & "If this value is positive, it sets the maximum value of mstar "//& - "allowed in ePBL. (This is not used if EPBL_MSTAR_SCHEME = CONSTANT).", & - units="nondim", default=-1.0, do_not_log=(CS%mstar_scheme==Use_Fixed_MStar)) - ! mstar_scheme==MStar_from_Ekman options - call get_param(param_file, mdl, "MSTAR2_COEF1", CS%MSTAR_COEF, & + "allowed in ePBL. (This is not used if EPBL_mstar_scheme = CONSTANT).", & + units="nondim", default=-1.0, do_not_log=(CS%mstar_scheme==Use_Fixed_mstar)) + ! mstar_scheme==mstar_from_Ekman options + call get_param(param_file, mdl, "MSTAR2_COEF1", CS%mstar_coef, & "Coefficient in computing mstar when rotation and stabilizing "//& - "effects are both important (used if EPBL_MSTAR_SCHEME = OM4).", & - units="nondim", default=0.3, do_not_log=(CS%mstar_scheme/=MStar_from_Ekman)) - call get_param(param_file, mdl, "MSTAR2_COEF2", CS%C_EK, & + "effects are both important (used if EPBL_mstar_scheme = OM4).", & + units="nondim", default=0.3, do_not_log=(CS%mstar_scheme/=mstar_from_Ekman)) + call get_param(param_file, mdl, "MSTAR2_COEF2", CS%C_Ek, & "Coefficient in computing mstar when only rotation limits "// & "the total mixing (used if EPBL_MSTAR_SCHEME = OM4)", & - units="nondim", default=0.085, do_not_log=(CS%mstar_scheme/=MStar_from_Ekman)) - ! mstar_scheme==MStar_from_RH18 options + units="nondim", default=0.085, do_not_log=(CS%mstar_scheme/=mstar_from_Ekman)) + ! mstar_scheme==mstar_from_RH18 options call get_param(param_file, mdl, "RH18_MSTAR_CN1", CS%RH18_mstar_cn1,& "MSTAR_N coefficient 1 (outer-most coefficient for fit). "//& "The value of 0.275 is given in RH18. Increasing this "//& - "coefficient increases MSTAR for all values of Hf/ust, but more "//& + "coefficient increases mstar for all values of Hf/ust, but more "//& "effectively at low values (weakly developed OSBLs).", & - units="nondim", default=0.275, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + units="nondim", default=0.275, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) call get_param(param_file, mdl, "RH18_MSTAR_CN2", CS%RH18_mstar_cn2,& "MSTAR_N coefficient 2 (coefficient outside of exponential decay). "//& "The value of 8.0 is given in RH18. Increasing this coefficient "//& - "increases MSTAR for all values of HF/ust, with a much more even "//& + "increases mstar for all values of HF/ust, with a much more even "//& "effect across a wide range of Hf/ust than CN1.", & - units="nondim", default=8.0, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + units="nondim", default=8.0, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) call get_param(param_file, mdl, "RH18_MSTAR_CN3", CS%RH18_mstar_CN3,& "MSTAR_N coefficient 3 (exponential decay coefficient). "//& "The value of -5.0 is given in RH18. Increasing this increases how "//& - "quickly the value of MSTAR decreases as Hf/ust increases.", & - units="nondim", default=-5.0, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + "quickly the value of mstar decreases as Hf/ust increases.", & + units="nondim", default=-5.0, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) call get_param(param_file, mdl, "RH18_MSTAR_CS1", CS%RH18_mstar_cs1,& "MSTAR_S coefficient for RH18 in stabilizing limit. "//& "The value of 0.2 is given in RH18 and increasing it increases "//& - "MSTAR in the presence of a stabilizing surface buoyancy flux.", & - units="nondim", default=0.2, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + "mstar in the presence of a stabilizing surface buoyancy flux.", & + units="nondim", default=0.2, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) call get_param(param_file, mdl, "RH18_MSTAR_CS2", CS%RH18_mstar_cs2,& "MSTAR_S exponent for RH18 in stabilizing limit. "//& - "The value of 0.4 is given in RH18 and increasing it increases MSTAR "//& + "The value of 0.4 is given in RH18 and increasing it increases mstar "//& "exponentially in the presence of a stabilizing surface buoyancy flux.", & - Units="nondim", default=0.4, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) - + Units="nondim", default=0.4, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) +!/ BBL mstar related options + call get_param(param_file, mdl, "EPBL_BBL_USE_MSTAR", CS%ePBL_BBL_use_mstar, & + "A logical to use mstar in the calculation of TKE in the ePBL BBL scheme", & + units="nondim", default=.false.) + if (CS%ePBL_BBL_use_mstar) then + call get_param(param_file, mdl, "EPBL_BBL_MSTAR_SCHEME", tmpstr, & + "EPBL_BBL_MSTAR_SCHEME selects the method for setting mstar in the BBL. Valid values are: \n"//& + "\t CONSTANT - Use a fixed mstar given by MSTAR_BBL \n"//& + "\t OM4 - Use L_Ekman/L_Obukhov in the stabilizing limit, as in OM4 \n"//& + "\t REICHL_H18 - Use the scheme documented in Reichl & Hallberg, 2018.", & + default=mstar_scheme) + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (CONSTANT_STRING) + CS%BBL_mstar_scheme = Use_Fixed_mstar + case (OM4_STRING) + CS%BBL_mstar_scheme = mstar_from_Ekman + case (RH18_STRING) + CS%BBL_mstar_scheme = mstar_from_RH18 + case default + call MOM_mesg('energetic_PBL_init: EPBL_BBL_MSTAR_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & + "EPBL_BBL_MSTAR_SCHEME = "//trim(tmpstr)//" found in input file.") + end select + call get_param(param_file, mdl, "MSTAR_BBL", CS%BBL_fixed_mstar, & + "The ratio of the friction velocity cubed to the TKE input to the "//& + "bottom boundary layer. This option is used if EPBL_BBL_MSTAR_SCHEME = CONSTANT.", & + units="nondim", default=1.2, do_not_log=(CS%BBL_mstar_scheme/=Use_Fixed_mstar)) + endif !/ Convective turbulence related options call get_param(param_file, mdl, "NSTAR", CS%nstar, & @@ -3619,10 +3985,12 @@ 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, & + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "EPBL_MLD_ITER_BUG", CS%MLD_iter_bug, & "If true, use buggy logic that gives the wrong bounds for the next iteration "//& "when successive guesses increase by exactly EPBL_MLD_TOLERANCE.", & - default=.true., do_not_log=.not.CS%Use_MLD_iteration) ! The default should be changed to .false. + default=enable_bugs, do_not_log=.not.CS%Use_MLD_iteration) call get_param(param_file, mdl, "EPBL_MLD_MAX_ITS", CS%max_MLD_its, & "The maximum number of iterations that can be used to find a self-consistent "//& "mixed layer depth. If EPBL_MLD_BISECTION is true, the maximum number "//& @@ -3790,20 +4158,20 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "\t ADDITIVE - Add a Langmuir turbulence contribution to mstar to other contributions", & default=NONE_STRING, do_not_log=.true.) call get_param(param_file, mdl, "LT_ENHANCE", LT_enhance, default=-1) - if (LT_ENHANCE == 0) then + if (LT_enhance == 0) then tmpstr = NONE_STRING call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = NONE instead of the archaic LT_ENHANCE = 0.") - elseif (LT_ENHANCE == 1) then + elseif (LT_enhance == 1) then call MOM_error(FATAL, "You are using a legacy LT_ENHANCE mode in ePBL that has been phased out. "//& "If you need to use this setting please report this error. Also use "//& "EPBL_LANGMUIR_SCHEME to specify the scheme for mstar.") - elseif (LT_ENHANCE == 2) then + elseif (LT_enhance == 2) then tmpstr = RESCALED_STRING call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = RESCALE instead of the archaic LT_ENHANCE = 2.") - elseif (LT_ENHANCE == 3) then + elseif (LT_enhance == 3) then tmpstr = ADDITIVE_STRING call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = ADDITIVE instead of the archaic LT_ENHANCE = 3.") - elseif (LT_ENHANCE > 3) then + elseif (LT_enhance > 3) then call MOM_error(FATAL, "An unrecognized value of the obsolete parameter LT_ENHANCE was specified.") endif call log_param(param_file, mdl, "EPBL_LANGMUIR_SCHEME", tmpstr, & @@ -3827,34 +4195,112 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "EPBL_LANGMUIR_SCHEME = "//trim(tmpstr)//" found in input file.") end select - call get_param(param_file, mdl, "LT_ENHANCE_COEF", CS%LT_ENHANCE_COEF, & + call get_param(param_file, mdl, "LT_ENHANCE_COEF", CS%LT_enhance_coef, & "Coefficient for Langmuir enhancement of mstar", & units="nondim", default=0.447, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_ENHANCE_EXP", CS%LT_ENHANCE_EXP, & + call get_param(param_file, mdl, "LT_ENHANCE_EXP", CS%LT_enhance_exp, & "Exponent for Langmuir enhancement of mstar", & units="nondim", default=-1.33, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLDoEK, & + call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLD_Ek, & "Coefficient for modification of Langmuir number due to "//& "MLD approaching Ekman depth.", & units="nondim", default=-0.87, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLDoOB_stab, & + call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLD_Ob_stab, & "Coefficient for modification of Langmuir number due to "//& "MLD approaching stable Obukhov depth.", & units="nondim", default=0.0, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLDoOB_un, & + call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLD_Ob_un, & "Coefficient for modification of Langmuir number due to "//& "MLD approaching unstable Obukhov depth.", & units="nondim", default=0.0, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_EKoOB_stab, & + call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_Ek_Ob_stab, & "Coefficient for modification of Langmuir number due to "//& "ratio of Ekman to stable Obukhov depth.", & units="nondim", default=0.95, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_EKoOB_un, & + call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_Ek_Ob_un, & "Coefficient for modification of Langmuir number due to "//& "ratio of Ekman to unstable Obukhov depth.", & units="nondim", default=0.95, do_not_log=(CS%LT_enhance_form==No_Langmuir)) endif + !/Options related to Machine Learning Equation Discovery + ! Logial flags for using shape function from equation discovery - machine learning + ! EPBL_EQD_DIFFUSIVITY : EPBL + Equation Discovery Diffusivity parameters + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_SHAPE", CS%eqdisc, & + "Logical flag for activating ML equation for shape function "// & + "that uses forcing to change its structure.", & + units="nondim", default=.false.) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_VELOCITY", CS%eqdisc_v0, & + "Logical flag for activating ML equation discovery for velocity scale", & + units="nondim", default=.false.) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_VELOCITY_H", CS%eqdisc_v0h, & + "Logical flag for activating ML equation discovery for velocity scale with h as input", & + units="nondim", default=.false.) + + + ! sets a lower cap for abs_f (Coriolis parameter) required in equation for v_0. + ! Small value, solution not sensitive below 1 deg Latitute + ! Default value of 2.5384E-07 corresponds to 0.1 deg. + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_CORIOLIS_LOWER_CAP", CS%f_lower, & + "value of lower limit cap for v0, default is for 0.1 deg, insensitive below 1deg", & + units="s-1", default=2.5384E-07, scale=US%T_to_S, & + do_not_log=.not.CS%eqdisc_v0) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_V0_LOWER_CAP", CS%v0_lower_cap, & + "value of lower limit cap for Coriolis in v0", & + units="m s-1", default=0.0001, scale=US%m_to_Z*US%T_to_s, & + do_not_log=.not.(CS%eqdisc_v0.or.CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_V0_UPPER_CAP", CS%v0_upper_cap, & + "value of upper limit cap for Coriolis in v0", & + units="m s-1", default=0.1, scale=US%m_to_Z*US%T_to_s, & + do_not_log=.not.(CS%eqdisc_v0.or.CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_BFLUX_LOWER_CAP", CS%bflux_lower_cap, & + "value of lower limit cap for Bflux used in setting in v0", & + units="m2 s-3", default=-7.0E-07, scale=(US%m_to_L**2)*(US%T_to_s**3), & + do_not_log=.not.(CS%eqdisc_v0.or.CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_BFLUX_UPPER_CAP", CS%bflux_upper_cap, & + "value of upper limit cap for Bflux used in setting in v0", & + units="m2 s-3", default=7.0E-07, scale=(US%m_to_L**2)*(US%T_to_s**3), & + do_not_log=.not.(CS%eqdisc_v0.or.CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_SIGMA_MAX_LOWER_CAP", CS%sigma_max_lower_cap, & + "value of lower limit cap for sigma coordinate of maximum for diffusivity", & + units="nondim", default=0.1, do_not_log=.not.CS%eqdisc) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_SIGMA_MAX_UPPER_CAP", CS%sigma_max_upper_cap, & + "value of upper limit cap for sigma coordinate of maximum for diffusivity", & + units="nondim", default=0.7, do_not_log=.not.CS%eqdisc) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_EH_UPPER_CAP", CS%Eh_upper_cap, & + "value of upper limit cap for boundary layer depth by Ekman depth hf/u", & + units="nondim", default=2.0, do_not_log=.not.CS%eqdisc) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_LH_CAP", CS%Lh_cap, & + "value of upper limit cap for boundary layer depth by Monin-Obukhov depth hB/u^3", & + units="nondim", default=8.0, do_not_log=.not.CS%eqdisc) + + ! The coefficients used for machine learned diffusivity + ! c1 to c6 used for sigma_m, + ! 7 to 9 v_0 surface heating, 10 to 14 v_0 surface cooling (ML velocity scale without h as input) + ! 14, 15, & 16 for v_0h surface heating, 17, 18, & 14 for v_0h surface cooling (ML velocity scale with h as input) + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_COEFFS", CS%ML_c, & + "Coefficient used for ML diffusivity 1 to 18 ", units="nondim", & + defaults=(/1.7908 , 0.6904, 0.0712, 0.4380, 2.6821, 1.5845, 0.1550, 1.1120, 0.8616, 0.0984, & + 45.0, 2.8570, 3.290, 0.0785, 0.650, 0.0944, 6.0277, 15.7292 /), & + do_not_log=.not.(CS%eqdisc .or. CS%eqdisc_v0 .or. CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_SHAPE_FUNCTION_EPSILON", CS%shape_function_epsilon, & + "Constant value of OSBL shape function below the boundary layer", & + units="nondim", default=0.01, do_not_log=.not.CS%eqdisc) + + !/ options end for Machine Learning Equation Discovery + !/ Options for documenting differences from parameter choices call get_param(param_file, mdl, "EPBL_OPTIONS_DIFF", CS%options_diff, & "If positive, this is a coded integer indicating a pair of settings whose "//& @@ -3894,6 +4340,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) ! 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', units='m', conversion=US%Z_to_m) + CS%id_ustar_ePBL = register_diag_field('ocean_model', 'ePBL_ustar', diag%axesT1, & + Time, 'Surface friction in ePBL', units='m s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_bflx_ePBL = register_diag_field('ocean_model', 'ePBL_bflx', diag%axesT1, & + Time, 'Surface buoyancy flux in ePBL', units='m2 s-3', conversion=US%Z_to_m**2*US%s_to_T**3) CS%id_TKE_wind = register_diag_field('ocean_model', 'ePBL_TKE_wind', diag%axesT1, & Time, 'Wind-stirring source of mixed layer TKE', 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, & @@ -3913,9 +4363,9 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) 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.', 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, & + CS%id_mstar_sfc = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') - if ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0)) then + if ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0) .or. CS%ePBL_BBL_use_mstar) then CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_ePBL_BBL', diag%axesTi, & Time, 'ePBL bottom boundary layer diffusivity', units='m2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_BBL_Mix_Length = register_diag_field('ocean_model', 'BBL_Mixing_Length', diag%axesTi, & @@ -3936,13 +4386,15 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) CS%id_TKE_BBL_decay = register_diag_field('ocean_model', 'ePBL_BBL_TKE_decay', diag%axesT1, & Time, 'Energy decay sink of mixed layer TKE in the bottom boundary layer', & units='W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_mstar_BBL = register_diag_field('ocean_model', 'MSTAR_BBL', diag%axesT1, & + Time, 'Total BBL mstar that is used.', 'nondim') endif if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') CS%id_LA_mod = register_diag_field('ocean_model', 'LA_MOD', diag%axesT1, & Time, 'Modified Langmuir number.', 'nondim') - CS%id_MSTAR_LT = register_diag_field('ocean_model', 'MSTAR_LT', diag%axesT1, & + CS%id_mstar_LT = register_diag_field('ocean_model', 'MSTAR_LT', diag%axesT1, & Time, 'Increase in mstar due to Langmuir Turbulence.', 'nondim') endif @@ -3966,7 +4418,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) 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 + if ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0) .or. CS%ePBL_BBL_use_mstar) then CS%TKE_diagnostics = CS%TKE_diagnostics .or. & (max(CS%id_TKE_BBL, CS%id_TKE_BBL_mixing, CS%id_TKE_BBL_decay) > 0) endif @@ -3992,7 +4444,7 @@ subroutine energetic_PBL_end(CS) 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 + if ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0) .or. CS%ePBL_BBL_use_mstar) then call EFP_sum_across_PEs(CS%sum_its_BBL, 2) avg_its = EFP_to_real(CS%sum_its_BBL(1)) / EFP_to_real(CS%sum_its_BBL(2)) write (mesg,*) "Average ePBL BBL iterations = ", avg_its diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 3769721da1..ac12bcdb1b 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -13,7 +13,8 @@ module MOM_geothermal use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_specific_vol_derivs implicit none ; private @@ -39,7 +40,7 @@ module MOM_geothermal integer :: id_internal_heat_heat_tendency = -1 !< ID for diagnostic of heat tendency integer :: id_internal_heat_temp_tendency = -1 !< ID for diagnostic of temperature tendency integer :: id_internal_heat_h_tendency = -1 !< ID for diagnostic of thickness tendency - + integer :: id_geothermal_buoyancy_flux = -1 !< ID for diagnostic of bottom buoyancy flux end type geothermal_CS contains @@ -360,7 +361,7 @@ end subroutine geothermal_entraining !> Applies geothermal heating to the bottommost layers that occur within GEOTHERMAL_THICKNESS of !! the bottom, by simply heating the water in place. Any heat that can not be applied to the ocean !! is returned (WHERE)? -subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) +subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, BFlx_geothermal, halo) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -369,12 +370,19 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(geothermal_CS), intent(in) :: CS !< Geothermal heating control struct + real, dimension(SZI_(G), SZJ_(G)), intent(out) :: BFlx_geothermal !< Geothermal Buoyancy Flux [m2 s-3] integer, optional, intent(in) :: halo !< Halo width over which to work + ! Local variables real, dimension(SZI_(G)) :: & heat_rem, & ! remaining heat [H C ~> m degC or kg degC m-2] - h_geo_rem ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] + h_geo_rem, & ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] + bottom_pressure, & ! Hydrostatic pressure in bottom layer [R L2 T-2 ~> Pa] + dRhodT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRhodS, & ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpVdT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpVdS ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real :: Angstrom, H_neglect ! small thicknesses [H ~> m or kg m-2] real :: heat_here ! heating applied to the present layer [C H ~> degC m or degC kg m-2] @@ -386,8 +394,13 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) dTdt_diag ! Diagnostic of temperature tendency [C T-1 ~> degC s-1] which might be ! converted into a layer-integrated heat tendency [Q R Z T-1 ~> W m-2] real :: Idt ! inverse of the timestep [T-1 ~> s-1] + real :: H_to_Pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real :: I_Cp ! 1.0 / C_p [C Q-1 ~> kg degC J-1] + real :: I_Rho0Squared ! 1.0 / rho_0^2 (Boussinesq only) [ R-2 ~> kg2 m-6] logical :: do_any ! True if there is more to be done on the current j-row. logical :: calc_diags ! True if diagnostic tendencies are needed. + logical :: nonBous ! If true, do not make the Boussinesq approximation. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, isj, iej is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -399,10 +412,15 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) "Module must be initialized before it is used.") if (.not.CS%apply_geothermal) return + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) Irho_cp = 1.0 / (GV%H_to_RZ * tv%C_p) Angstrom = GV%Angstrom_H H_neglect = GV%H_subroundoff Idt = 1.0 / dt + H_to_pres = GV%H_to_RZ * GV%g_Earth + I_Cp = 1. /tv%C_p + if (.not.nonBous) I_Rho0squared = 1. / (GV%Rho0**2) + EOSdom(:) = EOS_domain(G%HI) if (.not.associated(tv%T)) call MOM_error(FATAL, "MOM geothermal_in_place: "//& "Geothermal heating can only be applied if T & S are state variables.") @@ -413,11 +431,37 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) ! Conditionals for tracking diagnostic depdendencies calc_diags = (CS%id_internal_heat_heat_tendency > 0) .or. (CS%id_internal_heat_temp_tendency > 0) + BFlx_geothermal(:,:) = 0.0 if (calc_diags) dTdt_diag(:,:,:) = 0.0 !$OMP parallel do default(shared) private(heat_rem,do_any,h_geo_rem,isj,iej,heat_here,dTemp) do j=js,je + bottom_pressure(:) = 0.0 + do k=1,nz ; do i=is,ie + bottom_pressure(i) = bottom_pressure(i) + H_to_pres * h(i,j,k) + enddo; enddo + if (nonBous) then + dSpVdT(:) = 0.0 + dSpVdS(:) = 0.0 + call calculate_specific_vol_derivs(tv%T(:,j,nz), tv%S(:,j,nz), bottom_pressure, dSpVdT, dSpVdS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + BFlx_geothermal(i,j) = ( (GV%g_Earth_Z_T2 * dSpVdT(i)) * (CS%geo_heat(i,j)*I_Cp) ) * G%mask2dT(i,j) + enddo + else + dRhodT(:) = 0.0 + dRhodS(:) = 0.0 + call calculate_density_derivs(tv%T(:,j,nz), tv%S(:,j,nz), bottom_pressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + BFlx_geothermal(i,j) = - ( (GV%g_Earth_Z_T2*I_Rho0squared) * ((I_Cp*dRhodT(i))*CS%geo_heat(i,j)) ) & + * G%mask2dT(i,j) + enddo + endif + + + ! Only work on columns that are being heated, and heat the near-bottom water. ! If there is not enough mass in the ocean, pass some of the heat up @@ -480,7 +524,9 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) enddo ; enddo ; enddo call post_data(CS%id_internal_heat_heat_tendency, dTdt_diag, CS%diag, alt_h=h) endif - + if (CS%id_geothermal_buoyancy_flux > 0) then + call post_data(CS%id_geothermal_buoyancy_flux, BFlx_geothermal, CS%diag) + endif ! do j=js,je ; do i=is,ie ! resid(i,j) = tv%internal_heat(i,j) - resid(i,j) - GV%H_to_RZ * & ! (G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp))) @@ -572,6 +618,10 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') if (id > 0) call post_data(id, CS%geo_heat, diag, .true.) + CS%id_geothermal_buoyancy_flux = register_diag_field('ocean_model', & + 'geo_bflx', diag%axesT1, Time, 'Geothermal buoyancy flux into ocean', & + 'm2 s-3', conversion=US%Z_to_m**2*US%s_to_T**3) + ! Diagnostic for tendencies due to internal heat (in 3d) CS%id_internal_heat_heat_tendency = register_diag_field('ocean_model', & 'internal_heat_heat_tendency', diag%axesTL, Time, & diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 53d6b36e4a..da2c261ad9 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -57,12 +57,12 @@ module MOM_kappa_shear real :: lz_rescale !< A coefficient to rescale the distance to the nearest !! solid boundary. This adjustment is to account for !! regions where 3 dimensional turbulence prevents the - !! growth of shear instabilies [nondim]. + !! growth of shear instabilities [nondim]. real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. real :: kappa_0 !< The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_seed !< A moderately large seed value of diapycnal diffusivity that !! is used as a starting turbulent diffusivity in the iterations - !! to findind an energetically constrained solution for the + !! to finding an energetically constrained solution for the !! shear-driven diffusivity [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_tol_err !< The fractional error in kappa that is tolerated [nondim]. @@ -77,7 +77,7 @@ module MOM_kappa_shear !! to estimate the time-averaged diffusivity. logical :: dKdQ_iteration_bug !< If true. use an older, dimensionally inconsistent estimate of !! the derivative of diffusivity with energy in the Newton's method - !! iteration. The bug causes undercorrections when dz > 1m. + !! iteration. The bug causes under-corrections when dz > 1m. logical :: KS_at_vertex !< If true, do the calculations of the shear-driven mixing !! at the cell vertices (i.e., the vorticity points). logical :: eliminate_massless !< If true, massless layers are merged with neighboring @@ -103,6 +103,10 @@ module MOM_kappa_shear !! are some massless layers. logical :: VS_viscosity_bug !< If true, use a bug in the calculation of the viscosity that sets !! it to zero for all vertices that are on a coastline. + logical :: vertex_shear_OBC_bug !< If false, use extra masking when interpolating thicknesses to velocity + !! points for setting up the shear velocities at vertices to avoid using + !! external thicknesses at open boundaries. When OBCs are not in use, + !! this parameter does not change answers, but true is more efficient. logical :: VS_GeometricMean !< If true use geometric averaging for Kd from vertices to tracer points logical :: VS_ThicknessMean !< If true use thickness weighting when averaging Kd from vertices to !! tracer points @@ -214,8 +218,8 @@ 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_init>0) .or. CS%debug) diag_N2_init(:,:,:) = 0.0 + if ((CS%id_S2_init>0) .or. CS%debug) diag_S2_init(:,:,:) = 0.0 if (CS%id_N2_mean>0) diag_N2_mean(:,:,:) = 0.0 if (CS%id_S2_mean>0) diag_S2_mean(:,:,:) = 0.0 @@ -340,10 +344,10 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & 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 + if ((CS%id_N2_init>0) .or. CS%debug) then ; do K=1,nz+1 diag_N2_init(i,j,K) = N2_init(K) enddo ; endif - if (CS%id_S2_init>0) then ; do K=1,nz+1 + if ((CS%id_S2_init>0) .or. CS%debug) then ; do K=1,nz+1 diag_S2_init(i,j,K) = S2_init(K) enddo ; endif else @@ -360,16 +364,16 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & 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)) + if ((CS%id_N2_init>0) .or. CS%debug) diag_N2_init(i,j,K) = N2_init(kc(K)) + if ((CS%id_S2_init>0) .or. CS%debug) diag_S2_init(i,j,K) = S2_init(kc(K)) else if (CS%id_N2_mean>0) & diag_N2_mean(i,j,K) = (1.0-kf(K)) * N2_mean(kc(K)) + kf(K) * N2_mean(kc(K)+1) if (CS%id_S2_mean>0) & diag_S2_mean(i,j,K) = (1.0-kf(K)) * S2_mean(kc(K)) + kf(K) * S2_mean(kc(K)+1) - if (CS%id_N2_init>0) & + if ((CS%id_N2_init>0) .or. CS%debug) & diag_N2_init(i,j,K) = (1.0-kf(K)) * N2_init(kc(K)) + kf(K) * N2_init(kc(K)+1) - if (CS%id_S2_init>0) & + if ((CS%id_S2_init>0) .or. CS%debug) & diag_S2_init(i,j,K) = (1.0-kf(K)) * S2_init(kc(K)) + kf(K) * S2_init(kc(K)+1) endif enddo @@ -391,6 +395,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & enddo ! end of j-loop if (CS%debug) then + call hchksum(diag_N2_init, "kappa_shear N2_init", G%HI, unscale=US%s_to_T**2) + call hchksum(diag_S2_init, "kappa_shear S2_init", G%HI, unscale=US%s_to_T**2) call hchksum(kappa_io, "kappa", G%HI, unscale=GV%HZ_T_to_m2_s) call hchksum(tke_io, "tke", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif @@ -453,8 +459,12 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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),SZJB_(G),SZK_(GV)) :: & + h_vert ! Thicknesses interpolated to vertices [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + h_at_u ! A mask-weighted thickness interpolated to u-points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + h_at_v ! A mask-weighted thickness interpolated to v-points [H ~> m or kg m-2] real, dimension(SZIB_(G),SZK_(GV)) :: & h_2d, & ! A 2-D version of h interpolated to vertices [H ~> m or kg m-2]. dz_2d, & ! Vertical distance between interface heights [Z ~> m]. @@ -500,16 +510,18 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ real, dimension(SZK_(GV)+1) :: kf ! The fractional weight of interface kc+1 for ! interpolating back to the original index space [nondim]. 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 + real :: mks_to_HZ_T ! A factor used to restore dimensional scaling after the geometric mean ! diffusivity is taken using thickness weighted powers [H Z s m-2 T-1 ~> 1] ! or [H Z m s kg-1 T-1 ~> 1] + real :: H_tiny ! A sub-roundoff thickness to use in the denominator when calculating + ! thickness-weighted averages [H ~> m or kg m-2] integer :: IsB, IeB, JsB, JeB, i, j, k, nz, nzc ! Diagnostics that should be deleted? isB = G%isc-1 ; ieB = G%iecB ; jsB = G%jsc-1 ; jeB = G%jecB ; nz = GV%ke - if (CS%id_N2_init>0) diag_N2_init(:,:,:) = 0.0 - if (CS%id_S2_init>0) diag_S2_init(:,:,:) = 0.0 + if ((CS%id_N2_init>0) .or. CS%debug) diag_N2_init(:,:,:) = 0.0 + if ((CS%id_S2_init>0) .or. CS%debug) diag_S2_init(:,:,:) = 0.0 if (CS%id_N2_mean>0) diag_N2_mean(:,:,:) = 0.0 if (CS%id_S2_mean>0) diag_S2_mean(:,:,:) = 0.0 kappa_vertex(:,:,:) = 0.0 @@ -519,10 +531,39 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ k0dt = dt*CS%kappa_0 dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb + H_tiny = 0.5 * GV%H_subroundoff ! Convert layer thicknesses into geometric thickness in height units. call thickness_to_dz(h, tv, dz_3d, G, GV, US, halo_size=1) + if (CS%vertex_shear_OBC_bug) then + !$OMP parallel do default(shared) + do k=1,nz + do j=JsB,JeB+1 ; do I=IsB,IeB + h_at_u(I,j,k) = G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k)) * 0.5 + enddo ; enddo + do J=JsB,JeB ; do i=IsB,IeB+1 + h_at_v(i,J,k) = G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k)) * 0.5 + enddo ; enddo + enddo + else + ! Because G%mask2dCu(I,j) is zero if either G%mask2dT(i,j) or G%mask2dT(i+1,j) except at OBC + ! faces, the following form give equivalent answers to those above unless OBCs are in use, + ! although the former is clearly less complicated and costly. + !$OMP parallel do default(shared) + do k=1,nz + do j=JsB,JeB+1 ; do I=IsB,IeB + h_at_u(I,j,k) = G%mask2dCu(I,j) * (G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j) * h(i+1,j,k)) / & + (G%mask2dT(i,j) + G%mask2dT(i+1,j) + 1.0e-36) + enddo ; enddo + do J=JsB,JeB ; do i=IsB,IeB+1 + h_at_v(i,J,k) = G%mask2dCv(i,J) * (G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) / & + (G%mask2dT(i,j) + G%mask2dT(i,j+1) + 1.0e-36) + enddo ; enddo + enddo + endif + + !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,tv,G,GV,US,CS,kappa_io, & !$OMP dz_massless,k0dt,p_surf,dt,tke_io,kv_io,kappa_vertex,h_vert,I_Prandtl, & !$OMP diag_N2_init,diag_S2_init,diag_N2_mean,diag_S2_mean) @@ -530,14 +571,11 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ! Interpolate the various quantities to the corners, using masks. do k=1,nz ; do I=IsB,IeB - u_2d(I,k) = (G%mask2dCu(I,j) * (u_in(I,j,k) * (h(i,j,k) + h(i+1,j,k))) + & - G%mask2dCu(I,j+1) * (u_in(I,j+1,k) * (h(i,j+1,k) + h(i+1,j+1,k))) ) / & - ((G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k)) + & - G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) + GV%H_subroundoff) - v_2d(I,k) = (G%mask2dCv(i,J) * (v_in(i,J,k) * (h(i,j,k) + h(i,j+1,k))) + & - G%mask2dCv(i+1,J) * (v_in(i+1,J,k) * (h(i+1,j,k) + h(i+1,j+1,k))) ) / & - ((G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k)) + & - G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) + GV%H_subroundoff) + u_2d(I,k) = ( (u_in(I,j,k) * h_at_u(I,j,k)) + (u_in(I,j+1,k) * h_at_u(I,j+1,k)) ) / & + ( (h_at_u(I,j,k) + h_at_u(I,j+1,k)) + H_tiny ) + v_2d(I,k) = ( (v_in(i,J,k) * h_at_v(i,J,k)) + (v_in(i+1,J,k) * h_at_v(i+1,J,k)) ) / & + ( (h_at_v(i,J,k) + h_at_v(i+1,J,k)) + H_tiny ) + I_hwt = 1.0 / (((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k))) + & GV%H_subroundoff) @@ -668,22 +706,22 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do K=1,nz+1 kappa_2d(I,K) = kappa_avg(K) if (CS%all_layer_TKE_bug) then - tke_2d(i,K) = tke(K) + tke_2d(I,K) = tke(K) else - tke_2d(i,K) = tke_avg(K) + tke_2d(I,K) = tke_avg(K) endif enddo if (CS%id_N2_mean>0) then ; do K=1,nz+1 - diag_N2_mean(i,j,K) = N2_mean(K) + 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) + 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) + if ((CS%id_N2_init>0) .or. CS%debug) then ; do K=1,nz+1 + diag_N2_init(I,J,K) = N2_init(K) enddo ; endif - if (CS%id_S2_init>0) then ; do K=1,nz+1 - diag_S2_init(i,j,K) = S2_init(K) + if ((CS%id_S2_init>0) .or. CS%debug) then ; do K=1,nz+1 + diag_S2_init(I,J,K) = S2_init(K) enddo ; endif else do K=1,nz+1 @@ -699,16 +737,16 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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)) + if ((CS%id_N2_init>0) .or. CS%debug) diag_N2_init(I,J,K) = N2_init(kc(K)) + if ((CS%id_S2_init>0) .or. CS%debug) diag_S2_init(I,J,K) = S2_init(kc(K)) else if (CS%id_N2_mean>0) & diag_N2_mean(I,J,K) = (1.0-kf(K)) * N2_mean(kc(K)) + kf(K) * N2_mean(kc(K)+1) if (CS%id_S2_mean>0) & diag_S2_mean(I,J,K) = (1.0-kf(K)) * S2_mean(kc(K)) + kf(K) * S2_mean(kc(K)+1) - if (CS%id_N2_init>0) & + if ((CS%id_N2_init>0) .or. CS%debug) & diag_N2_init(I,J,K) = (1.0-kf(K)) * N2_init(kc(K)) + kf(K) * N2_init(kc(K)+1) - if (CS%id_S2_init>0) & + if ((CS%id_S2_init>0) .or. CS%debug) & diag_S2_init(I,J,K) = (1.0-kf(K)) * S2_init(kc(K)) + kf(K) * S2_init(kc(K)+1) endif enddo @@ -749,40 +787,45 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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 + if (CS%VS_ThicknessMean .and. CS%VS_GeometricMean) then + ! This conversion factor is required to allow for arbitrary fractional powers of the diffusivities. + mks_to_HZ_T = 1.0 / GV%HZ_T_to_MKS !$OMP parallel do default(private) shared(nz,G,GV,CS,kappa_io,kappa_vertex,h_vert) do K=2,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec h_SW = 0.5 * (h_vert(I-1,J-1,k) + h_vert(I-1,J-1,k-1)) h_NE = 0.5 * (h_vert(I,J,k) + h_vert(I,J,k-1)) h_NW = 0.5 * (h_vert(I-1,J,k) + h_vert(I-1,J,k-1)) h_SE = 0.5 * (h_vert(I,J-1,k) + h_vert(I,J-1,k-1)) - if (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 + 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 - ! 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 + ! If all points have zero thickness, the thickness-weighted geometric mean is undefined, so use + ! the non-thickness weighted geometric mean instead. + kappa_io(i,j,K) = G%mask2dT(i,j) * sqrt(sqrt( & + (max(kappa_vertex(I-1,J-1,K),CS%VS_GeoMean_Kdmin) * max(kappa_vertex(I,J,K),CS%VS_GeoMean_Kdmin)) * & + (max(kappa_vertex(I-1,J,K),CS%VS_GeoMean_Kdmin) * max(kappa_vertex(I,J-1,K),CS%VS_GeoMean_Kdmin)) )) endif enddo ; enddo ; enddo + elseif (CS%VS_ThicknessMean) then ! Use thickness-weighted arithmetic mean diffusivities. + !$OMP parallel do default(private) shared(nz,G,GV,CS,kappa_io,kappa_vertex,h_vert) + do K=2,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + h_SW = 0.5 * (h_vert(I-1,J-1,k) + h_vert(I-1,J-1,k-1)) + h_NE = 0.5 * (h_vert(I,J,k) + h_vert(I,J,k-1)) + h_NW = 0.5 * (h_vert(I-1,J,k) + h_vert(I-1,J,k-1)) + h_SE = 0.5 * (h_vert(I,J-1,k) + h_vert(I,J-1,k-1)) + ! The following expression is a thickness weighted arithmetic mean at tracer points: + I_htot = 1.0 / (((h_SW + h_NE) + (h_NW + h_SE)) + GV%H_subroundoff) + kappa_io(i,j,K) = G%mask2dT(i,j) * & + (((kappa_vertex(I-1,J-1,K)*h_SW) + (kappa_vertex(I,J,K)*h_NE)) + & + ((kappa_vertex(I-1,J,K)*h_NW) + (kappa_vertex(I,J-1,K)*h_SE))) * I_htot + enddo ; enddo ; enddo elseif (CS%VS_GeometricMean) then ! The geometic mean diffusivities are not thickness weighted. !$OMP parallel do default(private) shared(nz,G,CS,kappa_io,kappa_vertex) do K=2,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -800,6 +843,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ endif if (CS%debug) then + call Bchksum(diag_N2_init, "shear_vertex N2_init", G%HI, unscale=US%s_to_T**2) + call Bchksum(diag_S2_init, "shear_vertex S2_init", G%HI, unscale=US%s_to_T**2) call hchksum(kappa_io, "kappa", G%HI, unscale=GV%HZ_T_to_m2_s) call Bchksum(tke_io, "tke", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif @@ -1341,7 +1386,7 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int real, dimension(nz), intent(in) :: S0 !< The initial salinity [S ~> ppt]. real, intent(in) :: dt !< The time step [T ~> s]. real, dimension(nz), intent(in) :: dz !< The layer thicknesses [H ~> m or kg m-2] - real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the distance between succesive + real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the distance between successive !! layer centers [Z-1 ~> m-1]. real, dimension(nz+1), intent(in) :: dbuoy_dT !< The partial derivative of buoyancy with !! temperature [Z T-2 C-1 ~> m s-2 degC-1]. @@ -2040,7 +2085,10 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) ! for setting the default of KD_SMOOTH [Z2 T-1 ~> m2 s-1] real :: kappa_0_default ! The default value for KD_KAPPA_SHEAR_0 [Z2 T-1 ~> m2 s-1] logical :: merge_mixedlayer + integer :: number_of_OBC_segments logical :: debug_shear + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: just_read ! If true, this module is not used, so only read the parameters. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -2075,10 +2123,22 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "If true, do the calculations of the shear-driven mixing "//& "at the cell vertices (i.e., the vorticity points).", & default=.false., do_not_log=just_read) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "VERTEX_SHEAR_VISCOSITY_BUG", CS%VS_viscosity_bug, & "If true, use a bug in vertex shear that zeros out viscosities at "//& "vertices on coastlines.", & - default=.true., do_not_log=just_read.or.(.not.CS%KS_at_vertex)) + default=enable_bugs, do_not_log=just_read.or.(.not.CS%KS_at_vertex)) + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", number_of_OBC_segments, & + default=0, do_not_log=.true.) + call get_param(param_file, mdl, "VERTEX_SHEAR_OBC_BUG", CS%vertex_shear_OBC_bug, & + "If false, use extra masking when interpolating thicknesses to velocity "//& + "points for setting up the shear velocities at vertices to avoid using "//& + "external thicknesses at open boundaries. When OBCs are not in use, "//& + "this parameter does not change answers, but true is more efficient.", & + default=enable_bugs, & + do_not_log=just_read.or.(.not.CS%KS_at_vertex).or.(number_of_OBC_segments<=0)) + ! Use OBC settings to set the default for VERTEX_SHEAR_OBC_BUG? call get_param(param_file, mdl, "VERTEX_SHEAR_GEOMETRIC_MEAN", CS%VS_GeometricMean, & "If true, use a geometric mean for moving diffusivity from "//& "vertices to tracer points. False uses algebraic mean.", & @@ -2092,7 +2152,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) 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) + 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.", & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 67e57c7cdf..c87a99ba44 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -82,6 +82,8 @@ module MOM_set_diffusivity !! and those those used for TKE [Z2 L-2 ~> nondim]. real :: ePBL_BBL_effic !< efficiency with which the energy extracted !! by bottom drag drives BBL diffusion in the ePBL BBL scheme [nondim] + logical :: ePBL_BBL_mstar !< logical if the bottom boundary layer uses an mstar x ustar^3 formulation + !! needed here to know whether or not to populate the bottom ustar real :: cdrag !< quadratic drag coefficient [nondim] real :: dz_BBL_avg_min !< A minimal distance over which to average to determine the average !! bottom boundary layer density [Z ~> m] @@ -631,19 +633,19 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i 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) + VBF%Kd_leak(i,j,K) = min(Kd_leak_2d(i,K), CS%Kd_max) enddo ; enddo ; endif if (associated (VBF%Kd_quad)) then ; do K=1,nz+1 ; do i=is,ie - VBF%Kd_quad(i,j,K) = Kd_quad_2d(i,K) + VBF%Kd_quad(i,j,K) = min(Kd_quad_2d(i,K), CS%Kd_max) enddo ; enddo ; endif if (associated (VBF%Kd_itidal)) then ; do K=1,nz+1 ; do i=is,ie - VBF%Kd_itidal(i,j,K) = Kd_itidal_2d(i,K) + VBF%Kd_itidal(i,j,K) = min(Kd_itidal_2d(i,K), CS%Kd_max) enddo ; enddo ; endif if (associated (VBF%Kd_Froude)) then ; do K=1,nz+1 ; do i=is,ie - VBF%Kd_Froude(i,j,K) = Kd_Froude_2d(i,K) + VBF%Kd_Froude(i,j,K) = min(Kd_Froude_2d(i,K), CS%Kd_max) enddo ; enddo ; endif if (associated (VBF%Kd_slope)) then ; do K=1,nz+1 ; do i=is,ie - VBF%Kd_slope(i,j,K) = Kd_slope_2d(i,K) + VBF%Kd_slope(i,j,K) = min(Kd_slope_2d(i,K), CS%Kd_max) enddo ; enddo ; endif if (CS%id_prof_leak > 0) then ; do k=1,nz; do i=is,ie @@ -2002,7 +2004,8 @@ 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 .and. CS%ePBL_BBL_effic<=0.0)) then + if (.not.CS%bottomdraglaw .or. (CS%BBL_effic<=0.0 .and. CS%ePBL_BBL_effic<=0.0 .and. & + (.not.CS%ePBL_BBL_mstar))) then if (allocated(visc%ustar_BBL)) then do j=js,je ; do i=is,ie ; visc%ustar_BBL(i,j) = 0.0 ; enddo ; enddo endif @@ -2042,15 +2045,13 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) ! Determine if grid point is an OBC has_obc = .false. if (local_open_v_BC) then - l_seg = OBC%segnum_v(i,J) - if (l_seg /= OBC_NONE) then - has_obc = OBC%segment(l_seg)%open - endif + l_seg = abs(OBC%segnum_v(i,J)) + if (l_seg /= 0) has_obc = OBC%segment(l_seg)%open endif ! Compute h based on OBC state if (has_obc) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N hvel = dz(i,j,k) else hvel = dz(i,j+1,k) @@ -2094,15 +2095,13 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) ! Determine if grid point is an OBC has_obc = .false. if (local_open_u_BC) then - l_seg = OBC%segnum_u(I,j) - if (l_seg /= OBC_NONE) then - has_obc = OBC%segment(l_seg)%open - endif + l_seg = abs(OBC%segnum_u(I,j)) + if (l_seg /= 0) has_obc = OBC%segment(l_seg)%open endif ! Compute h based on OBC state if (has_obc) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E hvel = dz(i,j,k) else ! OBC_DIRECTION_W hvel = dz(i+1,j,k) @@ -2430,7 +2429,9 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "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.) + units="nondim", default=0.0, do_not_log=.true.) + call get_param(param_file, mdl, "EPBL_BBL_USE_MSTAR", CS%ePBL_BBL_mstar, & + default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BBL_MIXING_MAX_DECAY", decay_length, & "The maximum decay scale for the BBL diffusion, or 0 to allow the mixing "//& "to penetrate as far as stratification and rotation permit. The default "//& diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 70292380e7..6466b71dd5 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -306,6 +306,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) logical :: use_BBL_EOS, do_i(SZIB_(G)) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml + integer :: is_OBC, ie_OBC, js_OBC, je_OBC type(ocean_OBC_type), pointer :: OBC => NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -374,22 +375,42 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) mask_u(I,j) = G%mask2dCu(I,j) enddo ; enddo - if (associated(OBC)) then ; do n=1,OBC%number_of_segments - if (.not. OBC%segment(n)%on_pe) cycle + if (associated(OBC)) then ! Use a one-sided projection of bottom depths at OBC points. - I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB - if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= je)) then - do i = max(is-1,OBC%segment(n)%HI%isd), min(ie+1,OBC%segment(n)%HI%ied) - if (OBC%segment(n)%direction == OBC_DIRECTION_N) D_v(i,J) = G%bathyT(i,j) + G%Z_ref - if (OBC%segment(n)%direction == OBC_DIRECTION_S) D_v(i,J) = G%bathyT(i,j+1) + G%Z_ref - enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= ie)) then - do j = max(js-1,OBC%segment(n)%HI%jsd), min(je+1,OBC%segment(n)%HI%jed) - if (OBC%segment(n)%direction == OBC_DIRECTION_E) D_u(I,j) = G%bathyT(i,j) + G%Z_ref - if (OBC%segment(n)%direction == OBC_DIRECTION_W) D_u(I,j) = G%bathyT(i+1,j) + G%Z_ref - enddo + if (OBC%v_N_OBCs_on_PE) then + Js_OBC = max(js-1, OBC%Js_v_N_obc) ; Je_OBC = min(je, OBC%Je_v_N_obc) + is_OBC = max(is-1, OBC%is_v_N_obc) ; ie_OBC = min(ie+1, OBC%ie_v_N_obc) + !$OMP parallel do default(shared) + do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC + if (OBC%segnum_v(i,J) > 0) D_v(i,J) = G%bathyT(i,j) + G%Z_ref ! OBC_DIRECTION_N + enddo ; enddo endif - enddo ; endif + if (OBC%v_S_OBCs_on_PE) then + Js_OBC = max(js-1, OBC%Js_v_S_obc) ; Je_OBC = min(je, OBC%Je_v_S_obc) + is_OBC = max(is-1, OBC%is_v_S_obc) ; ie_OBC = min(ie+1, OBC%ie_v_S_obc) + !$OMP parallel do default(shared) + do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC + if (OBC%segnum_v(i,J) < 0) D_v(i,J) = G%bathyT(i,j+1) + G%Z_ref ! OBC_DIRECTION_S + enddo ; enddo + endif + if (OBC%u_E_OBCs_on_PE) then + js_OBC = max(js-1, OBC%js_u_E_obc) ; je_OBC = min(je+1, OBC%je_u_E_obc) + Is_OBC = max(is-1, OBC%Is_u_E_obc) ; Ie_OBC = min(ie, OBC%Ie_u_E_obc) + !$OMP parallel do default(shared) + do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC + if (OBC%segnum_u(I,j) > 0) D_u(I,j) = G%bathyT(i,j) + G%Z_ref ! OBC_DIRECTION_E + enddo ; enddo + endif + if (OBC%u_W_OBCs_on_PE) then + js_OBC = max(js-1, OBC%js_u_W_obc) ; je_OBC = min(je+1, OBC%je_u_W_obc) + Is_OBC = max(is-1, OBC%Is_u_W_obc) ; Ie_OBC = min(ie, OBC%Ie_u_W_obc) + !$OMP parallel do default(shared) + do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC + if (OBC%segnum_u(I,j) < 0) D_u(I,j) = G%bathyT(i+1,j) + G%Z_ref ! OBC_DIRECTION_W + enddo ; enddo + endif + endif + if (associated(OBC)) then ; do n=1,OBC%number_of_segments ! Now project bottom depths across cell-corner points in the OBCs. The two ! projections have to occur in sequence and can not be combined easily. @@ -506,8 +527,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then ! Apply a zero gradient projection of thickness across OBC points. if (m==1) then - do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= 0)) then + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E do k=1,nz h_at_vel(I,k) = h(i,j,k) ; h_vel(I,k) = h(i,j,k) dz_at_vel(I,k) = dz(i,j,k) ; dz_vel(I,k) = dz(i,j,k) @@ -524,7 +545,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (allocated(tv%SpV_avg)) then ; do k=1,nz SpV_vel(I,k) = tv%SpV_avg(i,j,k) enddo ; endif - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + elseif (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W do k=1,nz h_at_vel(I,k) = h(i+1,j,k) ; h_vel(I,k) = h(i+1,j,k) dz_at_vel(I,k) = dz(i+1,j,k) ; dz_vel(I,k) = dz(i+1,j,k) @@ -544,8 +565,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif endif ; enddo else - do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= 0)) then + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N do k=1,nz h_at_vel(i,k) = h(i,j,k) ; h_vel(i,k) = h(i,j,k) dz_at_vel(i,k) = dz(i,j,k) ; dz_vel(i,k) = dz(i,j,k) @@ -562,7 +583,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (allocated(tv%SpV_avg)) then ; do k=1,nz SpV_vel(i,k) = tv%SpV_avg(i,j,k) enddo ; endif - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + elseif (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S do k=1,nz h_at_vel(i,k) = h(i,j+1,k) ; h_vel(i,k) = h(i,j+1,k) dz_at_vel(i,k) = dz(i,j+1,k) ; dz_vel(i,k) = dz(i,j+1,k) @@ -1821,11 +1842,11 @@ function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC) enddo ; enddo if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then - do j0 = -1,0 ; do i0 = 0,1 ; if ((OBC%segnum_v(i+i0,J+j0) /= OBC_NONE)) then + do j0 = -1,0 ; do i0 = 0,1 ; if (OBC%segnum_v(i+i0,J+j0) /= 0) then i1 = i+i0 ; J1 = J+j0 - if (OBC%segment(OBC%segnum_v(i1,j1))%direction == OBC_DIRECTION_N) then + if (OBC%segnum_v(i1,j1) > 0) then ! OBC_DIRECTION_N hwt(i0,j0) = 2.0 * h(i1,j1,k) * mask2dCv(i1,J1) - elseif (OBC%segment(OBC%segnum_v(i1,J1))%direction == OBC_DIRECTION_S) then + elseif (OBC%segnum_v(i1,J1) < 0) then ! OBC_DIRECTION_S hwt(i0,j0) = 2.0 * h(i1,J1+1,k) * mask2dCv(i1,J1) endif endif ; enddo ; enddo @@ -1866,11 +1887,11 @@ function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC) enddo ; enddo if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then - do j0 = 0,1 ; do i0 = -1,0 ; if ((OBC%segnum_u(I+i0,j+j0) /= OBC_NONE)) then + do j0 = 0,1 ; do i0 = -1,0 ; if ((OBC%segnum_u(I+i0,j+j0) /= 0)) then I1 = I+i0 ; j1 = j+j0 - if (OBC%segment(OBC%segnum_u(I1,j1))%direction == OBC_DIRECTION_E) then + if (OBC%segnum_u(I1,j1) > 0) then ! OBC_DIRECTION_E hwt(i0,j0) = 2.0 * h(I1,j1,k) * mask2dCu(I1,j1) - elseif (OBC%segment(OBC%segnum_u(I1,j1))%direction == OBC_DIRECTION_W) then + elseif (OBC%segnum_u(I1,j1) < 0) then ! OBC_DIRECTION_W hwt(i0,j0) = 2.0 * h(I1+1,j1,k) * mask2dCu(I1,j1) endif endif ; enddo ; enddo @@ -2091,8 +2112,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) enddo ; enddo if (associated(OBC)) then ; do n=1,OBC%number_of_segments - ! Now project bottom depths across cell-corner points in the OBCs. The two - ! projections have to occur in sequence and can not be combined easily. + ! Project bottom depths across cell-corner points in the OBCs. if (.not. OBC%segment(n)%on_pe) cycle ! Use a one-sided projection of bottom depths at OBC points. I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB @@ -2101,7 +2121,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (OBC%segment(n)%direction == OBC_DIRECTION_N) mask_u(I,j+1) = 0.0 if (OBC%segment(n)%direction == OBC_DIRECTION_S) mask_u(I,j) = 0.0 enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= je)) then + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= ie)) then do J = max(js-1,OBC%segment(n)%HI%JsdB), min(je,OBC%segment(n)%HI%JedB) if (OBC%segment(n)%direction == OBC_DIRECTION_E) mask_v(i+1,J) = 0.0 if (OBC%segment(n)%direction == OBC_DIRECTION_W) mask_v(i,J) = 0.0 diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d3c0099d20..c5a085298e 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -411,6 +411,20 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, lpost, Cemp_NL, G end subroutine vertFPmix + +!> Expose loop indices to IPO for alias analysis and loop transformation. +function touch_ij(i,j) result(ij) + integer, intent(in) :: i + !< Inner loop index + integer, intent(in) :: j + !< Outer loop index + integer:: ij + !< Trivial operation to prevent removal during optimization + + ij = i * j +end function touch_ij + + !> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb !! (1990), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme !! redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, @@ -430,36 +444,41 @@ end subroutine vertFPmix !! or !! a_cpl_gl90 = nu / h = f^2 * alpha / h -subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, VarMix, work_on_u) +subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, G, GV, CS, VarMix, work_on_u) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: hvel !< Distance between interfaces + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), intent(in) :: hvel !< Distance between interfaces !! at velocity points [Z ~> m] - logical, dimension(SZIB_(G)), intent(in) :: do_i !< If true, determine coupling coefficient + logical, dimension(SZIB_(G),SZJB_(G)), intent(in) :: do_i !< If true, determine coupling coefficient !! for a column - real, dimension(SZIB_(G),SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the !! bottom, normalized by the GL90 bottom !! boundary layer thickness [nondim] - real, dimension(SZIB_(G),SZK_(GV)+1), intent(inout) :: a_cpl_gl90 !< Coupling coefficient associated + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), intent(out) :: a_cpl_gl90 !< Coupling coefficient associated !! with GL90 across interfaces; is not !! included in a_cpl [H T-1 ~> m s-1 or Pa s m-1]. - integer, intent(in) :: j !< j-index to find coupling coefficient for - type(vertvisc_cs), pointer :: CS !< Vertical viscosity control structure + type(vertvisc_cs), intent(in) :: CS !< Vertical viscosity control structure type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients logical, intent(in) :: work_on_u !< If true, u-points are being calculated, !! otherwise they are v-points. ! local variables logical :: kdgl90_use_vert_struct ! use vertical structure for GL90 coefficient - integer :: i, k, is, ie, nz, Isq, Ieq + integer :: i, j, k, is, ie, js, je, nz real :: f2 !< Squared Coriolis parameter at a velocity grid point [T-2 ~> s-2]. real :: h_neglect ! A vertical distance that is so small it is usually lost in roundoff error ! and can be neglected [Z ~> m]. real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: z2 ! The distance from the bottom, normalized by Hbbl_gl90 [nondim] - is = G%isc ; ie = G%iec - Isq = G%IscB ; Ieq = G%IecB + if (work_on_u) then + Is = G%iscB ; Ie = G%iecB + js = G%jsc ; je = G%jec + else + is = G%isc ; ie = G%iec + Js = G%jscB ; Je = G%jecB + endif + nz = GV%ke h_neglect = GV%dZ_subroundoff @@ -468,60 +487,60 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va kdgl90_use_vert_struct = allocated(VarMix%kdgl90_struct) endif - if (work_on_u) then - ! compute coupling coefficient at u-points - do I=Isq,Ieq; if (do_i(I)) then - f2 = 0.25 * (G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J))**2 - do K=2,nz + a_cpl_gl90(:,:,:) = 0. + + do K=2,nz + if (work_on_u) then + ! compute coupling coefficient at u-points + do j=js,je ; do I=Is,Ie; if (do_i(I,j)) then + f2 = 0.25 * (G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J))**2 if (CS%use_GL90_N2) then - a_cpl_gl90(I,K) = 2.0 * f2 * CS%alpha_gl90 / (hvel(I,k) + hvel(I,k-1) + h_neglect) + a_cpl_gl90(I,j,K) = 2. * f2 * CS%alpha_gl90 / (hvel(I,j,k) + hvel(I,j,k-1) + h_neglect) else if (CS%read_kappa_gl90) then - a_cpl_gl90(I,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i+1,j)) / GV%g_prime(K) + a_cpl_gl90(I,j,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i+1,j)) / GV%g_prime(K) else - a_cpl_gl90(I,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) + a_cpl_gl90(I,j,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) endif if (kdgl90_use_vert_struct) then - a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * 0.5 * & - ( VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i+1,j,k-1) ) + a_cpl_gl90(I,j,K) = a_cpl_gl90(I,j,K) * 0.5 & + * (VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i+1,j,k-1)) endif endif ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, ! going from 1 at the bottom to 0 in the interior. - z2 = z_i(I,k) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * (1 - botfn) - enddo - endif; enddo - else - ! compute viscosities at v-points - do i=is,ie; if (do_i(i)) then - f2 = 0.25 * (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J))**2 - do K=2,nz + z2 = z_i(I,j,k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + a_cpl_gl90(I,j,K) = a_cpl_gl90(I,j,K) * (1. - botfn) + endif; enddo ; enddo + else + ! compute viscosities at v-points + do J=Js,Je ; do i=is,ie ; if (do_i(i,J)) then + f2 = 0.25 * (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J))**2 if (CS%use_GL90_N2) then - a_cpl_gl90(i,K) = 2.0 * f2 * CS%alpha_gl90 / (hvel(i,k) + hvel(i,k-1) + h_neglect) + a_cpl_gl90(i,J,K) = 2. * f2 * CS%alpha_gl90 / (hvel(i,J,k) + hvel(i,J,k-1) + h_neglect) else if (CS%read_kappa_gl90) then - a_cpl_gl90(i,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i,j+1)) / GV%g_prime(K) + a_cpl_gl90(i,J,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i,j+1)) / GV%g_prime(K) else - a_cpl_gl90(i,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) + a_cpl_gl90(i,J,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) endif if (kdgl90_use_vert_struct) then - a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * 0.5 * & - ( VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i,j+1,k-1) ) + a_cpl_gl90(i,J,K) = a_cpl_gl90(i,J,K) * 0.5 & + * (VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i,j+1,k-1)) endif endif ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, ! going from 1 at the bottom to 0 in the interior. - z2 = z_i(i,k) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * (1 - botfn) - enddo - endif; enddo - endif - + z2 = z_i(i,J,k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + a_cpl_gl90(i,J,K) = a_cpl_gl90(i,J,K) * (1. - botfn) + endif ; enddo ; enddo + endif + enddo end subroutine find_coupling_coef_gl90 + !> Perform a fully implicit vertical diffusion !! of momentum. Stress top and bottom boundary conditions are used. !! @@ -535,7 +554,6 @@ end subroutine find_coupling_coef_gl90 !! $r_k$ is a Rayleigh drag term due to channel drag. !! There is an additional stress term on the right-hand side !! if DIRECT_STRESS is true, applied to the surface layer. - subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & taux_bot, tauy_bot, fpmix, Waves) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -571,10 +589,14 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! Local variables - real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. - real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] + real :: b1(SZIB_(G), SZJB_(G)) + ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: c1(SZIB_(G), SZJB_(G), SZK_(GV)) + ! A variable used by the tridiagonal solver [nondim]. + real :: d1(SZIB_(G), SZJB_(G)) + ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: Ray(SZIB_(G), SZJB_(G)) + ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: Hmix ! The mixed layer thickness over which stress @@ -591,8 +613,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! than this are diagnosed as 0 [L T-2 ~> m s-2]. real :: zDS, h_a ! Temporary thickness variables used with direct_stress [H ~> m or kg m-2] real :: hfr ! Temporary ratio of thicknesses used with direct_stress [nondim] - real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress - ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: surface_stress(SZIB_(G), SZJB_(G)) + ! The same as stress, unless the wind stress is applied as a body force + ! [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, allocatable, dimension(:,:,:) :: KE_term ! A term in the kinetic energy budget ! [H L2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:) :: KE_u ! The area integral of a KE term in a layer at u-points @@ -600,7 +623,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real, allocatable, dimension(:,:,:) :: KE_v ! The area integral of a KE term in a layer at v-points ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] - logical :: do_i(SZIB_(G)) logical :: DoStokesMixing logical :: lfpmix @@ -643,341 +665,470 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & lfpmix = .false. if ( present(fpmix) ) lfpmix = fpmix - do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo - ! Update the zonal velocity component using a modification of a standard ! tridagonal solver. - !$OMP parallel do default(shared) firstprivate(Ray) & - !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & - !$OMP b_denom_1,b1,d1,c1) - do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo - - ! WGL: Brandon Reichl says the following is obsolete. u(I,j,k) already - ! includes Stokes. - ! When mixing down Eulerian current + Stokes drift add before calling solver - if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) - enddo ; enddo ; endif + ! WGL: Brandon Reichl says the following is obsolete. u(I,j,k) already + ! includes Stokes. + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + endif ; enddo ; enddo ; enddo + endif - if ( lfpmix ) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) - enddo ; enddo ; endif + if (lfpmix) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + endif ; enddo ; enddo ; enddo + endif - if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq + if (associated(ADp%du_dt_visc)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = u(I,j,k) - enddo ; enddo ; endif - if (associated(ADp%du_dt_visc_gl90)) then ; do k=1,nz ; do I=Isq,Ieq + enddo ; enddo; enddo + endif + + if (associated(ADp%du_dt_visc_gl90)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ADp%du_dt_visc_gl90(I,j,k) = u(I,j,k) - enddo ; enddo ; endif - if (associated(ADp%du_dt_str)) then ; do k=1,nz ; do I=Isq,Ieq + enddo ; enddo ; enddo + endif + + if (associated(ADp%du_dt_str)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ADp%du_dt_str(I,j,k) = 0.0 - enddo ; enddo ; endif - - ! One option is to have the wind stress applied as a body force - ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, - ! the wind stress is applied as a stress boundary condition. - if (CS%direct_stress) then - do I=Isq,Ieq ; if (do_i(I)) then - surface_stress(I) = 0.0 - zDS = 0.0 - stress = dt_Rho0 * forces%taux(I,j) - do k=1,nz - h_a = 0.5 * (h(i,j,k) + h(i+1,j,k)) + h_neglect - hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a - u(I,j,k) = u(I,j,k) + I_Hmix * hfr * stress - if (associated(ADp%du_dt_str)) ADp%du_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt - zDS = zDS + h_a ; if (zDS >= Hmix) exit - enddo - endif ; enddo ! end of i loop - else ; do I=Isq,Ieq - surface_stress(I) = dt_Rho0 * (G%mask2dCu(I,j)*forces%taux(I,j)) - enddo ; endif ! direct_stress - - if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = visc%Ray_u(I,j,k) - enddo ; enddo ; endif - - ! perform forward elimination on the tridiagonal system - ! - ! denote the diagonal of the system as b_k, the subdiagonal as a_k - ! and the superdiagonal as c_k. The right-hand side terms are d_k. - ! - ! ignoring the Rayleigh drag contribution, - ! we have a_k = -dt * a_u(k) - ! b_k = h_u(k) + dt * (a_u(k) + a_u(k+1)) - ! c_k = -dt * a_u(k+1) - ! - ! for forward elimination, we want to: - ! calculate c'_k = - c_k / (b_k + a_k c'_(k-1)) - ! and d'_k = (d_k - a_k d'_(k-1)) / (b_k + a_k c'_(k-1)) - ! where c'_1 = c_1/b_1 and d'_1 = d_1/b_1 - ! - ! This form is mathematically equivalent to Thomas' tridiagonal matrix algorithm, but it - ! does not suffer from the acute sensitivity to truncation errors of the Thomas algorithm - ! because it involves no subtraction, as discussed by Schopf & Loughe, MWR, 1995. - ! - ! b1 is the denominator term 1 / (b_k + a_k c'_(k-1)) - ! b_denom_1 is (b_k + a_k + c_k) - a_k(1 - c'_(k-1)) - ! = (b_k + c_k + c'_(k-1)) - ! this is done so that d1 = b1 * b_denom_1 = 1 - c'_(k-1) - ! c1(k) is -c'_(k - 1) - ! and the right-hand-side is destructively updated to be d'_k - ! - do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) - d1(I) = b_denom_1 * b1(I) - u(I,j,1) = b1(I) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I)) - if (associated(ADp%du_dt_str)) & - ADp%du_dt_str(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I)*Idt) - endif ; enddo - do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt * CS%a_u(I,j,K) * b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) - d1(I) = b_denom_1 * b1(I) - u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & - dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) - if (associated(ADp%du_dt_str)) & - ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) + & - dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I) + enddo ; enddo ; enddo + endif + + ! One option is to have the wind stress applied as a body force + ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, + ! the wind stress is applied as a stress boundary condition. + if (CS%direct_stress) then + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + surface_stress(I,j) = 0.0 + zDS = 0.0 + stress = dt_Rho0 * forces%taux(I,j) + do k=1,nz + h_a = 0.5 * (h(i,j,k) + h(i+1,j,k)) + h_neglect + hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a + u(I,j,k) = u(I,j,k) + I_Hmix * hfr * stress + if (associated(ADp%du_dt_str)) ADp%du_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt + zDS = zDS + h_a ; if (zDS >= Hmix) exit + enddo endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do I=Isq,Ieq + surface_stress(I,j) = dt_Rho0 * (G%mask2dCu(I,j)*forces%taux(I,j)) + enddo ; enddo + endif - ! back substitute to solve for the new velocities - ! u_k = d'_k - c'_k x_(k+1) - do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - u(I,j,k) = u(I,j,k) + c1(I,k+1) * u(I,j,k+1) - endif ; enddo ; enddo ! i and k loops + ! perform forward elimination on the tridiagonal system + ! + ! denote the diagonal of the system as b_k, the subdiagonal as a_k + ! and the superdiagonal as c_k. The right-hand side terms are d_k. + ! + ! ignoring the Rayleigh drag contribution, + ! we have a_k = -dt * a_u(k) + ! b_k = h_u(k) + dt * (a_u(k) + a_u(k+1)) + ! c_k = -dt * a_u(k+1) + ! + ! for forward elimination, we want to: + ! calculate c'_k = - c_k / (b_k + a_k c'_(k-1)) + ! and d'_k = (d_k - a_k d'_(k-1)) / (b_k + a_k c'_(k-1)) + ! where c'_1 = c_1/b_1 and d'_1 = d_1/b_1 + ! + ! This form is mathematically equivalent to Thomas' tridiagonal matrix algorithm, but it + ! does not suffer from the acute sensitivity to truncation errors of the Thomas algorithm + ! because it involves no subtraction, as discussed by Schopf & Loughe, MWR, 1995. + ! + ! b1 is the denominator term 1 / (b_k + a_k c'_(k-1)) + ! b_denom_1 is (b_k + a_k + c_k) - a_k(1 - c'_(k-1)) + ! = (b_k + c_k + c'_(k-1)) + ! this is done so that d1 = b1 * b_denom_1 = 1 - c'_(k-1) + ! c1(k) is -c'_(k - 1) + ! and the right-hand-side is destructively updated to be d'_k + + if (allocated(visc%Ray_u)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq + Ray(I,j) = visc%Ray_u(I,j,1) + enddo ; enddo + else + do j=G%jsc,G%jec ; do I=Isq,Ieq + Ray(I,j) = 0. + enddo ; enddo + endif + + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,j) + CS%a_u(I,j,1)) + b1(I,j) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) + d1(I,j) = b_denom_1 * b1(I,j) + u(I,j,1) = b1(I,j) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I,j)) + endif ; enddo ; enddo + + if (associated(ADp%du_dt_str)) then + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + ADp%du_dt_str(I,j,1) = b1(I,j) * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I,j) * Idt) + endif ; enddo ; enddo + endif + + do k=2,nz + if (allocated(visc%Ray_u)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq + Ray(I,j) = visc%Ray_u(I,j,k) + enddo ; enddo + endif + + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + c1(I,j,k) = dt * CS%a_u(I,j,K) * b1(I,j) + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,j) + CS%a_u(I,j,K)*d1(I,j)) + b1(I,j) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) + d1(I,j) = b_denom_1 * b1(I,j) + u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & + dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I,j) + endif ; enddo ; enddo if (associated(ADp%du_dt_str)) then - do i=is,ie ; if (abs(ADp%du_dt_str(I,j,nz)) < accel_underflow) ADp%du_dt_str(I,j,nz) = 0.0 ; enddo - do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(I,k+1) * ADp%du_dt_str(I,j,k+1) - if (abs(ADp%du_dt_str(I,j,k)) < accel_underflow) ADp%du_dt_str(I,j,k) = 0.0 + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) & + + dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I,j) endif ; enddo ; enddo endif + enddo + + ! back substitute to solve for the new velocities + ! u_k = d'_k - c'_k x_(k+1) + do k=nz-1,1,-1 + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) + c1(I,j,k+1) * u(I,j,k+1) + endif ; enddo ; enddo + enddo + + if (associated(ADp%du_dt_str)) then + do j=G%isc,G%jec ; do I=Isq,Ieq + if (abs(ADp%du_dt_str(I,j,nz)) < accel_underflow) & + ADp%du_dt_str(I,j,nz) = 0.0 + enddo ; enddo + + do k=nz-1,1,-1 + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(I,j,k+1) * ADp%du_dt_str(I,j,k+1) + + if (abs(ADp%du_dt_str(I,j,k)) < accel_underflow) & + ADp%du_dt_str(I,j,k) = 0.0 + endif ; enddo ; enddo + enddo + endif - ! compute vertical velocity tendency that arises from GL90 viscosity; - ! follow tridiagonal solve method as above; to avoid corrupting u, - ! use ADp%du_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop - if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then - if (associated(ADp%du_dt_visc_gl90)) then - do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero - b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u_gl90(I,j,2)) - d1(I) = b_denom_1 * b1(I) - ADp%du_dt_visc_gl90(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) - endif ; enddo - do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt * CS%a_u_gl90(I,j,K) * b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1)) - d1(I) = b_denom_1 * b1(I) - ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) + & - dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I) + ! compute vertical velocity tendency that arises from GL90 viscosity; + ! follow tridiagonal solve method as above; to avoid corrupting u, + ! use ADp%du_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop + if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + if (associated(ADp%du_dt_visc_gl90)) then + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero + b1(I,j) = 1.0 / (b_denom_1 + dt*CS%a_u_gl90(I,j,2)) + d1(I,j) = b_denom_1 * b1(I,j) + + ADp%du_dt_visc_gl90(I,j,1) = b1(I,j) * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) + endif ; enddo ; enddo + + do k=2,nz + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + c1(I,j,k) = dt * CS%a_u_gl90(I,j,K) * b1(I,j) + b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1(I,j)) + b1(I,j) = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1)) + d1(I,j) = b_denom_1 * b1(I,j) + + ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) & + + dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I,j) + endif ; enddo ; enddo + enddo + + ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 + do k=nz-1,1,-1 + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + ADp%du_dt_visc_gl90(I,j,k) = ADp%du_dt_visc_gl90(I,j,k) & + + c1(I,j,k+1) * ADp%du_dt_visc_gl90(I,j,k+1) endif ; enddo ; enddo - ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 - do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - ADp%du_dt_visc_gl90(I,j,k) = ADp%du_dt_visc_gl90(I,j,k) + c1(I,k+1) * ADp%du_dt_visc_gl90(I,j,k+1) - endif ; enddo ; enddo ! i and k loops - do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then + enddo + + do k=1,nz + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then ! now fill ADp%du_dt_visc_gl90(I,j,k) with actual velocity tendency due to GL90; ! note that on RHS: ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) ! and ADp%du_dt_visc_gl90(I,j,k) the updated velocity due to GL90 - ADp%du_dt_visc_gl90(I,j,k) = (ADp%du_dt_visc_gl90(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt - if (abs(ADp%du_dt_visc_gl90(I,j,k)) < accel_underflow) ADp%du_dt_visc_gl90(I,j,k) = 0.0 - endif ; enddo ; enddo ; - ! to compute energetics, we need to multiply by u*h, where u is original velocity before - ! velocity update; note that ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) - if (CS%id_GLwork > 0) then - do k=1,nz; do I=Isq,Ieq ; if (do_i(I)) then - KE_u(I,j,k) = ADp%du_dt_visc(I,j,k) * CS%h_u(I,j,k) * G%areaCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) + ADp%du_dt_visc_gl90(I,j,k) = & + (ADp%du_dt_visc_gl90(I,j,k) - ADp%du_dt_visc(I,j,k)) * Idt + + if (abs(ADp%du_dt_visc_gl90(I,j,k)) < accel_underflow) then + ADp%du_dt_visc_gl90(I,j,k) = 0.0 + endif + endif ; enddo ; enddo + enddo + + ! to compute energetics, we need to multiply by u*h, where u is original velocity before + ! velocity update; note that ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) + if (CS%id_GLwork > 0) then + do k=1,nz + do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + KE_u(I,j,k) = ADp%du_dt_visc(I,j,k) * CS%h_u(I,j,k) * G%areaCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) endif ; enddo ; enddo - endif + enddo endif endif + endif - if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq - ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt - if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) ADp%du_dt_visc(I,j,k) = 0.0 - enddo ; enddo ; endif + if (associated(ADp%du_dt_visc)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq + ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k)) * Idt - if (allocated(visc%taux_shelf)) then ; do I=Isq,Ieq - visc%taux_shelf(I,j) = -GV%H_to_RZ*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? - enddo ; endif + if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) & + ADp%du_dt_visc(I,j,k) = 0.0 + enddo ; enddo ; enddo + endif - if (PRESENT(taux_bot)) then - do I=Isq,Ieq - taux_bot(I,j) = GV%H_to_RZ * (u(I,j,nz)*CS%a_u(I,j,nz+1)) - enddo - if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - taux_bot(I,j) = taux_bot(I,j) + GV%H_to_RZ * (Ray(I,k)*u(I,j,k)) - enddo ; enddo ; endif - endif + if (allocated(visc%taux_shelf)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq + visc%taux_shelf(I,j) = -GV%H_to_RZ * CS%a1_shelf_u(I,j) * u(I,j,1) ! - u_shelf? + enddo ; enddo + endif - ! When mixing down Eulerian current + Stokes drift subtract after calling solver - if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) - enddo ; enddo ; endif + if (present(taux_bot)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq + taux_bot(I,j) = GV%H_to_RZ * (u(I,j,nz) * CS%a_u(I,j,nz+1)) + enddo ; enddo - if ( lfpmix ) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) - enddo ; enddo ; endif + if (allocated(visc%Ray_u)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq + taux_bot(I,j) = taux_bot(I,j) + GV%H_to_RZ * (visc%Ray_u(I,j,k) * u(I,j,k)) + enddo ; enddo ; enddo + endif + endif - enddo ! end u-component j loop + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + endif ; enddo ; enddo ; enddo + endif - ! Now work on the meridional velocity component. + if (lfpmix) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + endif ; enddo ; enddo ; enddo + endif - !$OMP parallel do default(shared) firstprivate(Ray) & - !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & - !$OMP b_denom_1,b1,d1,c1) - do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo + ! == Now work on the meridional velocity component. - ! When mixing down Eulerian current + Stokes drift add before calling solver - if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) - enddo ; enddo ; endif + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) + endif ; enddo ; enddo ; enddo + endif - if ( lfpmix ) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,j,k) = v(i,j,k) - Waves%Us_y(i,j,k) - enddo ; enddo ; endif + if (lfpmix) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,j,k) = v(i,j,k) - Waves%Us_y(i,j,k) + endif ; enddo ; enddo ; enddo + endif - if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie + if (associated(ADp%dv_dt_visc)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ADp%dv_dt_visc(i,J,k) = v(i,J,k) - enddo ; enddo ; endif - if (associated(ADp%dv_dt_visc_gl90)) then ; do k=1,nz ; do i=is,ie + enddo ; enddo ; enddo + endif + + if (associated(ADp%dv_dt_visc_gl90)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ADp%dv_dt_visc_gl90(i,J,k) = v(i,J,k) - enddo ; enddo ; endif - if (associated(ADp%dv_dt_str)) then ; do k=1,nz ; do i=is,ie + enddo ; enddo ; enddo + endif + + if (associated(ADp%dv_dt_str)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ADp%dv_dt_str(i,J,k) = 0.0 - enddo ; enddo ; endif - - ! One option is to have the wind stress applied as a body force - ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, - ! the wind stress is applied as a stress boundary condition. - if (CS%direct_stress) then - do i=is,ie ; if (do_i(i)) then - surface_stress(i) = 0.0 - zDS = 0.0 - stress = dt_Rho0 * forces%tauy(i,J) - do k=1,nz - h_a = 0.5 * (h(i,J,k) + h(i,J+1,k)) + h_neglect - hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a - v(i,J,k) = v(i,J,k) + I_Hmix * hfr * stress - if (associated(ADp%dv_dt_str)) ADp%dv_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt - zDS = zDS + h_a ; if (zDS >= Hmix) exit - enddo - endif ; enddo ! end of i loop - else ; do i=is,ie - surface_stress(i) = dt_Rho0 * (G%mask2dCv(i,J)*forces%tauy(i,J)) - enddo ; endif ! direct_stress - - if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = visc%Ray_v(i,J,k) - enddo ; enddo ; endif - - do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) - d1(i) = b_denom_1 * b1(i) - v(i,J,1) = b1(i) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i)) - if (associated(ADp%dv_dt_str)) & - ADp%dv_dt_str(i,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i)*Idt) - endif ; enddo - do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt * CS%a_v(i,J,K) * b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) - d1(i) = b_denom_1 * b1(i) - v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) - if (associated(ADp%dv_dt_str)) & - ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) + & - dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i) + enddo ; enddo ; enddo + endif + + ! One option is to have the wind stress applied as a body force + ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, + ! the wind stress is applied as a stress boundary condition. + if (CS%direct_stress) then + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + surface_stress(i,J) = 0.0 + zDS = 0.0 + stress = dt_Rho0 * forces%tauy(i,J) + do k=1,nz + h_a = 0.5 * (h(i,J,k) + h(i,J+1,k)) + h_neglect + hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a + v(i,J,k) = v(i,J,k) + I_Hmix * hfr * stress + if (associated(ADp%dv_dt_str)) ADp%dv_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt + zDS = zDS + h_a ; if (zDS >= Hmix) exit + enddo + endif ; enddo ; enddo + else + do J=Jsq,Jeq ; do i=is,ie + surface_stress(i,J) = dt_Rho0 * (G%mask2dCv(i,J) * forces%tauy(i,J)) + enddo ; enddo + endif + + if (allocated(visc%Ray_v)) then + do J=Jsq,Jeq ; do i=is,ie + Ray(i,J) = visc%Ray_v(i,J,1) + enddo ; enddo + else + do J=Jsq,Jeq ; do i=is,ie + Ray(i,J) = 0. + enddo ; enddo + endif + + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,J) + CS%a_v(i,J,1)) + b1(i,J) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) + d1(i,J) = b_denom_1 * b1(i,J) + v(i,J,1) = b1(i,J) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i,J)) + endif ; enddo ; enddo + + if (associated(ADp%dv_dt_str)) then + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + ADp%dv_dt_str(i,J,1) = b1(i,J) * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i,J) * Idt) + endif ; enddo ; enddo + endif + + do k=2,nz + if (allocated(visc%Ray_v)) then + do J=Jsq,Jeq ; do i=is,ie + Ray(i,J) = visc%Ray_v(i,J,k) + enddo ; enddo + endif + + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + c1(i,J,k) = dt * CS%a_v(i,J,K) * b1(i,J) + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,J) + CS%a_v(i,J,K)*d1(i,J)) + b1(i,J) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) + d1(i,J) = b_denom_1 * b1(i,J) + v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i,J) endif ; enddo ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then - v(i,J,k) = v(i,J,k) + c1(i,k+1) * v(i,J,k+1) - endif ; enddo ; enddo ! i and k loops if (associated(ADp%dv_dt_str)) then - do i=is,ie ; if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) ADp%dv_dt_str(i,J,nz) = 0.0 ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then - ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(i,k+1) * ADp%dv_dt_str(i,J,k+1) - if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) ADp%dv_dt_str(i,J,k) = 0.0 + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) & + + dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i,J) endif ; enddo ; enddo endif + enddo + + do k=nz-1,1,-1 + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,J,k) = v(i,J,k) + c1(i,J,k+1) * v(i,J,k+1) + endif ; enddo ; enddo + enddo + + if (associated(ADp%dv_dt_str)) then + do J=Jsq,Jeq ; do i=is,ie + if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) ADp%dv_dt_str(i,J,nz) = 0.0 + enddo ; enddo + + do k=nz-1,1,-1 + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(i,J,k+1) * ADp%dv_dt_str(i,J,k+1) + if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) ADp%dv_dt_str(i,J,k) = 0.0 + endif ; enddo ; enddo + enddo + endif - ! compute vertical velocity tendency that arises from GL90 viscosity; - ! follow tridiagonal solve method as above; to avoid corrupting v, - ! use ADp%dv_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop - if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then - if (associated(ADp%dv_dt_visc_gl90)) then - do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero - b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2)) - d1(i) = b_denom_1 * b1(i) - ADp%dv_dt_visc_gl90(I,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) - endif ; enddo - do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt * CS%a_v_gl90(i,J,K) * b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1)) - d1(i) = b_denom_1 * b1(i) + ! compute vertical velocity tendency that arises from GL90 viscosity; + ! follow tridiagonal solve method as above; to avoid corrupting v, + ! use ADp%dv_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop + if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + if (associated(ADp%dv_dt_visc_gl90)) then + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero + b1(i,J) = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2)) + d1(i,J) = b_denom_1 * b1(i,J) + ADp%dv_dt_visc_gl90(I,J,1) = b1(i,J) * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) + endif ; enddo ; enddo + + do k=2,nz + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + c1(i,J,k) = dt * CS%a_v_gl90(i,J,K) * b1(i,J) + b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K)*d1(i,J)) + b1(i,J) = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1)) + d1(i,J) = b_denom_1 * b1(i,J) ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) + & - dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i) + dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i,J) + endif ; enddo ; enddo + enddo + + ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 + do k=nz-1,1,-1 + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + ADp%dv_dt_visc_gl90(i,J,k) = ADp%dv_dt_visc_gl90(i,J,k) + c1(i,J,k+1) * ADp%dv_dt_visc_gl90(i,J,k+1) endif ; enddo ; enddo - ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 - do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then - ADp%dv_dt_visc_gl90(i,J,k) = ADp%dv_dt_visc_gl90(i,J,k) + c1(i,k+1) * ADp%dv_dt_visc_gl90(i,J,k+1) - endif ; enddo ; enddo ! i and k loops - do k=1,nz ; do i=is,ie ; if (do_i(i)) then + enddo + + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then ! now fill ADp%dv_dt_visc_gl90(i,J,k) with actual velocity tendency due to GL90; ! note that on RHS: ADp%dv_dt_visc(i,J,k) holds the original velocity value v(i,J,k) ! and ADp%dv_dt_visc_gl90(i,J,k) the updated velocity due to GL90 ADp%dv_dt_visc_gl90(i,J,k) = (ADp%dv_dt_visc_gl90(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt if (abs(ADp%dv_dt_visc_gl90(i,J,k)) < accel_underflow) ADp%dv_dt_visc_gl90(i,J,k) = 0.0 - endif ; enddo ; enddo ; - ! to compute energetics, we need to multiply by v*h, where u is original velocity before - ! velocity update; note that ADp%dv_dt_visc(I,j,k) holds the original velocity value v(i,J,k) - if (CS%id_GLwork > 0) then - do k=1,nz ; do i=is,ie ; if (do_i(i)) then - ! note that on RHS: ADp%dv_dt_visc(I,j,k) holds the original velocity value v(I,j,k) - KE_v(I,j,k) = ADp%dv_dt_visc(i,J,k) * CS%h_v(i,J,k) * G%areaCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k) + endif ; enddo ; enddo + enddo + + ! to compute energetics, we need to multiply by v*h, where u is original velocity before + ! velocity update; note that ADp%dv_dt_visc(I,j,k) holds the original velocity value v(i,J,k) + if (CS%id_GLwork > 0) then + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + ! note that on RHS: ADp%dv_dt_visc(I,j,k) holds the original velocity value v(I,j,k) + KE_v(I,j,k) = ADp%dv_dt_visc(i,J,k) * CS%h_v(i,J,k) * G%areaCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k) endif ; enddo ; enddo - endif + enddo endif endif + endif - if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie + if (associated(ADp%dv_dt_visc)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ADp%dv_dt_visc(i,J,k) = (v(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt if (abs(ADp%dv_dt_visc(i,J,k)) < accel_underflow) ADp%dv_dt_visc(i,J,k) = 0.0 - enddo ; enddo ; endif + enddo ; enddo ; enddo + endif - if (allocated(visc%tauy_shelf)) then ; do i=is,ie - visc%tauy_shelf(i,J) = -GV%H_to_RZ*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? - enddo ; endif + if (allocated(visc%tauy_shelf)) then + do J=Jsq,Jeq ; do i=is,ie + visc%tauy_shelf(i,J) = -GV%H_to_RZ * CS%a1_shelf_v(i,J) * v(i,J,1) ! - v_shelf? + enddo ; enddo + endif - if (present(tauy_bot)) then - do i=is,ie - tauy_bot(i,J) = GV%H_to_RZ * (v(i,J,nz)*CS%a_v(i,J,nz+1)) - enddo - if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - tauy_bot(i,J) = tauy_bot(i,J) + GV%H_to_RZ * (Ray(i,k)*v(i,J,k)) - enddo ; enddo ; endif - endif + if (present(tauy_bot)) then + do J=Jsq,Jeq ; do i=is,ie + tauy_bot(i,J) = GV%H_to_RZ * (v(i,J,nz) * CS%a_v(i,J,nz+1)) + enddo; enddo - ! When mixing down Eulerian current + Stokes drift subtract after calling solver - if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) - enddo ; enddo ; endif + if (allocated(visc%Ray_v)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + tauy_bot(i,J) = tauy_bot(i,J) + GV%H_to_RZ * (visc%Ray_v(i,J,k)*v(i,J,k)) + enddo ; enddo ; enddo + endif + endif - if ( lfpmix ) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,J,k) = v(i,J,k) + Waves%Us_y(i,J,k) - enddo ; enddo ; endif + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) + endif ; enddo ; enddo ; enddo + endif - enddo ! end of v-component J loop + if (lfpmix) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,J,k) = v(i,J,k) + Waves%Us_y(i,J,k) + endif ; enddo ; enddo ; enddo + endif ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3]. ! We do the KE-rate calculation here (rather than in MOM_diagnostics) to ensure @@ -1071,6 +1222,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & end subroutine vertvisc + !> Calculate the fraction of momentum originally in a layer that remains in the water column !! after a time-step of viscosity, equivalently the fraction of a time-step's worth of !! barotropic acceleration that a layer experiences after viscosity is applied. @@ -1092,12 +1244,15 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Local variables - real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. - real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] + real :: b1(SZIB_(G),SZJB_(G)) + ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: c1(SZIB_(G),SZJB_(G),SZK_(GV)) + ! A variable used by the tridiagonal solver [nondim]. + real :: d1(SZIB_(G),SZJB_(G)) + ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: Ray(SZIB_(G),SZJB_(G)) + ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. - logical :: do_i(SZIB_(G)) integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec @@ -1109,69 +1264,90 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remant): "// & "Module must be initialized before it is used.") - do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo - ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. - !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) - do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo - - if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = visc%Ray_u(I,j,k) - enddo ; enddo ; endif - - do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) - d1(I) = b_denom_1 * b1(I) - visc_rem_u(I,j,1) = b1(I) * CS%h_u(I,j,1) - endif ; enddo - do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt * CS%a_u(I,j,K)*b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) - d1(I) = b_denom_1 * b1(I) - visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) - endif ; enddo ; enddo - do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(I,k+1)*visc_rem_u(I,j,k+1) + if (allocated(visc%Ray_u)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq + Ray(I,j) = visc%Ray_u(I,j,1) + enddo ; enddo + else + do j=G%jsc,G%jec ; do I=Isq,Ieq + Ray(I,j) = 0. + enddo ; enddo + endif - endif ; enddo ; enddo ! i and k loops + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,j) + CS%a_u(I,j,1)) + b1(I,j) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,2)) + d1(I,j) = b_denom_1 * b1(I,j) + visc_rem_u(I,j,1) = b1(I,j) * CS%h_u(I,j,1) + endif ; enddo ; enddo + + do k=2,nz + if (allocated(visc%Ray_u)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq + Ray(I,j) = visc%Ray_u(I,j,k) + enddo ; enddo + endif + + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + c1(I,j,k) = dt * CS%a_u(I,j,K)*b1(I,j) + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,j) + CS%a_u(I,j,K) * d1(I,j)) + b1(I,j) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) + d1(I,j) = b_denom_1 * b1(I,j) + visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I,j) + endif ; enddo ; enddo + enddo - enddo ! end u-component j loop + do k=nz-1,1,-1 + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(I,j,k+1) * visc_rem_u(I,j,k+1) + endif ; enddo ; enddo + enddo ! Now find the meridional viscous remnant using the robust tridiagonal solver. - !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) - do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo - - if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = visc%Ray_v(i,J,k) - enddo ; enddo ; endif - - do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) - d1(i) = b_denom_1 * b1(i) - visc_rem_v(i,J,1) = b1(i) * CS%h_v(i,J,1) - endif ; enddo - do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt * CS%a_v(i,J,K)*b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) - d1(i) = b_denom_1 * b1(i) - visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) + if (allocated(visc%Ray_v)) then + do J=Jsq,Jeq ; do i=is,ie + Ray(i,J) = visc%Ray_v(i,J,1) + enddo ; enddo + else + do J=Jsq,Jeq ; do i=is,ie + Ray(i,J) = 0. + enddo ; enddo + endif + + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,J) + CS%a_v(i,J,1)) + b1(i,J) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) + d1(i,J) = b_denom_1 * b1(i,J) + visc_rem_v(i,J,1) = b1(i,J) * CS%h_v(i,J,1) + endif ; enddo ; enddo + + do k=2,nz + if (allocated(visc%Ray_v)) then + do J=Jsq,Jeq ; do i=is,ie + Ray(i,J) = visc%Ray_v(i,J,k) + enddo ; enddo + endif + + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + c1(i,J,k) = dt * CS%a_v(i,J,K) * b1(i,J) + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,J) + CS%a_v(i,J,K) * d1(i,J)) + b1(i,J) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) + d1(i,J) = b_denom_1 * b1(i,J) + visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i,J) endif ; enddo ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then - visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,k+1)*visc_rem_v(i,J,k+1) + enddo + + do k=nz-1,1,-1 + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,J,k+1) * visc_rem_v(i,J,k+1) endif ; enddo ; enddo ! i and k loops - enddo ! end of v-component J loop + enddo if (CS%debug) then call uvchksum("visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & scalar_pair=.true.) endif - end subroutine vertvisc_remnant @@ -1195,7 +1371,7 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available !! thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s] - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(vertvisc_CS), intent(inout) :: CS !< Vertical viscosity control structure type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients ! Field from forces used in this subroutine: @@ -1204,39 +1380,38 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! Local variables - real, dimension(SZIB_(G),SZK_(GV)) :: & - h_harm, & ! Harmonic mean of the thicknesses around a velocity grid point, - ! given by 2*(h+ * h-)/(h+ + h-) [H ~> m or kg m-2]. - h_arith, & ! The arithmetic mean thickness [H ~> m or kg m-2]. - h_delta, & ! The lateral difference of thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & hvel, & ! hvel is the thickness used at a velocity grid point [H ~> m or kg m-2]. - hvel_shelf, & ! The equivalent of hvel under shelves [H ~> m or kg m-2]. dz_harm, & ! Harmonic mean of the vertical distances around a velocity grid point, ! given by 2*(h+ * h-)/(h+ + h-) [Z ~> m]. - dz_arith, & ! The arithmetic mean of the vertical distances around a velocity grid point [Z ~> m] dz_vel, & ! The vertical distance between interfaces used at a velocity grid point [Z ~> m]. + hvel_shelf, & ! The equivalent of hvel under shelves [H ~> m or kg m-2]. dz_vel_shelf ! The equivalent of dz_vel under shelves [Z ~> m]. - real, dimension(SZIB_(G),SZK_(GV)+1) :: & + real, dimension(SZIB_(G),SZJB_(G)) :: & + h_harm, & ! Harmonic mean of the thicknesses around a velocity grid point, + ! given by 2*(h+ * h-)/(h+ + h-) [H ~> m or kg m-2]. + h_arith, & ! The arithmetic mean thickness [H ~> m or kg m-2]. + h_delta, & ! The lateral difference of thickness [H ~> m or kg m-2]. + dz_arith ! The arithmetic mean of the vertical distances around a velocity grid point [Z ~> m] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1) :: & + z_i, & ! An estimate of each interface's height above the bottom, + ! normalized by the bottom boundary layer thickness [nondim] + z_i_gl90, & ! An estimate of each interface's height above the bottom, + ! normalized by the GL90 bottom boundary layer thickness [nondim] a_cpl, & ! The drag coefficients across interfaces [H T-1 ~> m s-1 or Pa s m-1]. a_cpl times ! the velocity difference gives the stress across an interface. a_cpl_gl90, & ! The drag coefficients across interfaces associated with GL90 [H T-1 ~> m s-1 or Pa s m-1]. ! a_cpl_gl90 times the velocity difference gives the GL90 stress across an interface. ! a_cpl_gl90 is part of a_cpl. - a_shelf, & ! The drag coefficients across interfaces in water columns under + a_shelf ! The drag coefficients across interfaces in water columns under ! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. - z_i, & ! An estimate of each interface's height above the bottom, - ! normalized by the bottom boundary layer thickness [nondim] - z_i_gl90 ! An estimate of each interface's height above the bottom, - ! normalized by the GL90 bottom boundary layer thickness [nondim] - real, dimension(SZIB_(G)) :: & + real, dimension(SZIB_(G),SZJB_(G)) :: & kv_bbl, & ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. bbl_thick, & ! The bottom boundary layer thickness [Z ~> m]. I_Hbbl, & ! The inverse of the bottom boundary layer thickness [Z-1 ~> m-1]. I_Hbbl_gl90, &! The inverse of the bottom boundary layer thickness used for the GL90 scheme ! [Z-1 ~> m-1]. I_HTbl, & ! The inverse of the top boundary layer thickness [Z-1 ~> m-1]. - zcol1, & ! The height of the interfaces to the south of a v-point [Z ~> m]. - zcol2, & ! The height of the interfaces to the north of a v-point [Z ~> m]. Ztop_min, & ! The deeper of the two adjacent surface heights [Z ~> m]. Dmin, & ! The shallower of the two adjacent bottom depths [Z ~> m]. zh, & ! An estimate of the interface's distance from the bottom @@ -1255,7 +1430,7 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. real, allocatable, dimension(:,:,:) :: Kv_gl90_v ! GL90 vertical viscosity at v-points in ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. - real :: zcol(SZI_(G)) ! The height of an interface at h-points [Z ~> m]. + real :: zcol(SZI_(G), SZJ_(G)) ! The height of an interface at h-points [Z ~> m]. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior [nondim]. real :: topfn ! A function which goes from 1 at the top to 0 much more @@ -1273,27 +1448,30 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, real :: I_valBL ! The inverse of a scaling factor determining when water is ! still within the boundary layer, as determined by the sum ! of the harmonic mean thicknesses [nondim]. - logical, dimension(SZIB_(G)) :: do_i, do_i_shelf + logical :: do_i(SZIB_(G), SZJB_(G)) + ! Land mask + logical :: do_i_shelf(SZIB_(G), SZJB_(G)) + ! Land mask with fractional shelf logical :: do_any_shelf - integer, dimension(SZIB_(G)) :: & + integer, dimension(SZIB_(G), SZJB_(G)) :: & zi_dir ! A trinary logical array indicating which thicknesses to use for ! finding z_clear. - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, ij + integer :: is_N_OBC, is_S_OBC, Is_E_OBC, Is_W_OBC, ie_N_OBC, ie_S_OBC, Ie_E_OBC, Ie_W_OBC + integer :: js_N_OBC, js_S_OBC, Js_E_OBC, Js_W_OBC, je_N_OBC, je_S_OBC, Je_E_OBC, Je_W_OBC + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke - if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(coef): "// & - "Module must be initialized before it is used.") - if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(coef): "// & "Module must be initialized before it is used.") h_neglect = GV%H_subroundoff dz_neglect = GV%dZ_subroundoff a_cpl_max = 1.0e37 * GV%m_to_H * US%T_to_s - I_Hbbl(:) = 1.0 / (CS%Hbbl + dz_neglect) + I_Hbbl(:,:) = 1. / (CS%Hbbl + dz_neglect) if (CS%use_GL90_in_SSW) then - I_Hbbl_gl90(:) = 1.0 / (CS%Hbbl_gl90 + dz_neglect) + I_Hbbl_gl90(:,:) = 1. / (CS%Hbbl_gl90 + dz_neglect) endif I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val @@ -1317,430 +1495,784 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, allocate(CS%a1_shelf_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) endif - call find_ustar(forces, tv, Ustar_2d, G, GV, US, halo=1) + if (associated(OBC)) then + ! Set the ranges that contain various orientations of OBCs on this PE. + is_N_OBC = max(is, OBC%is_v_N_obc) ; ie_N_OBC = min(ie, OBC%ie_v_N_obc) + is_S_OBC = max(is, OBC%is_v_S_obc) ; ie_S_OBC = min(ie, OBC%ie_v_S_obc) + Js_N_OBC = max(Jsq, OBC%Js_v_N_obc) ; Je_N_OBC = min(Jeq, OBC%Je_v_N_obc) + Js_S_OBC = max(Jsq, OBC%Js_v_S_obc) ; Je_S_OBC = min(Jeq, OBC%Je_v_S_obc) + Is_E_OBC = max(Isq, OBC%Is_u_E_obc) ; Ie_E_OBC = min(Ieq, OBC%Ie_u_E_obc) + Is_W_OBC = max(Isq, OBC%Is_u_W_obc) ; Ie_W_OBC = min(Ieq, OBC%Ie_u_W_obc) + js_E_OBC = max(js, OBC%Js_u_E_obc) ; je_E_OBC = min(je, OBC%je_u_E_obc) + js_W_OBC = max(js, OBC%Js_u_W_obc) ; je_W_OBC = min(je, OBC%je_u_W_obc) + endif - !$OMP parallel do default(private) shared(G,GV,US,CS,tv,visc,OBC,Isq,Ieq,nz,u,h,dz,forces, & - !$OMP Ustar_2d,h_neglect,dz_neglect,dt,I_valBL,hML_u,Kv_u, & - !$OMP a_cpl_max,I_Hbbl_gl90,Kv_gl90_u) & - !$OMP firstprivate(I_Hbbl) - do j=G%Jsc,G%Jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo - - if (CS%bottomdraglaw) then ; do I=Isq,Ieq - kv_bbl(I) = visc%Kv_bbl_u(I,j) - bbl_thick(I) = visc%bbl_thick_u(I,j) + dz_neglect - if (do_i(I)) I_Hbbl(I) = 1.0 / bbl_thick(I) - enddo ; endif - - do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then - h_harm(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / (h(i,j,k)+h(i+1,j,k)+h_neglect) - h_arith(I,k) = 0.5*(h(i+1,j,k)+h(i,j,k)) - h_delta(I,k) = h(i+1,j,k) - h(i,j,k) - dz_harm(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / (dz(i,j,k)+dz(i+1,j,k)+dz_neglect) - dz_arith(I,k) = 0.5*(dz(i+1,j,k)+dz(i,j,k)) - endif ; enddo ; enddo - do I=Isq,Ieq - Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) - zi_dir(I) = 0 - enddo + call find_ustar(forces, tv, Ustar_2d, G, GV, US, halo=1) - ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then - do I=Isq,Ieq ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do k=1,nz - h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(I,k) = 0. - dz_harm(I,k) = dz(i,j,k) ; dz_arith(I,k) = dz(i,j,k) - enddo - Dmin(I) = G%bathyT(i,j) - zi_dir(I) = -1 - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do k=1,nz - h_harm(I,k) = h(i+1,j,k) ; h_arith(I,k) = h(i+1,j,k) ; h_delta(I,k) = 0. - dz_harm(I,k) = dz(i+1,j,k) ; dz_arith(I,k) = dz(i+1,j,k) - enddo - Dmin(I) = G%bathyT(i+1,j) - zi_dir(I) = 1 - endif - endif ; enddo - endif ; endif + ! First do u-points -! The following block calculates the thicknesses at velocity -! grid points for the vertical viscosity (hvel and dz_vel). Near the -! bottom an upwind biased thickness is used to control the effect -! of spurious Montgomery potential gradients at the bottom where -! nearly massless layers layers ride over the topography. - if (CS%harmonic_visc) then - do I=Isq,Ieq ; z_i(I,nz+1) = 0.0 ; enddo - do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - hvel(I,k) = h_harm(I,k) - dz_vel(I,k) = dz_harm(I,k) - if (u(I,j,k) * h_delta(I,k) < 0) then - z2 = z_i(I,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - hvel(I,k) = (1.0-botfn)*h_harm(I,k) + botfn*h_arith(I,k) - dz_vel(I,k) = (1.0-botfn)*dz_harm(I,k) + botfn*dz_arith(I,k) - endif - z_i(I,k) = z_i(I,k+1) + dz_harm(I,k)*I_Hbbl(I) - endif ; enddo ; enddo ! i & k loops - else ! Not harmonic_visc - do I=Isq,Ieq ; zh(I) = 0.0 ; z_i(I,nz+1) = 0.0 ; enddo - do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) ; enddo - do k=nz,1,-1 - do i=Isq,Ieq+1 ; zcol(i) = zcol(i) + dz(i,j,k) ; enddo - do I=Isq,Ieq ; if (do_i(I)) then - zh(I) = zh(I) + dz_harm(I,k) - - z_clear = max(zcol(i),zcol(i+1)) + Dmin(I) - if (zi_dir(I) < 0) z_clear = zcol(i) + Dmin(I) - if (zi_dir(I) > 0) z_clear = zcol(i+1) + Dmin(I) - - z_i(I,k) = max(zh(I), z_clear) * I_Hbbl(I) - - hvel(I,k) = h_arith(I,k) - dz_vel(I,k) = dz_arith(I,k) - if (u(I,j,k) * h_delta(I,k) > 0) then - if (zh(I) * I_Hbbl(I) < CS%harm_BL_val) then - hvel(I,k) = h_harm(I,k) - dz_vel(I,k) = dz_harm(I,k) - else - z2_wt = 1.0 ; if (zh(I) * I_Hbbl(I) < 2.0*CS%harm_BL_val) & - z2_wt = max(0.0, min(1.0, zh(I) * I_Hbbl(I) * I_valBL - 1.0)) - z2 = z2_wt * (max(zh(I), z_clear) * I_Hbbl(I)) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - hvel(I,k) = (1.0-botfn)*h_arith(I,k) + botfn*h_harm(I,k) - dz_vel(I,k) = (1.0-botfn)*dz_arith(I,k) + botfn*dz_harm(I,k) - endif - endif + ! Force IPO optimizations (e.g. Intel) + ij = touch_ij(i,j) - endif ; enddo ! i loop - enddo ! k loop - endif + do j=js,je ; do I=Isq,Ieq + do_i(I,j) = G%mask2dCu(I,j) > 0. + enddo ; enddo - call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC) - a_cpl_gl90(:,:) = 0.0 - if (CS%use_GL90_in_SSW) then - ! The following block calculates the normalized height above the GL90 - ! BBL (z_i_gl90), using a harmonic mean between layer thicknesses. For the - ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the GL90 - ! coupling coefficient is zeroed out within Hbbl_gl90, to ensure that - ! no momentum gets fluxed into vanished layers. The scheme is not - ! sensitive to the exact value of Hbbl_gl90, as long as it is in a - ! reasonable range (~1-20 m): large enough to capture vanished layers - ! over topography, small enough to not contaminate the interior. - do I=Isq,Ieq ; z_i_gl90(I,nz+1) = 0.0 ; enddo - do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - z_i_gl90(I,k) = z_i_gl90(I,k+1) + dz_harm(I,k)*I_Hbbl_gl90(I) - endif ; enddo ; enddo ! i & k loops - call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.true.) - endif + if (CS%bottomdraglaw) then + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + kv_bbl(I,j) = visc%Kv_bbl_u(I,j) + bbl_thick(I,j) = visc%bbl_thick_u(I,j) + dz_neglect + I_Hbbl(I,j) = 1. / bbl_thick(I,j) + endif ; enddo ; enddo + endif - if (allocated(hML_u)) then - do i=isq,ieq ; if (do_i(i)) then ; hML_u(I,j) = h_ml(I) ; endif ; enddo - endif + do j=js,je ; do I=Isq,Ieq + Dmin(I,j) = min(G%bathyT(i,j), G%bathyT(i+1,j)) + zi_dir(I,j) = 0 + enddo ; enddo - do_any_shelf = .false. - if (associated(forces%frac_shelf_u)) then - do I=Isq,Ieq - CS%a1_shelf_u(I,j) = 0.0 - do_i_shelf(I) = (do_i(I) .and. forces%frac_shelf_u(I,j) > 0.0) - if (do_i_shelf(I)) do_any_shelf = .true. - enddo - if (do_any_shelf) then - if (CS%harmonic_visc) then - do k=1,nz ; do I=Isq,Ieq - hvel_shelf(I,k) = hvel(I,k) ; dz_vel_shelf(I,k) = dz_vel(I,k) - enddo ; enddo - else ! Find upwind-biased thickness near the surface. - ! Perhaps this needs to be done more carefully, via find_eta. - do I=Isq,Ieq ; if (do_i_shelf(I)) then - zh(I) = 0.0 ; Ztop_min(I) = min(zcol(i), zcol(i+1)) - I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j) + dz_neglect) - endif ; enddo - do k=1,nz - do i=Isq,Ieq+1 ; zcol(i) = zcol(i) - dz(i,j,k) ; enddo - do I=Isq,Ieq ; if (do_i_shelf(I)) then - zh(I) = zh(I) + dz_harm(I,k) - - hvel_shelf(I,k) = hvel(I,k) ; dz_vel_shelf(I,k) = dz_vel(I,k) - if (u(I,j,k) * h_delta(I,k) > 0) then - if (zh(I) * I_HTbl(I) < CS%harm_BL_val) then - hvel_shelf(I,k) = min(hvel(I,k), h_harm(I,k)) - dz_vel_shelf(I,k) = min(dz_vel(I,k), dz_harm(I,k)) - else - z2_wt = 1.0 ; if (zh(I) * I_HTbl(I) < 2.0*CS%harm_BL_val) & - z2_wt = max(0.0, min(1.0, zh(I) * I_HTbl(I) * I_valBL - 1.0)) - z2 = z2_wt * (max(zh(I), Ztop_min(I) - min(zcol(i),zcol(i+1))) * I_HTbl(I)) - topfn = 1.0 / (1.0 + 0.09*z2**6) - hvel_shelf(I,k) = min(hvel(I,k), (1.0-topfn)*h_arith(I,k) + topfn*h_harm(I,k)) - dz_vel_shelf(I,k) = min(dz_vel(I,k), (1.0-topfn)*dz_arith(I,k) + topfn*dz_harm(I,k)) - endif - endif - endif ; enddo - enddo + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then + Dmin(I,j) = G%bathyT(i,j) + zi_dir(I,j) = -1 endif - call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, Ustar_2d, tv, & - work_on_u=.true., OBC=OBC, shelf=.true.) - do I=Isq,Ieq ; if (do_i_shelf(I)) CS%a1_shelf_u(I,j) = a_shelf(I,1) ; enddo - endif - endif - - if (do_any_shelf) then - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i_shelf(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(I,K) + & - (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) + a_cpl_gl90(I,K)) -! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & -! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) - elseif (do_i(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) - CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) - endif ; enddo ; enddo - do k=1,nz ; do I=Isq,Ieq ; if (do_i_shelf(I)) then - ! Should we instead take the inverse of the average of the inverses? - CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(I,k) + & - (1.0-forces%frac_shelf_u(I,j)) * hvel(I,k) + h_neglect - elseif (do_i(I)) then - CS%h_u(I,j,k) = hvel(I,k) + h_neglect - endif ; enddo ; enddo - else - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) - endif; enddo ; enddo - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then - CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) - endif; enddo ; enddo - do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo - endif - - ! Diagnose total Kv at u-points - if (CS%id_Kv_u > 0) then - do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) enddo ; enddo endif - ! Diagnose GL90 Kv at u-points - if (CS%id_Kv_gl90_u > 0) then - do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) Kv_gl90_u(I,j,k) = 0.5 * (CS%a_u_gl90(I,j,K)+CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) + + if (OBC%u_W_OBCs_on_PE) then + do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Is_W_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then + Dmin(I,j) = G%bathyT(i+1,j) + zi_dir(I,j) = 1 + endif enddo ; enddo endif - enddo + endif + ! The following block calculates the thicknesses at velocity grid points for + ! the vertical viscosity (hvel and dz_vel). Near the bottom an upwind biased + ! thickness is used to control the effect of spurious Montgomery potential + ! gradients at the bottom where nearly massless layers layers ride over the + ! topography. - ! Now work on v-points. - !$OMP parallel do default(private) shared(G,GV,US,CS,tv,OBC,visc,is,ie,Jsq,Jeq,nz,v,h,dz,forces, & - !$OMP Ustar_2d,h_neglect,dz_neglect,dt,I_valBL,hML_v,Kv_v, & - !$OMP a_cpl_max,I_Hbbl_gl90,Kv_gl90_v) & - !$OMP firstprivate(I_Hbbl) - do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo - - if (CS%bottomdraglaw) then ; do i=is,ie - kv_bbl(i) = visc%Kv_bbl_v(i,J) - bbl_thick(i) = visc%bbl_thick_v(i,J) + dz_neglect - if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) - enddo ; endif - - do k=1,nz ; do i=is,ie ; if (do_i(i)) then - h_harm(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / (h(i,j,k)+h(i,j+1,k)+h_neglect) - h_arith(i,k) = 0.5*(h(i,j+1,k)+h(i,j,k)) - h_delta(i,k) = h(i,j+1,k) - h(i,j,k) - dz_harm(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / (dz(i,j,k)+dz(i,j+1,k)+dz_neglect) - dz_arith(i,k) = 0.5*(dz(i,j+1,k)+dz(i,j,k)) - endif ; enddo ; enddo - do i=is,ie - Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) - zi_dir(i) = 0 - enddo + do j=js,je ; do I=Isq,Ieq + z_i(I,j,nz+1) = 0. + enddo ; enddo + + if (.not. CS%harmonic_visc) then + do j=js,je ; do I=Isq,Ieq + zh(I,j) = 0. + enddo ; enddo + + do j=js,je ; do I=Isq,Ieq+1 + zcol(i,j) = -G%bathyT(i,j) + enddo ; enddo + endif + + if (CS%use_GL90_in_SSW) then + do j=js,je ; do I=Isq,Ieq + z_i_gl90(I,j,nz+1) = 0. + enddo ; enddo + endif + + do k=nz,1,-1 + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + h_harm(I,j) = 2. * h(i,j,k) * h(i+1,j,k) / (h(i,j,k) + h(i+1,j,k) + h_neglect) + h_arith(I,j) = 0.5 * (h(i+1,j,k) + h(i,j,k)) + h_delta(I,j) = h(i+1,j,k) - h(i,j,k) + dz_harm(I,j,k) = 2. * dz(i,j,k) * dz(i+1,j,k) / (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) + dz_arith(I,j) = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) + endif ; enddo ; enddo ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then - do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do k=1,nz - h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(i,k) = 0. - dz_harm(I,k) = dz(i,j,k) ; dz_arith(I,k) = dz(i,j,k) - enddo - Dmin(I) = G%bathyT(i,j) - zi_dir(I) = -1 - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do k=1,nz - h_harm(i,k) = h(i,j+1,k) ; h_arith(i,k) = h(i,j+1,k) ; h_delta(i,k) = 0. - dz_harm(i,k) = dz(i,j+1,k) ; dz_arith(i,k) = dz(i,j+1,k) - enddo - Dmin(i) = G%bathyT(i,j+1) - zi_dir(i) = 1 - endif - endif ; enddo - endif ; endif + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then + h_harm(I,j) = h(i,j,k) + h_arith(I,j) = h(i,j,k) + h_delta(I,j) = 0. + dz_harm(I,j,k) = dz(i,j,k) + dz_arith(I,j) = dz(i,j,k) + endif + enddo ; enddo + endif + + if (OBC%u_W_OBCs_on_PE) then + do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then + h_harm(I,j) = h(i+1,j,k) + h_arith(I,j) = h(i+1,j,k) + h_delta(I,j) = 0. + dz_harm(I,j,k) = dz(i+1,j,k) + dz_arith(I,j) = dz(i+1,j,k) + endif + enddo ; enddo + endif + endif -! The following block calculates the thicknesses at velocity -! grid points for the vertical viscosity (hvel). Near the -! bottom an upwind biased thickness is used to control the effect -! of spurious Montgomery potential gradients at the bottom where -! nearly massless layers layers ride over the topography. if (CS%harmonic_visc) then - do i=is,ie ; z_i(i,nz+1) = 0.0 ; enddo - - do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - hvel(i,k) = h_harm(i,k) - dz_vel(i,k) = dz_harm(i,k) - if (v(i,J,k) * h_delta(i,k) < 0) then - z2 = z_i(i,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - hvel(i,k) = (1.0-botfn)*h_harm(i,k) + botfn*h_arith(i,k) - dz_vel(i,k) = (1.0-botfn)*dz_harm(i,k) + botfn*dz_arith(i,k) + ! The following block calculates the thicknesses at velocity grid points + ! for the vertical viscosity (hvel and dz_vel). Near the bottom an + ! upwind biased thickness is used to control the effect of spurious + ! Montgomery potential gradients at the bottom where nearly massless + ! layers ride over the topography. + + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + hvel(I,j,k) = h_harm(I,j) + dz_vel(I,j,k) = dz_harm(I,j,k) + + if (u(I,j,k) * h_delta(I,j) < 0) then + z2 = z_i(I,j,k+1) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + hvel(I,j,k) = (1. - botfn) * h_harm(I,j) + botfn * h_arith(I,j) + dz_vel(I,j,k) = (1. - botfn) * dz_harm(I,j,k) + botfn * dz_arith(I,j) endif - z_i(i,k) = z_i(i,k+1) + dz_harm(i,k)*I_Hbbl(i) - endif ; enddo ; enddo ! i & k loops - else ! Not harmonic_visc - do i=is,ie - zh(i) = 0.0 ; z_i(i,nz+1) = 0.0 - zcol1(i) = -G%bathyT(i,j) - zcol2(i) = -G%bathyT(i,j+1) - enddo - do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - zh(i) = zh(i) + dz_harm(i,k) - zcol1(i) = zcol1(i) + dz(i,j,k) ; zcol2(i) = zcol2(i) + dz(i,j+1,k) - - z_clear = max(zcol1(i),zcol2(i)) + Dmin(i) - if (zi_dir(i) < 0) z_clear = zcol1(i) + Dmin(I) - if (zi_dir(i) > 0) z_clear = zcol2(i) + Dmin(I) - - z_i(I,k) = max(zh(i), z_clear) * I_Hbbl(i) - - hvel(i,k) = h_arith(i,k) - dz_vel(i,k) = dz_arith(i,k) - if (v(i,J,k) * h_delta(i,k) > 0) then - if (zh(i) * I_Hbbl(i) < CS%harm_BL_val) then - hvel(i,k) = h_harm(i,k) - dz_vel(i,k) = dz_harm(i,k) + + z_i(I,j,k) = z_i(I,j,k+1) + dz_harm(I,j,k) * I_Hbbl(I,j) + endif ; enddo ; enddo + else + do j=js,je ; do I=Isq,Ieq+1 + zcol(i,j) = zcol(i,j) + dz(i,j,k) + enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + zh(I,j) = zh(I,j) + dz_harm(I,j,k) + + z_clear = max(zcol(i,j),zcol(i+1,j)) + Dmin(I,j) + if (zi_dir(I,j) < 0) z_clear = zcol(i,j) + Dmin(I,j) + if (zi_dir(I,j) > 0) z_clear = zcol(i+1,j) + Dmin(I,j) + + z_i(I,j,k) = max(zh(I,j), z_clear) * I_Hbbl(I,j) + + hvel(I,j,k) = h_arith(I,j) + dz_vel(I,j,k) = dz_arith(I,j) + + if (u(I,j,k) * h_delta(I,j) > 0.) then + if (zh(I,j) * I_Hbbl(I,j) < CS%harm_BL_val) then + hvel(I,j,k) = h_harm(I,j) + dz_vel(I,j,k) = dz_harm(I,j,k) else - z2_wt = 1.0 ; if (zh(i) * I_Hbbl(i) < 2.0*CS%harm_BL_val) & - z2_wt = max(0.0, min(1.0, zh(i) * I_Hbbl(i) * I_valBL - 1.0)) - z2 = z2_wt * (max(zh(i), max(zcol1(i),zcol2(i)) + Dmin(i)) * I_Hbbl(i)) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - hvel(i,k) = (1.0-botfn)*h_arith(i,k) + botfn*h_harm(i,k) - dz_vel(i,k) = (1.0-botfn)*dz_arith(i,k) + botfn*dz_harm(i,k) + z2_wt = 1. + if (zh(I,j) * I_Hbbl(I,j) < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh(I,j) * I_Hbbl(I,j) * I_valBL - 1.)) + + z2 = z2_wt * (max(zh(I,j), z_clear) * I_Hbbl(I,j)) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + hvel(I,j,k) = (1. - botfn) * h_arith(I,j) + botfn * h_harm(I,j) + dz_vel(I,j,k) = (1. - botfn) * dz_arith(I,j) + botfn * dz_harm(I,j,k) endif endif - - endif ; enddo ; enddo ! i & k loops + endif ; enddo ; enddo endif - call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC) - a_cpl_gl90(:,:) = 0.0 if (CS%use_GL90_in_SSW) then - ! The following block calculates the normalized height above the GL90 - ! BBL (z_i_gl90), using a harmonic mean between layer thicknesses. For the - ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the GL90 - ! coupling coefficient is zeroed out within Hbbl_gl90, to ensure that - ! no momentum gets fluxed into vanished layers. The scheme is not - ! sensitive to the exact value of Hbbl_gl90, as long as it is in a - ! reasonable range (~1-20 m): large enough to capture vanished layers - ! over topography, small enough to not contaminate the interior. - do i=is,ie ; z_i_gl90(i,nz+1) = 0.0 ; enddo - - do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - z_i_gl90(i,k) = z_i_gl90(i,k+1) + dz_harm(i,k)*I_Hbbl_gl90(i) - endif ; enddo ; enddo ! i & k loops - - call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.false.) + ! The following block calculates the normalized height above the GL90 BBL + ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the + ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure + ! that no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + z_i_gl90(I,j,k) = z_i_gl90(I,j,k+1) + dz_harm(I,j,k) * I_Hbbl_gl90(I,j) + endif ; enddo ; enddo endif + enddo - if ( allocated(hML_v)) then - do i=is,ie ; if (do_i(i)) then ; hML_v(i,J) = h_ml(i) ; endif ; enddo - endif - do_any_shelf = .false. - if (associated(forces%frac_shelf_v)) then - do i=is,ie - CS%a1_shelf_v(i,J) = 0.0 - do_i_shelf(i) = (do_i(i) .and. forces%frac_shelf_v(i,J) > 0.0) - if (do_i_shelf(I)) do_any_shelf = .true. - enddo - if (do_any_shelf) then + call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, & + h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC) + + if (allocated(hML_u)) then + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + hML_u(I,j) = h_ml(I,j) + endif ; enddo ; enddo + endif + + if (CS%use_GL90_in_SSW) then + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, G, GV, & + CS, VarMix, work_on_u=.true.) + endif + + do_any_shelf = .false. + if (associated(forces%frac_shelf_u)) then + do j=js,je ; do I=Isq,Ieq + CS%a1_shelf_u(I,j) = 0. + do_i_shelf(I,j) = do_i(I,j) .and. forces%frac_shelf_u(I,j) > 0. + enddo ; enddo + do_any_shelf = any(do_i_shelf) + + if (do_any_shelf) then + if (.not. CS%harmonic_visc) then + do j=js,je ; do I=Isq,Ieq ; if (do_i_shelf(I,j)) then + zh(I,j) = 0. + Ztop_min(I,j) = min(zcol(i,j), zcol(i+1,j)) + I_HTbl(I,j) = 1. / (visc%tbl_thick_shelf_u(I,j) + dz_neglect) + endif ; enddo ; enddo + endif + + do k=1,nz if (CS%harmonic_visc) then - do k=1,nz ; do i=is,ie - hvel_shelf(i,k) = hvel(i,k) ; dz_vel_shelf(i,k) = dz_vel(i,k) + do j=js,je ; do I=Isq,Ieq + hvel_shelf(I,j,k) = hvel(I,j,k) + dz_vel_shelf(I,j,k) = dz_vel(I,j,k) enddo ; enddo - else ! Find upwind-biased thickness near the surface. - ! Perhaps this needs to be done more carefully, via find_eta. - do i=is,ie ; if (do_i_shelf(i)) then - zh(i) = 0.0 ; Ztop_min(I) = min(zcol1(i), zcol2(i)) - I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J) + dz_neglect) - endif ; enddo - do k=1,nz - do i=is,ie ; if (do_i_shelf(i)) then - zcol1(i) = zcol1(i) - dz(i,j,k) ; zcol2(i) = zcol2(i) - dz(i,j+1,k) - zh(i) = zh(i) + dz_harm(i,k) - - hvel_shelf(i,k) = hvel(i,k) ; dz_vel_shelf(i,k) = dz_vel(i,k) - if (v(i,J,k) * h_delta(i,k) > 0) then - if (zh(i) * I_HTbl(i) < CS%harm_BL_val) then - hvel_shelf(i,k) = min(hvel(i,k), h_harm(i,k)) - dz_vel_shelf(i,k) = min(dz_vel(i,k), dz_harm(i,k)) - else - z2_wt = 1.0 ; if (zh(i) * I_HTbl(i) < 2.0*CS%harm_BL_val) & - z2_wt = max(0.0, min(1.0, zh(i) * I_HTbl(i) * I_valBL - 1.0)) - z2 = z2_wt * (max(zh(i), Ztop_min(i) - min(zcol1(i),zcol2(i))) * I_HTbl(i)) - topfn = 1.0 / (1.0 + 0.09*z2**6) - hvel_shelf(i,k) = min(hvel(i,k), (1.0-topfn)*h_arith(i,k) + topfn*h_harm(i,k)) - dz_vel_shelf(i,k) = min(dz_vel(i,k), (1.0-topfn)*dz_arith(i,k) + topfn*dz_harm(i,k)) + else + ! Find upwind-biased thickness near the surface. + ! (Perhaps this needs to be done more carefully, via find_eta.) + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + h_harm(I,j) = 2. * h(i,j,k) * h(i+1,j,k) & + / (h(i,j,k) + h(i+1,j,k) + h_neglect) + h_arith(I,j) = 0.5 * (h(i+1,j,k) + h(i,j,k)) + h_delta(I,j) = h(i+1,j,k) - h(i,j,k) + dz_arith(I,j) = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) + endif ; enddo ; enddo + + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then + h_harm(I,j) = h(i,j,k) + h_arith(I,j) = h(i,j,k) + h_delta(I,j) = 0. + dz_arith(I,j) = dz(i,j,k) endif - endif - endif ; enddo - enddo + enddo ; enddo + endif + + if (OBC%u_W_OBCs_on_PE) then + do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then + h_harm(I,j) = h(i+1,j,k) + h_arith(I,j) = h(i+1,j,k) + h_delta(I,j) = 0. + dz_arith(I,j) = dz(i+1,j,k) + endif + enddo ; enddo + endif + endif + + do j=js,je ; do i=Isq,Ieq+1 + zcol(i,j) = zcol(i,j) - dz(i,j,k) + enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (do_i_shelf(I,j)) then + zh(I,j) = zh(I,j) + dz_harm(I,j,k) + + hvel_shelf(I,j,k) = hvel(I,j,k) + dz_vel_shelf(I,j,k) = dz_vel(I,j,k) + + if (u(I,j,k) * h_delta(I,j) > 0) then + if (zh(I,j) * I_HTbl(I,j) < CS%harm_BL_val) then + hvel_shelf(I,j,k) = min(hvel(I,j,k), h_harm(I,j)) + dz_vel_shelf(I,j,k) = min(dz_vel(I,j,k), dz_harm(I,j,k)) + else + z2_wt = 1. + if (zh(I,j) * I_HTbl(I,j) < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh(I,j) * I_HTbl(I,j) * I_valBL - 1.)) + + z2 = z2_wt * (max(zh(I,j), Ztop_min(I,j) - min(zcol(i,j),zcol(i+1,j))) * I_HTbl(I,j)) + topfn = 1. / (1. + 0.09 * z2**6) + + h_arith(I,j) = 0.5 * (h(i+1,j,k) + h(i,j,k)) + dz_arith(I,j) = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) + + hvel_shelf(I,j,k) = min(hvel(I,j,k), (1. - topfn) * h_arith(I,j) + topfn * h_harm(I,j)) + dz_vel_shelf(I,j,k) = min(dz_vel(I,j,k), (1. - topfn) * dz_arith(I,j) + topfn * dz_harm(I,j,k)) + endif + endif + endif ; enddo ; enddo + endif + enddo + + call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, & + bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, & + tv, work_on_u=.true., OBC=OBC, shelf=.true.) + + do j=js,je ; do I=Isq,Ieq ; if (do_i_shelf(I,j)) then + CS%a1_shelf_u(I,j) = a_shelf(I,j,1) + endif ; enddo ; enddo + endif + endif + + if (do_any_shelf) then + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + do j=js,je ; do I=Isq,Ieq + if (do_i_shelf(I,j)) then + CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(I,j,K) + & + (1. - forces%frac_shelf_u(I,j)) * a_cpl(I,j,K)) + a_cpl_gl90(I,j,K)) + + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,j,K), a_cpl(I,j,K)) + & + ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(I,j,K)) + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,j,K)) + elseif (do_i(I,j)) then + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,j,K) + a_cpl_gl90(I,j,K)) + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,j,K)) + endif + enddo ; enddo + enddo + else + do K=1,nz+1 + do j=js,je ; do I=Isq,Ieq + if (do_i_shelf(I,j)) then + CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(I,j,K) + & + (1. - forces%frac_shelf_u(I,j)) * a_cpl(I,j,K))) + + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,j,K), a_cpl(I,j,K)) + & + ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(I,j,K)) + elseif (do_i(I,j)) then + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,j,K)) + endif + enddo ; enddo + enddo + endif + + do k=1,nz + do j=js,je ; do I=Isq,Ieq + if (do_i_shelf(I,j)) then + ! Should we instead take the inverse of the average of the inverses? + CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(I,j,k) & + + (1. - forces%frac_shelf_u(I,j)) * hvel(I,j,k) + h_neglect + elseif (do_i(I,j)) then + CS%h_u(I,j,k) = hvel(I,j,k) + h_neglect + endif + enddo ; enddo + enddo + else + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + a_cpl(I,j,K) = a_cpl(I,j,K) + a_cpl_gl90(I,j,K) + endif; enddo ; enddo + enddo + + do K=1,nz+1 + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,j,K)) + endif; enddo ; enddo + enddo + endif + + do K=1,nz+1 + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,j,K)) + endif; enddo ; enddo + enddo + + do k=1,nz + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + CS%h_u(I,j,k) = hvel(I,j,k) + h_neglect + endif; enddo ; enddo + enddo + endif + + ! Diagnose total Kv at u-points + if (CS%id_Kv_u > 0) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K) + CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) + endif ; enddo ; enddo + enddo + endif + + ! Diagnose GL90 Kv at u-points + if (CS%id_Kv_gl90_u > 0) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + Kv_gl90_u(I,j,k) = 0.5 * (CS%a_u_gl90(I,j,K) + CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) + endif ; enddo ; enddo + enddo + endif + + ! Now work on v-points. + + ! Force IPO optimizations (e.g. Intel) + ij = touch_ij(i,j) + + do J=Jsq,Jeq ; do i=is,ie + do_i(i,J) = G%mask2dCv(i,J) > 0. + enddo ; enddo + + if (CS%bottomdraglaw) then + do J=Jsq,Jeq ; do i=is,ie ; if(do_i(i,J)) then + kv_bbl(i,J) = visc%Kv_bbl_v(i,J) + bbl_thick(i,J) = visc%bbl_thick_v(i,J) + dz_neglect + I_Hbbl(i,J) = 1. / bbl_thick(i,J) + endif ; enddo ; enddo + endif + + do J=Jsq,Jeq ; do i=is,ie + Dmin(i,J) = min(G%bathyT(i,j), G%bathyT(i,j+1)) + zi_dir(i,J) = 0 + enddo ; enddo + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then + Dmin(I,J) = G%bathyT(i,j) + zi_dir(I,J) = -1 endif - call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, Ustar_2d, tv, & - work_on_u=.false., OBC=OBC, shelf=.true.) - do i=is,ie ; if (do_i_shelf(i)) CS%a1_shelf_v(i,J) = a_shelf(i,1) ; enddo + enddo ; enddo + endif + + if (OBC%v_S_OBCs_on_PE) then + do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then + Dmin(i,J) = G%bathyT(i,j+1) + zi_dir(i,J) = 1 + endif + enddo ; enddo + endif + endif + + do J=Jsq,Jeq ; do i=is,ie + z_i(i,J,nz+1) = 0. + enddo ; enddo + + if (.not. CS%harmonic_visc) then + do J=Jsq,Jeq ; do i=is,ie + zh(i,J) = 0. + enddo ; enddo + + do J=Jsq,Jeq+1 ; do i=is,ie + zcol(i,j) = -G%bathyT(i,j) + enddo ; enddo + endif + + if (CS%use_GL90_in_SSW) then + do j=Jsq,Jeq ; do i=is,ie + z_i_gl90(i,J,nz+1) = 0. + enddo ; enddo + endif + + do k=nz,1,-1 + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + h_harm(i,J) = 2. * h(i,j,k) * h(i,j+1,k) / (h(i,j,k) + h(i,j+1,k) + h_neglect) + h_arith(i,J) = 0.5 * (h(i,j+1,k) + h(i,j,k)) + h_delta(i,J) = h(i,j+1,k) - h(i,j,k) + dz_harm(i,J,k) = 2. * dz(i,j,k) * dz(i,j+1,k) / (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) + dz_arith(i,J) = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) + endif ; enddo ; enddo + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then + h_harm(i,J) = h(i,j,k) + h_arith(i,J) = h(i,j,k) + h_delta(i,J) = 0. + dz_harm(i,J,k) = dz(i,j,k) + dz_arith(i,J) = dz(i,j,k) + endif + enddo ; enddo + endif + + if (OBC%v_S_OBCs_on_PE) then + do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then + h_harm(i,J) = h(i,j+1,k) + h_arith(i,J) = h(i,j+1,k) + h_delta(i,J) = 0. + dz_harm(i,J,k) = dz(i,j+1,k) + dz_arith(i,J) = dz(i,j+1,k) + endif + enddo ; enddo endif endif - if (do_any_shelf) then - do K=1,nz+1 ; do i=is,ie ; if (do_i_shelf(i)) then - CS%a_v(i,J,K) = min(a_cpl_max, (forces%frac_shelf_v(i,J) * a_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) + a_cpl_gl90(i,K)) -! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & - ! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) - elseif (do_i(i)) then - CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K) + a_cpl_gl90(i,K)) - CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,K)) + if (CS%harmonic_visc) then + ! The following block calculates the thicknesses at velocity grid points + ! for the vertical viscosity (hvel and dz_vel). Near the bottom an + ! upwind biased thickness is used to control the effect of spurious + ! Montgomery potential gradients at the bottom where nearly massless + ! layers ride over the topography. + + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + hvel(i,J,k) = h_harm(i,J) + dz_vel(i,J,k) = dz_harm(i,J,k) + + if (v(i,J,k) * h_delta(i,J) < 0) then + z2 = z_i(i,J,k+1) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + hvel(i,J,k) = (1. - botfn) * h_harm(i,J) + botfn * h_arith(i,J) + dz_vel(i,J,k) = (1. - botfn) * dz_harm(i,J,k) + botfn * dz_arith(i,J) + endif + + z_i(i,J,k) = z_i(i,J,k+1) + dz_harm(i,J,k)*I_Hbbl(i,J) endif ; enddo ; enddo - do k=1,nz ; do i=is,ie ; if (do_i_shelf(i)) then - ! Should we instead take the inverse of the average of the inverses? - CS%h_v(i,J,k) = forces%frac_shelf_v(i,J) * hvel_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * hvel(i,k) + h_neglect - elseif (do_i(i)) then - CS%h_v(i,J,k) = hvel(i,k) + h_neglect + else ! Not harmonic_visc + do J=Jsq,Jeq+1 ; do i=is,ie + zcol(i,j) = zcol(i,j) + dz(i,j,k) + enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + zh(i,J) = zh(i,J) + dz_harm(i,J,k) + + z_clear = max(zcol(i,j), zcol(i,j+1)) + Dmin(i,J) + if (zi_dir(i,J) < 0) z_clear = zcol(i,j) + Dmin(i,J) + if (zi_dir(i,J) > 0) z_clear = zcol(i,j+1) + Dmin(i,J) + + z_i(i,J,k) = max(zh(i,J), z_clear) * I_Hbbl(i,J) + + hvel(i,J,k) = h_arith(i,J) + dz_vel(i,J,k) = dz_arith(i,J) + + if (v(i,J,k) * h_delta(i,J) > 0) then + if (zh(i,J) * I_Hbbl(i,J) < CS%harm_BL_val) then + hvel(i,J,k) = h_harm(i,J) + dz_vel(i,J,k) = dz_harm(i,J,k) + else + z2_wt = 1. + if (zh(i,J) * I_Hbbl(i,J) < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh(i,J) * I_Hbbl(i,J) * I_valBL - 1.)) + + ! TODO: should z_clear be used here? + z2 = z2_wt * (max(zh(i,J), max(zcol(i,j), zcol(i,j+1)) + Dmin(i,J)) * I_Hbbl(i,J)) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + hvel(i,J,k) = (1. - botfn) * h_arith(i,J) + botfn * h_harm(i,J) + dz_vel(i,J,k) = (1. - botfn) * dz_arith(i,J) + botfn * dz_harm(i,J,k) + endif + endif endif ; enddo ; enddo - else - do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) then - CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K) + a_cpl_gl90(i,K)) + endif + + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 BBL + ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the + ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure + ! that no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + z_i_gl90(i,J,k) = z_i_gl90(i,J,k+1) + dz_harm(i,J,k) * I_Hbbl_gl90(i,J) endif ; enddo ; enddo - do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) then - CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,K)) + endif + enddo + + call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, & + h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC) + + if ( allocated(hML_v)) then + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + hML_v(i,J) = h_ml(i,J) + endif ; enddo ; enddo + endif + + if (CS%use_GL90_in_SSW) then + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, G, GV, & + CS, VarMix, work_on_u=.false.) + endif + + do_any_shelf = .false. + if (associated(forces%frac_shelf_v)) then + do J=Jsq,Jeq ; do i=is,ie + CS%a1_shelf_v(i,J) = 0. + do_i_shelf(i,J) = do_i(i,J) .and. forces%frac_shelf_v(i,J) > 0. + enddo ; enddo + do_any_shelf = any(do_i_shelf) + + if (do_any_shelf) then + ! Initialize non-harmonic depths + if (.not. CS%harmonic_visc) then + do J=Jsq,Jeq ; do i=is,ie ; if (do_i_shelf(i,J)) then + zh(i,J) = 0. + Ztop_min(i,J) = min(zcol(i,j), zcol(i,j+1)) + I_HTbl(i,J) = 1. / (visc%tbl_thick_shelf_v(i,J) + dz_neglect) + endif ; enddo ; enddo + endif + + do k=1,nz + if (CS%harmonic_visc) then + do J=Jsq,Jeq ; do i=is,ie + hvel_shelf(i,J,k) = hvel(i,J,k) + dz_vel_shelf(i,J,k) = dz_vel(i,J,k) + enddo ; enddo + else + ! Find upwind-biased thickness near the surface. + ! Perhaps this needs to be done more carefully, via find_eta. + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + h_harm(i,J) = 2. * h(i,j,k) * h(i,j+1,k) & + / (h(i,j,k) + h(i,j+1,k) + h_neglect) + h_arith(i,J) = 0.5 * (h(i,j+1,k) + h(i,j,k)) + h_delta(i,J) = h(i,j+1,k) - h(i,j,k) + dz_arith(i,J) = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) + endif ; enddo ; enddo + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then + h_harm(i,J) = h(i,j,k) + h_arith(i,J) = h(i,j,k) + h_delta(i,J) = 0. + dz_arith(i,J) = dz(i,j,k) + endif + enddo ; enddo + endif + + if (OBC%v_S_OBCs_on_PE) then + do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then + h_harm(i,J) = h(i,j+1,k) + h_arith(i,J) = h(i,j+1,k) + h_delta(i,J) = 0. + dz_arith(i,J) = dz(i,j+1,k) + endif + enddo ; enddo + endif + endif + + do J=Jsq,Jeq+1 ; do i=is,ie + zcol(i,j) = zcol(i,j) - dz(i,j,k) + enddo ; enddo + + do J=Jsq,Jeq ; do i=is,je ; if (do_i_shelf(i,J)) then + zh(i,J) = zh(i,J) + dz_harm(i,J,k) + + hvel_shelf(i,J,k) = hvel(i,J,k) + dz_vel_shelf(i,J,k) = dz_vel(i,J,k) + + if (v(i,J,k) * h_delta(i,J) > 0.) then + if (zh(i,J) * I_HTbl(i,J) < CS%harm_BL_val) then + hvel_shelf(i,J,k) = min(hvel(i,J,k), h_harm(i,J)) + dz_vel_shelf(i,J,k) = min(dz_vel(i,J,k), dz_harm(i,J,k)) + else + z2_wt = 1. + if (zh(i,J) * I_HTbl(i,J) < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh(i,J) * I_HTbl(i,J) * I_valBL - 1.)) + + z2 = z2_wt * (max(zh(i,J), Ztop_min(i,J) - min(zcol(i,j), zcol(i,j+1))) * I_HTbl(i,J)) + topfn = 1. / (1. + 0.09 * z2**6) + + h_arith(i,J) = 0.5 * (h(i,j+1,k) + h(i,j,k)) + dz_arith(i,J) = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) + + hvel_shelf(i,J,k) = min(hvel(i,J,k), (1. - topfn) * h_arith(i,J) + topfn * h_harm(i,J)) + dz_vel_shelf(i,J,k) = min(dz_vel(i,J,k), (1. - topfn) * dz_arith(i,J) + topfn * dz_harm(i,J,k)) + endif + endif + endif ; enddo ; enddo + endif + enddo + + call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, & + bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, & + tv, work_on_u=.false., OBC=OBC, shelf=.true.) + + do J=Jsq,Jeq ; do i=is,ie ; if (do_i_shelf(i,J)) then + CS%a1_shelf_v(i,J) = a_shelf(i,J,1) endif ; enddo ; enddo - do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo endif + endif - ! Diagnose total Kv at v-points - if (CS%id_Kv_v > 0) then - do k=1,nz ; do i=is,ie - if (do_i(I)) Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) - enddo ; enddo + if (do_any_shelf) then + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + do J=Jsq,Jeq ; do i=is,ie + if (do_i_shelf(i,J)) then + CS%a_v(i,J,K) = min(a_cpl_max, (forces%frac_shelf_v(i,J) * a_shelf(i,J,k) + & + (1. - forces%frac_shelf_v(i,J)) * a_cpl(i,J,K)) + a_cpl_gl90(i,J,K)) + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,J,K), a_cpl(i,J,K)) + & + ! (1. - forces%frac_shelf_v(i,J)) * a_cpl(i,J,K)) + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,J,K)) + elseif (do_i(i,J)) then + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,J,K) + a_cpl_gl90(i,J,K)) + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,J,K)) + endif + enddo ; enddo + enddo + else + do K=1,nz+1 + do J=Jsq,Jeq ; do i=is,ie + if (do_i_shelf(i,J)) then + CS%a_v(i,J,K) = min(a_cpl_max, (forces%frac_shelf_v(i,J) * a_shelf(i,J,k) + & + (1. - forces%frac_shelf_v(i,J)) * a_cpl(i,J,K))) + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,J,K), a_cpl(i,J,K)) + & + ! (1. - forces%frac_shelf_v(i,J)) * a_cpl(i,J,K)) + elseif (do_i(i,J)) then + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,J,K)) + endif + enddo ; enddo + enddo endif - ! Diagnose GL90 Kv at v-points - if (CS%id_Kv_gl90_v > 0) then - do k=1,nz ; do i=is,ie - if (do_i(I)) Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) + + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + if (do_i_shelf(i,J)) then + ! Should we instead take the inverse of the average of the inverses? + CS%h_v(i,J,k) = forces%frac_shelf_v(i,J) * hvel_shelf(i,J,k) + & + (1. - forces%frac_shelf_v(i,J)) * hvel(i,J,k) + h_neglect + elseif (do_i(i,J)) then + CS%h_v(i,J,k) = hvel(i,J,k) + h_neglect + endif enddo ; enddo + enddo + else + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + a_cpl(i,J,K) = a_cpl(i,J,K) + a_cpl_gl90(i,J,K) + endif ; enddo ; enddo + enddo + + do K=1,nz+1 + do J=Jsq,Jeq; do i=is,ie ; if (do_i(i,J)) then + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,J,K)) + endif ; enddo ; enddo + enddo endif - enddo ! end of v-point j loop + + do K=1,nz+1 + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,J,K)) + endif ; enddo ; enddo + enddo + + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + CS%h_v(i,J,k) = hvel(i,J,k) + h_neglect + endif; enddo ; enddo + enddo + endif + + ! Diagnose total Kv at v-points + if (CS%id_Kv_v > 0) then + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) + endif ; enddo ; enddo + enddo + endif + + ! Diagnose GL90 Kv at v-points + if (CS%id_Kv_gl90_v > 0) then + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then + Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) + endif ; enddo ; enddo + enddo + endif if (CS%debug) then call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & @@ -1775,34 +2307,34 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, end subroutine vertvisc_coef + !> Calculate the 'coupling coefficient' (a_cpl) at the interfaces. !! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent !! layer thicknesses are used to calculate a_cpl near the bottom. subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf) + dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZK_(GV)+1), & + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & intent(out) :: a_cpl !< Coupling coefficient across interfaces [H T-1 ~> m s-1 or Pa s m-1] - real, dimension(SZIB_(G),SZK_(GV)), & + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), & intent(in) :: hvel !< Distance between interfaces at velocity points [Z ~> m] - logical, dimension(SZIB_(G)), & + logical, dimension(SZIB_(G),SZJB_(G)), & intent(in) :: do_i !< If true, determine coupling coefficient for a column - real, dimension(SZIB_(G),SZK_(GV)), & + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), & intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity !! grid point [Z ~> m] - real, dimension(SZIB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m] - real, dimension(SZIB_(G)), intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m] + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of !! any depth-dependent contributions from !! visc%Kv_shear [H Z T-1 ~> m2 s-1 or Pa s] - real, dimension(SZIB_(G),SZK_(GV)+1), & + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & intent(in) :: z_i !< Estimate of interface heights above the bottom, !! normalized by the bottom boundary layer thickness [nondim] - real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [Z ~> m] - integer, intent(in) :: j !< j-index to find coupling coefficient for + real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: h_ml !< Mixed layer depth [Z ~> m] real, intent(in) :: dt !< Time increment [T ~> s] - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(vertvisc_CS), intent(in) :: CS !< Vertical viscosity control structure type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: Ustar_2d !< The wind friction velocity, calculated using @@ -1819,7 +2351,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Local variables - real, dimension(SZIB_(G)) :: & + real, dimension(SZIB_(G),SZJB_(G)) :: & u_star, & ! ustar at a velocity point [Z T-1 ~> m s-1] tau_mag, & ! The magnitude of the wind stress at a velocity point including gustiness [H Z T-2 ~> m2 s-2 or Pa] absf, & ! The average of the neighboring absolute values of f [T-1 ~> s-1]. @@ -1827,11 +2359,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, z_t, & ! The distance from the top, sometimes normalized ! by Hmix, [Z ~> m] or [nondim]. kv_TBL, & ! The viscosity in a top boundary layer under ice [H Z T-1 ~> m2 s-1 or Pa s] - tbl_thick ! The thickness of the top boundary layer [Z ~> m] - real, dimension(SZIB_(G),SZK_(GV)+1) :: & - Kv_tot, & ! The total viscosity at an interface [H Z T-1 ~> m2 s-1 or Pa s] - Kv_add ! A viscosity to add [H Z T-1 ~> m2 s-1 or Pa s] - integer, dimension(SZIB_(G)) :: & + tbl_thick, &! The thickness of the top boundary layer [Z ~> m] + Kv_add, & ! A viscosity to add [H Z T-1 ~> m2 s-1 or Pa s] + Kv_tot ! The total viscosity at an interface [H Z T-1 ~> m2 s-1 or Pa s] + integer, dimension(SZIB_(G),SZJB_(G)) :: & nk_in_ml ! The index of the deepest interface in the mixed layer. real :: h_shear ! The distance over which shears occur [Z ~> m]. real :: dhc ! The distance between the center of adjacent layers [Z ~> m]. @@ -1852,15 +2383,21 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, real :: topfn ! A function that is 1 at the top and small far from it [nondim] real :: kv_top ! A viscosity associated with the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] logical :: do_shelf, do_OBCs, can_exit - integer :: i, k, is, ie, max_nk - integer :: nz - - a_cpl(:,:) = 0.0 - Kv_tot(:,:) = 0.0 + integer :: i, j, k + integer :: is, ie, js, je + integer :: nz, max_nk + integer :: is_N_OBC, is_S_OBC, Is_E_OBC, Is_W_OBC, ie_N_OBC, ie_S_OBC, Ie_E_OBC, Ie_W_OBC + integer :: js_N_OBC, js_S_OBC, Js_E_OBC, Js_W_OBC, je_N_OBC, je_S_OBC, Je_E_OBC, Je_W_OBC - if (work_on_u) then ; is = G%IscB ; ie = G%IecB - else ; is = G%isc ; ie = G%iec ; endif + if (work_on_u) then + Is = G%IscB ; Ie = G%IecB + js = G%jsc ; je = G%jec + else + is = G%isc ; ie = G%iec + Js = G%JscB ; Je = G%JecB + endif nz = GV%ke + h_neglect = GV%dZ_subroundoff if (CS%answer_date < 20190101) then @@ -1873,143 +2410,194 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif do_shelf = .false. ; if (present(shelf)) do_shelf = shelf + do_OBCs = .false. - if (associated(OBC)) then ; do_OBCS = (OBC%number_of_segments > 0) ; endif - h_ml(:) = 0.0 - - ! This top boundary condition is appropriate when the wind stress is determined - ! externally and does not change within a timestep due to the surface velocity. - do i=is,ie ; Kv_tot(i,1) = 0.0 ; enddo - do K=2,nz+1 ; do i=is,ie - Kv_tot(i,K) = CS%Kv - enddo ; enddo + if (associated(OBC)) then + if (work_on_u) then + do_OBCS = OBC%u_E_OBCs_on_PE .or. OBC%u_W_OBCs_on_PE + Is_E_OBC = max(G%IscB, OBC%Is_u_E_obc) ; Ie_E_OBC = min(G%IecB, OBC%Ie_u_E_obc) + Is_W_OBC = max(G%IscB, OBC%Is_u_W_obc) ; Ie_W_OBC = min(G%IecB, OBC%Ie_u_W_obc) + js_E_OBC = max(G%jsc, OBC%js_u_E_obc) ; je_E_OBC = min(G%jec, OBC%je_u_E_obc) + js_W_OBC = max(G%jsc, OBC%js_u_W_obc) ; je_W_OBC = min(G%jec, OBC%je_u_W_obc) + else + do_OBCS = OBC%v_N_OBCs_on_PE .or. OBC%v_S_OBCs_on_PE + is_N_OBC = max(G%isc, OBC%is_v_N_obc) ; ie_N_OBC = min(G%iec, OBC%ie_v_N_obc) + is_S_OBC = max(G%isc, OBC%is_v_S_obc) ; ie_S_OBC = min(G%iec, OBC%ie_v_S_obc) + Js_N_OBC = max(G%JscB, OBC%Js_v_N_obc) ; Je_N_OBC = min(G%JecB, OBC%Je_v_N_obc) + Js_S_OBC = max(G%JscB, OBC%Js_v_S_obc) ; Je_S_OBC = min(G%JecB, OBC%Je_v_S_obc) + endif + endif - if ((CS%Kvml_invZ2 > 0.0) .and. .not.do_shelf) then - ! This is an older (vintage ~1997) way to prevent wind stresses from driving very - ! large flows in nearly massless near-surface layers when there is not a physically- - ! based surface boundary layer parameterization. It does not have a plausible - ! physical basis, and probably should not be used. - I_Hmix = 1.0 / (CS%Hmix + h_neglect) - do i=is,ie ; z_t(i) = h_neglect*I_Hmix ; enddo - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - z_t(i) = z_t(i) + h_harm(i,k-1)*I_Hmix - Kv_tot(i,K) = CS%Kv + CS%Kvml_invZ2 / ((z_t(i)*z_t(i)) * & - (1.0 + 0.09*z_t(i)*z_t(i)*z_t(i)*z_t(i)*z_t(i)*z_t(i))) - endif ; enddo ; enddo + a_cpl(:,:,:) = 0.0 + h_ml(:,:) = 0. + + if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then + I_Hmix = 1. / (CS%Hmix + h_neglect) + do j=js,je ; do i=is,ie + z_t(i,j) = h_neglect * I_Hmix + enddo ; enddo endif - if (associated(visc%Kv_shear)) then - ! Add in viscosities that are determined by physical processes that are handled in - ! other modules, and which do not respond immediately to the changing layer thicknesses. - ! These processes may include shear-driven mixing or contributions from some boundary - ! layer turbulence schemes. Other viscosity contributions that respond to the evolving - ! layer thicknesses or the surface wind stresses are added later. - if (work_on_u) then - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) + do K=2,nz + do j=js,je ; do i=is,ie + Kv_tot(i,j) = CS%Kv + enddo ; enddo + + if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then + ! This is an older (vintage ~1997) way to prevent wind stresses from driving very + ! large flows in nearly massless near-surface layers when there is not a physically- + ! based surface boundary layer parameterization. It does not have a plausible + ! physical basis, and probably should not be used. + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + z_t(i,j) = z_t(i,j) + h_harm(i,j,k-1) * I_Hmix + Kv_tot(i,j) = CS%Kv + CS%Kvml_invZ2 / ((z_t(i,j)*z_t(i,j)) * & + (1. + 0.09 * z_t(i,j) * z_t(i,j) * z_t(i,j) * z_t(i,j) * z_t(i,j) * z_t(i,j))) endif ; enddo ; enddo - if (do_OBCs) then - do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i+1,j,k) ; enddo + endif + + if (associated(visc%Kv_shear)) then + ! Add in viscosities that are determined by physical processes that are handled in + ! other modules, and which do not respond immediately to the changing layer thicknesses. + ! These processes may include shear-driven mixing or contributions from some boundary + ! layer turbulence schemes. Other viscosity contributions that respond to the evolving + ! layer thicknesses or the surface wind stresses are added later. + if (work_on_u) then + ! FIXME: Uppercase i? + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + Kv_add(i,j) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) + endif ; enddo ; enddo + + if (do_OBCs) then + if (OBC%u_E_OBCs_on_PE) then + do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then + Kv_add(i,j) = visc%Kv_shear(i,j,k) + endif + enddo ; enddo endif - endif ; enddo - endif - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + Kv_add(i,K) - endif ; enddo ; enddo - else - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) - endif ; enddo ; enddo - if (do_OBCs) then - do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j+1,k) ; enddo + + if (OBC%u_W_OBCs_on_PE) then + do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then + Kv_add(i,j) = visc%Kv_shear(i+1,j,k) + endif + enddo ; enddo endif - endif ; enddo + endif + + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + Kv_tot(i,j) = Kv_tot(i,j) + Kv_add(i,j) + endif ; enddo ; enddo + else + ! FIXME: Uppercase j? + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + Kv_add(i,j) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) + endif ; enddo ; enddo + + if (do_OBCs) then + if (OBC%v_N_OBCs_on_PE) then + do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then + Kv_add(i,j) = visc%Kv_shear(i,j,k) + endif + enddo ; enddo + endif + + if (OBC%v_S_OBCs_on_PE) then + do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then + Kv_add(i,j) = visc%Kv_shear(i,j+1,k) + endif + enddo ; enddo + endif + endif + + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + Kv_tot(i,j) = Kv_tot(i,j) + Kv_add(i,j) + endif ; enddo ; enddo endif - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + Kv_add(i,K) - endif ; enddo ; enddo endif - endif - if (associated(visc%Kv_shear_Bu)) then - ! This is similar to what was done above, but for contributions coming from the corner - ! (vorticity) points. Because OBCs run through the faces and corners there is no need - ! to further modify these viscosities here to take OBCs into account. - if (work_on_u) then - do K=2,nz ; do I=Is,Ie ; If (do_i(I)) then - Kv_tot(I,K) = Kv_tot(I,K) + 0.5*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) - endif ; enddo ; enddo + if (associated(visc%Kv_shear_Bu)) then + ! This is similar to what was done above, but for contributions coming from the corner + ! (vorticity) points. Because OBCs run through the faces and corners there is no need + ! to further modify these viscosities here to take OBCs into account. + if (work_on_u) then + do J=Js,Je ; do I=Is,Ie ; If (do_i(i,j)) then + Kv_tot(I,J) = Kv_tot(I,J) + 0.5 * (visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) + endif ; enddo ; enddo + else + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + Kv_tot(i,j) = Kv_tot(i,j) + 0.5 * (visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) + endif ; enddo ; enddo + endif + endif + + ! Set the viscous coupling coefficients, excluding surface mixed layer contributions + ! for now, but including viscous bottom drag, working up from the bottom. + if (CS%bottomdraglaw) then + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + ! botfn determines when a point is within the influence of the bottom + ! boundary layer, going from 1 at the bottom to 0 in the interior. + z2 = z_i(i,j,k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + Kv_tot(i,j) = Kv_tot(i,j) + (kv_bbl(i,j) - CS%Kv)*botfn + dhc = 0.5 * (hvel(i,j,k) + hvel(i,j,k-1)) + if (dhc > bbl_thick(i,j)) then + h_shear = ((1. - botfn) * dhc + botfn*bbl_thick(i,j)) + h_neglect + else + h_shear = dhc + h_neglect + endif + + ! Calculate the coupling coefficients from the viscosities. + a_cpl(i,j,K) = Kv_tot(i,j) / (h_shear + (I_amax * Kv_tot(i,j))) + endif ; enddo ; enddo ! i & k loops + elseif (abs(CS%Kv_extra_bbl) > 0.0) then + ! There is a simple enhancement of the near-bottom viscosities, but no + ! adjustment of the viscous coupling length scales to give a particular + ! bottom stress. + + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + ! botfn determines when a point is within the influence of the bottom + ! boundary layer, going from 1 at the bottom to 0 in the interior. + z2 = z_i(i,j,k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + Kv_tot(i,j) = Kv_tot(i,j) + CS%Kv_extra_bbl*botfn + h_shear = 0.5 * (hvel(i,j,k) + hvel(i,j,k-1) + h_neglect) + + ! Calculate the coupling coefficients from the viscosities. + a_cpl(i,j,K) = Kv_tot(i,j) / (h_shear + I_amax * Kv_tot(i,j)) + endif ; enddo ; enddo ! i & k loops else - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + 0.5*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) - endif ; enddo ; enddo + ! Any near-bottom viscous enhancements were already incorporated into + ! Kv_tot, and there is no adjustment of the viscous coupling length + ! scales to give a particular bottom stress. + + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + h_shear = 0.5*(hvel(i,j,k) + hvel(i,j,k-1) + h_neglect) + ! Calculate the coupling coefficients from the viscosities. + a_cpl(i,j,K) = Kv_tot(i,j) / (h_shear + I_amax*Kv_tot(i,j)) + endif ; enddo ; enddo ! i & k loops endif - endif + enddo - ! Set the viscous coupling coefficients, excluding surface mixed layer contributions - ! for now, but including viscous bottom drag, working up from the bottom. + ! Assign the bottom coupling coefficients if (CS%bottomdraglaw) then - do i=is,ie ; if (do_i(i)) then - 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. - 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 - ! boundary layer, going from 1 at the bottom to 0 in the interior. - z2 = z_i(i,k) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - - Kv_tot(i,K) = Kv_tot(i,K) + (kv_bbl(i) - CS%Kv)*botfn - dhc = 0.5*(hvel(i,k) + hvel(i,k-1)) - if (dhc > bbl_thick(i)) then - h_shear = ((1.0 - botfn) * dhc + botfn*bbl_thick(i)) + h_neglect - else - h_shear = dhc + h_neglect - endif - - ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear + (I_amax * Kv_tot(i,K))) - endif ; enddo ; enddo ! i & k loops + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + dhc = hvel(i,j,nz)*0.5 + a_cpl(i,j,nz+1) = kv_bbl(i,j) / ((min(dhc, bbl_thick(i,j)) + h_neglect) + I_amax*kv_bbl(i,j)) + endif ; enddo ; enddo elseif (abs(CS%Kv_extra_bbl) > 0.0) then - ! There is a simple enhancement of the near-bottom viscosities, but no adjustment - ! of the viscous coupling length scales to give a particular bottom stress. - do i=is,ie ; if (do_i(i)) then - a_cpl(i,nz+1) = (Kv_tot(i,nz+1) + CS%Kv_extra_bbl) / & - ((0.5*hvel(i,nz)+h_neglect) + I_amax*(Kv_tot(i,nz+1)+CS%Kv_extra_bbl)) - 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 - ! boundary layer, going from 1 at the bottom to 0 in the interior. - z2 = z_i(i,k) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - - Kv_tot(i,K) = Kv_tot(i,K) + CS%Kv_extra_bbl*botfn - h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) - - ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) - endif ; enddo ; enddo ! i & k loops + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + a_cpl(i,j,nz+1) = (CS%Kv + CS%Kv_extra_bbl) & + / ((0.5 * hvel(i,j,nz) + h_neglect) + I_amax * (CS%Kv + CS%Kv_extra_bbl)) + endif ; enddo ; enddo else - ! Any near-bottom viscous enhancements were already incorporated into Kv_tot, and there is - ! no adjustment of the viscous coupling length scales to give a particular bottom stress. - do i=is,ie ; if (do_i(i)) then - a_cpl(i,nz+1) = Kv_tot(i,nz+1) / ((0.5*hvel(i,nz)+h_neglect) + I_amax*Kv_tot(i,nz+1)) - endif ; enddo - do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then - h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) - ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) - endif ; enddo ; enddo ! i & k loops + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + a_cpl(i,j,nz+1) = CS%Kv / ((0.5 * hvel(i,j,nz) + h_neglect) + I_amax * CS%Kv) + endif ; enddo ; enddo endif ! Add surface intensified viscous coupling, either as a no-slip boundary condition under a @@ -2017,246 +2605,322 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! already been added via visc%Kv_shear. if (do_shelf) then ! Set the coefficients to include the no-slip surface stress. - do i=is,ie ; if (do_i(i)) then + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then if (work_on_u) then - kv_TBL(i) = visc%Kv_tbl_shelf_u(I,j) - tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) + h_neglect + kv_TBL(i,j) = visc%Kv_tbl_shelf_u(I,j) + tbl_thick(i,j) = visc%tbl_thick_shelf_u(I,j) + h_neglect else - kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J) - tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) + h_neglect + kv_TBL(i,j) = visc%Kv_tbl_shelf_v(i,J) + tbl_thick(i,j) = visc%tbl_thick_shelf_v(i,J) + h_neglect endif - z_t(i) = 0.0 + z_t(i,j) = 0.0 ! If a_cpl(i,1) were not already 0, it would be added here. - if (0.5*hvel(i,1) > tbl_thick(i)) then - a_cpl(i,1) = kv_TBL(i) / (tbl_thick(i) + I_amax*kv_TBL(i)) + if (0.5*hvel(i,j,1) > tbl_thick(i,j)) then + a_cpl(i,j,1) = kv_TBL(i,j) / (tbl_thick(i,j) + I_amax * kv_TBL(i,j)) else - a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect) + I_amax*kv_TBL(i)) + a_cpl(i,j,1) = kv_TBL(i,j) & + / ((0.5 * hvel(i,j,1) + h_neglect) + I_amax * kv_TBL(i,j)) endif - endif ; enddo - - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - z_t(i) = z_t(i) + hvel(i,k-1) / tbl_thick(i) - topfn = 1.0 / (1.0 + 0.09 * z_t(i)**6) + endif ; enddo ; enddo - dhc = 0.5*(hvel(i,k)+hvel(i,k-1)) - if (dhc > tbl_thick(i)) then - h_shear = ((1.0 - topfn) * dhc + topfn*tbl_thick(i)) + h_neglect - else - h_shear = dhc + h_neglect - endif + do K=2,nz + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + z_t(i,j) = z_t(i,j) + hvel(i,j,k-1) / tbl_thick(i,j) + topfn = 1. / (1. + 0.09 * z_t(i,j)**6) - kv_top = topfn * kv_TBL(i) - a_cpl(i,K) = a_cpl(i,K) + kv_top / (h_shear + I_amax*kv_top) - endif ; enddo ; enddo + dhc = 0.5 * (hvel(i,j,k) + hvel(i,j,k-1)) + if (dhc > tbl_thick(i,j)) then + h_shear = ((1. - topfn) * dhc + topfn * tbl_thick(i,j)) + h_neglect + else + h_shear = dhc + h_neglect + endif + kv_top = topfn * kv_TBL(i,j) + a_cpl(i,j,K) = a_cpl(i,j,K) + kv_top / (h_shear + I_amax * kv_top) + endif ; enddo ; enddo + enddo elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then ! Find the friction velocity and the absolute value of the Coriolis parameter at this point. - u_star(:) = 0.0 ! Zero out the friction velocity on land points. - tau_mag(:) = 0.0 ! Zero out the friction velocity on land points. + u_star(:,:) = 0.0 ! Zero out the friction velocity on land points. + tau_mag(:,:) = 0.0 ! Zero out the friction velocity on land points. if (allocated(tv%SpV_avg)) then - rho_av1(:) = 0.0 + rho_av1(:,:) = 0.0 + if (work_on_u) then - do I=is,ie ; if (do_i(I)) then - u_star(I) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) - rho_av1(I) = 2.0 / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1)) - absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - endif ; enddo - if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - u_star(I) = Ustar_2d(i,j) - rho_av1(I) = 1.0 / tv%SpV_avg(i,j,1) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - u_star(I) = Ustar_2d(i+1,j) - rho_av1(I) = 1.0 / tv%SpV_avg(i+1,j,1) + do j=js,je ; do I=is,ie ; if (do_i(i,j)) then + u_star(I,j) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + rho_av1(I,j) = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1)) + absf(I,j) = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + endif ; enddo ; enddo + + if (do_OBCs) then + if (OBC%u_E_OBCs_on_PE) then + do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then + u_star(I,j) = Ustar_2d(i,j) + rho_av1(I,j) = 1. / tv%SpV_avg(i,j,1) + endif + enddo ; enddo endif - endif ; enddo ; endif - else ! Work on v-points - do i=is,ie ; if (do_i(i)) then - u_star(i) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) - rho_av1(i) = 2.0 / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1)) - absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - endif ; enddo - if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - u_star(i) = Ustar_2d(i,j) - rho_av1(i) = 1.0 / tv%SpV_avg(i,j,1) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - u_star(i) = Ustar_2d(i,j+1) - rho_av1(i) = 1.0 / tv%SpV_avg(i,j+1,1) + + if (OBC%u_W_OBCs_on_PE) then + do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then + u_star(I,j) = Ustar_2d(i+1,j) + rho_av1(I,j) = 1. / tv%SpV_avg(i+1,j,1) + endif + enddo ; enddo endif - endif ; enddo ; endif + endif + else + do J=Js,Je ; do i=is,ie ; if (do_i(i,J)) then + u_star(i,J) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + rho_av1(i,J) = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1)) + absf(i,J) = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + endif ; enddo ; enddo + + if (do_OBCs) then + if (OBC%v_N_OBCs_on_PE) then + do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_obc + if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then + u_star(i,J) = Ustar_2d(i,j) + rho_av1(i,J) = 1. / tv%SpV_avg(i,j,1) + endif + enddo ; enddo + endif + + if (OBC%v_S_OBCs_on_PE) then + do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_obc + if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then + u_star(i,J) = Ustar_2d(i,j+1) + rho_av1(i,J) = 1. / tv%SpV_avg(i,j+1,1) + endif + enddo ; enddo + endif + endif endif - do I=is,ie - tau_mag(I) = GV%RZ_to_H*rho_av1(i) * u_star(I)**2 - enddo + + do J=Js,Je ; do I=is,ie + tau_mag(I,J) = GV%RZ_to_H * rho_av1(i,j) * u_star(I,J)**2 + enddo ; enddo else ! (.not.allocated(tv%SpV_avg)) if (work_on_u) then - do I=is,ie ; if (do_i(I)) then - u_star(I) = 0.5*(Ustar_2d(i,j) + Ustar_2d(i+1,j)) - absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - endif ; enddo - if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) & - u_star(I) = Ustar_2d(i,j) - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) & - u_star(I) = Ustar_2d(i+1,j) - endif ; enddo ; endif + do j=js,je ; do I=is,ie ; if (do_i(I,j)) then + u_star(I,j) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + absf(I,j) = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + endif ; enddo ; enddo + + if (do_OBCs) then + if (OBC%u_E_OBCs_on_PE) then + do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then + u_star(I,j) = Ustar_2d(i,j) + endif + enddo ; enddo + endif + + if (OBC%u_W_OBCs_on_PE) then + do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC + if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then + u_star(I,j) = Ustar_2d(i+1,j) + endif + enddo ; enddo + endif + endif else - do i=is,ie ; if (do_i(i)) then - u_star(i) = 0.5*(Ustar_2d(i,j) + Ustar_2d(i,j+1)) - absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - endif ; enddo - if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) & - u_star(i) = Ustar_2d(i,j) - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) & - u_star(i) = Ustar_2d(i,j+1) - endif ; enddo ; endif + do J=Js,Je ; do i=is,ie ; if (do_i(i,J)) then + u_star(i,J) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + absf(i,J) = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + endif ; enddo ; enddo + + if (do_OBCs) then + if (OBC%v_N_OBCs_on_PE) then + do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then + u_star(i,J) = Ustar_2d(i,j) + endif + enddo ; enddo + endif + + if (OBC%v_S_OBCs_on_PE) then + do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC + if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then + u_star(i,J) = Ustar_2d(i,j+1) + endif + enddo ; enddo + endif + endif endif - do I=is,ie - tau_mag(I) = GV%Z_to_H*u_star(I)**2 - enddo + do J=Js,Je ; do I=is,ie + tau_mag(I,J) = GV%Z_to_H*u_star(I,J)**2 + enddo ; enddo endif ! Determine the thickness of the surface ocean boundary layer and its extent in index space. - nk_in_ml(:) = 0 + nk_in_ml(:,:) = 0 if (CS%dynamic_viscous_ML) then ! The fractional number of layers that are within the viscous boundary layer were ! previously stored in visc%nkml_visc_[uv]. - h_ml(:) = h_neglect + h_ml(:,:) = h_neglect max_nk = 0 if (work_on_u) then - do i=is,ie ; if (do_i(i)) then - nk_in_ml(I) = ceiling(visc%nkml_visc_u(I,j)) - max_nk = max(max_nk, nk_in_ml(I)) - endif ; enddo - do k=1,max_nk ; do i=is,ie ; if (do_i(i)) then - if (k <= visc%nkml_visc_u(I,j)) then ! This layer is all in the ML. - h_ml(i) = h_ml(i) + hvel(i,k) - elseif (k < visc%nkml_visc_u(I,j) + 1.0) then ! Part of this layer is in the ML. - h_ml(i) = h_ml(i) + ((visc%nkml_visc_u(I,j) + 1.0) - k) * hvel(i,k) - endif + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + nk_in_ml(I,j) = ceiling(visc%nkml_visc_u(I,j)) + max_nk = max(max_nk, nk_in_ml(I,j)) endif ; enddo ; enddo + + do k=1,max_nk + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + if (k <= visc%nkml_visc_u(I,j)) then ! This layer is all in the ML. + h_ml(i,j) = h_ml(i,j) + hvel(i,j,k) + elseif (k < visc%nkml_visc_u(I,j) + 1.) then ! Part of this layer is in the ML. + h_ml(i,j) = h_ml(i,j) + ((visc%nkml_visc_u(I,j) + 1.) - k) * hvel(i,j,k) + endif + endif ; enddo ; enddo + enddo else - do i=is,ie ; if (do_i(i)) then - nk_in_ml(i) = ceiling(visc%nkml_visc_v(i,J)) - max_nk = max(max_nk, nk_in_ml(i)) - endif ; enddo - do k=1,max_nk ; do i=is,ie ; if (do_i(i)) then - if (k <= visc%nkml_visc_v(i,J)) then ! This layer is all in the ML. - h_ml(i) = h_ml(i) + hvel(i,k) - elseif (k < visc%nkml_visc_v(i,J) + 1.0) then ! Part of this layer is in the ML. - h_ml(i) = h_ml(i) + ((visc%nkml_visc_v(i,J) + 1.0) - k) * hvel(i,k) - endif + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + nk_in_ml(i,j) = ceiling(visc%nkml_visc_v(i,J)) + max_nk = max(max_nk, nk_in_ml(i,j)) endif ; enddo ; enddo - endif + do k=1,max_nk + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + if (k <= visc%nkml_visc_v(i,J)) then ! This layer is all in the ML. + h_ml(i,j) = h_ml(i,j) + hvel(i,j,k) + elseif (k < visc%nkml_visc_v(i,J) + 1.) then ! Part of this layer is in the ML. + h_ml(i,j) = h_ml(i,j) + ((visc%nkml_visc_v(i,J) + 1.) - k) * hvel(i,j,k) + endif + endif ; enddo ; enddo + enddo + endif elseif (GV%nkml>0) then ! This is a simple application of a refined-bulk mixed layer with GV%nkml sublayers. max_nk = GV%nkml - do i=is,ie ; if (do_i(i)) then - nk_in_ml(i) = GV%nkml - endif ; enddo - - h_ml(:) = h_neglect - do k=1,GV%nkml ; do i=is,ie ; if (do_i(i)) then - h_ml(i) = h_ml(i) + hvel(i,k) + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + nk_in_ml(i,j) = GV%nkml endif ; enddo ; enddo + + h_ml(:,:) = h_neglect + + do k=1,GV%nkml + do j=js,je ; do i=is,ie ; if (do_i(i,j)) then + h_ml(i,j) = h_ml(i,j) + hvel(i,j,k) + endif ; enddo ; enddo + enddo elseif (CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then ! Determine which interfaces are within CS%Hmix of the surface, and set the viscous ! boundary layer thickness to the the smaller of CS%Hmix and the depth of the ocean. - h_ml(:) = 0.0 + h_ml(:,:) = 0.0 do k=1,nz can_exit = .true. - do i=is,ie ; if (do_i(i) .and. (h_ml(i) < CS%Hmix)) then - nk_in_ml(i) = k - if (h_ml(i) + hvel(i,k) < CS%Hmix) then - h_ml(i) = h_ml(i) + hvel(i,k) + do j=js,je ; do i=is,ie ; if (do_i(i,j) .and. (h_ml(i,j) < CS%Hmix)) then + nk_in_ml(i,j) = k + + if (h_ml(i,j) + hvel(i,j,k) < CS%Hmix) then + h_ml(i,j) = h_ml(i,j) + hvel(i,j,k) can_exit = .false. ! Part of the next deeper layer is also in the mixed layer. else - h_ml(i) = CS%Hmix + h_ml(i,j) = CS%Hmix endif - endif ; enddo + endif ; enddo ; enddo + if (can_exit) exit ! All remaining layers in this row are below the mixed layer depth. enddo + max_nk = 0 - do i=is,ie ; max_nk = max(max_nk, nk_in_ml(i)) ; enddo + do j=js,je ; do i=is,ie + max_nk = max(max_nk, nk_in_ml(i,j)) + enddo ; enddo endif ! Avoid working on land or on columns where the viscous coupling could not be increased. - do i=is,ie ; if ((u_star(i)<=0.0) .or. (.not.do_i(i))) nk_in_ml(i) = 0 ; enddo + do j=js,je ; do i=is,ie ; if ((u_star(i,j)<=0.0) .or. (.not.do_i(i,j))) then + nk_in_ml(i,j) = 0 + endif ; enddo ; enddo ! Set the viscous coupling at the interfaces as the larger of what was previously ! set and the contributions from the surface boundary layer. - z_t(:) = 0.0 + z_t(:,:) = 0.0 if (CS%apply_LOTW_floor .and. & (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML)) then - do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then - z_t(i) = z_t(i) + hvel(i,k-1) - - ! The viscosity in visc_ml is set to go to 0 at the mixed layer top and bottom - ! (in a log-layer) and be further limited by rotation to give the natural Ekman length. - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) - if (GV%Boussinesq) then - ustar2_denom = (CS%vonKar * GV%Z_to_H*u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) - else - ustar2_denom = (CS%vonKar * tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) - endif - visc_ml = temp1 * ustar2_denom - ! Set the viscous coupling based on the model's vertical resolution. The omission of - ! the I_amax factor here is consistent with answer dates above 20190101. - a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect)) - - ! As a floor on the viscous coupling, assume that the length scale in the denominator can - ! not be larger than the distance from the surface, consistent with a logarithmic velocity - ! profile. This is consistent with visc_ml, but cancels out common factors of z_t. - a_floor = (h_ml(i) - z_t(i)) * ustar2_denom - - ! Choose the largest estimate of a_cpl. - a_cpl(i,K) = max(a_cpl(i,K), a_ml, a_floor) - ! An option could be added to change this to: a_cpl(i,K) = max(a_cpl(i,K) + a_ml, a_floor) - endif ; enddo ; enddo - elseif (CS%apply_LOTW_floor) then - do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then - z_t(i) = z_t(i) + hvel(i,k-1) + do K=2,max_nk + do j=js,je ; do i=is,ie ; if (k <= nk_in_ml(i,j)) then + z_t(i,j) = z_t(i,j) + hvel(i,j,k-1) + + ! The viscosity in visc_ml is set to go to 0 at the mixed layer top and bottom + ! (in a log-layer) and be further limited by rotation to give the natural Ekman length. + temp1 = (z_t(i,j)*h_ml(i,j) - z_t(i,j)*z_t(i,j)) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star(i,j)**2) & + / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + else + ustar2_denom = (CS%vonKar * tau_mag(i,j)) & + / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + endif - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) - if (GV%Boussinesq) then - ustar2_denom = (CS%vonKar * GV%Z_to_H*u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) - else - ustar2_denom = (CS%vonKar * tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) - endif + visc_ml = temp1 * ustar2_denom + ! Set the viscous coupling based on the model's vertical resolution. The omission of + ! the I_amax factor here is consistent with answer dates above 20190101. + a_ml = visc_ml / (0.25 * (hvel(i,j,k) + hvel(i,j,k-1) + h_neglect)) - ! As a floor on the viscous coupling, assume that the length scale in the denominator can not - ! be larger than the distance from the surface, consistent with a logarithmic velocity profile. - a_cpl(i,K) = max(a_cpl(i,K), (h_ml(i) - z_t(i)) * ustar2_denom) - endif ; enddo ; enddo + ! As a floor on the viscous coupling, assume that the length scale in the denominator can + ! not be larger than the distance from the surface, consistent with a logarithmic velocity + ! profile. This is consistent with visc_ml, but cancels out common factors of z_t. + a_floor = (h_ml(i,j) - z_t(i,j)) * ustar2_denom + + ! Choose the largest estimate of a_cpl. + a_cpl(i,j,K) = max(a_cpl(i,j,K), a_ml, a_floor) + ! An option could be added to change this to: a_cpl(i,K) = max(a_cpl(i,K) + a_ml, a_floor) + endif ; enddo ; enddo + enddo + elseif (CS%apply_LOTW_floor) then + do K=2,max_nk + do j=js,je ; do i=is,ie ; if (k <= nk_in_ml(i,j)) then + z_t(i,j) = z_t(i,j) + hvel(i,j,k-1) + + temp1 = (z_t(i,j)*h_ml(i,j) - z_t(i,j) * z_t(i,j)) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star(i,j)**2) & + / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + else + ustar2_denom = (CS%vonKar * tau_mag(i,j)) & + / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + endif + + ! As a floor on the viscous coupling, assume that the length scale in the denominator can not + ! be larger than the distance from the surface, consistent with a logarithmic velocity profile. + a_cpl(i,j,K) = max(a_cpl(i,j,K), (h_ml(i,j) - z_t(i,j)) * ustar2_denom) + endif ; enddo ; enddo + enddo else - do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then - z_t(i) = z_t(i) + hvel(i,k-1) - - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) - ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) - ! and be further limited by rotation to give the natural Ekman length. - ! The following expressions are mathematically equivalent. - if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then - visc_ml = u_star(i) * CS%vonKar * (GV%Z_to_H*temp1*u_star(i)) / & - (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) - else - visc_ml = CS%vonKar * (temp1*tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) - endif - a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) + 0.5*I_amax*visc_ml) + do K=2,max_nk + do j=js,je ; do i=is,ie ; if (k <= nk_in_ml(i,j)) then + z_t(i,j) = z_t(i,j) + hvel(i,j,k-1) + + temp1 = (z_t(i,j) * h_ml(i,j) - z_t(i,j) * z_t(i,j)) + ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) + ! and be further limited by rotation to give the natural Ekman length. + ! The following expressions are mathematically equivalent. + if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then + visc_ml = u_star(i,j) * CS%vonKar * (GV%Z_to_H * temp1 * u_star(i,j)) & + / (absf(i,j) * temp1 + (h_ml(i,j)+h_neglect) * u_star(i,j)) + else + visc_ml = CS%vonKar * (temp1 * tau_mag(i,j)) & + / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + endif + a_ml = visc_ml / (0.25 * (hvel(i,j,k) + hvel(i,j,k-1) + h_neglect) + 0.5 * I_amax * visc_ml) - ! Choose the largest estimate of a_cpl, but these could be changed to be additive. - a_cpl(i,K) = max(a_cpl(i,K), a_ml) - ! An option could be added to change this to: a_cpl(i,K) = a_cpl(i,K) + a_ml - endif ; enddo ; enddo + ! Choose the largest estimate of a_cpl, but these could be changed to be additive. + a_cpl(i,j,K) = max(a_cpl(i,j,K), a_ml) + ! An option could be added to change this to: a_cpl(i,K) = a_cpl(i,K) + a_ml + endif ; enddo ; enddo + enddo endif endif - end subroutine find_coupling_coef !> Velocity components which exceed a threshold for physically reasonable values diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90 index 34899ab890..847a174d36 100644 --- a/src/tracer/MARBL_tracers.F90 +++ b/src/tracer/MARBL_tracers.F90 @@ -1502,7 +1502,7 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, do m=1,CS%ntr call hchksum(CS%STF(:,:,m), & trim(MARBL_instances%tracer_metadata(m)%short_name)//" sfc_flux", G%HI, & - scale=US%Z_to_m*US%s_to_T) + unscale=US%Z_to_m*US%s_to_T) enddo endif @@ -1545,7 +1545,7 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, enddo ; enddo if (CS%debug) & call hchksum(riv_flux_loc(:,:), & - trim(MARBL_instances%tracer_metadata(m)%short_name)//' riv flux', G%HI, scale=GV%H_to_m) + trim(MARBL_instances%tracer_metadata(m)%short_name)//' riv flux', G%HI, unscale=GV%H_to_m) call applyTracerBoundaryFluxesInOut(G, GV, CS%tracer_data(m)%tr(:,:,:) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth, in_flux_optional=riv_flux_loc) call tracer_vertdiff(h_work, ea, eb, dt, CS%tracer_data(m)%tr(:,:,:), G, GV, & diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 4a822592fb..afb4732cb5 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -234,7 +234,7 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, visc, CS) tracer => Reg%tr(m) if (CS%debug) then - call hchksum(tracer%t, "before HBD "//tracer%name, G%HI, scale=tracer%conc_scale) + call hchksum(tracer%t, "before HBD "//tracer%name, G%HI, unscale=tracer%conc_scale) endif ! for diagnostics @@ -290,7 +290,7 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, visc, CS) endif if (CS%debug) then - call hchksum(tracer%t, "after HBD "//tracer%name, G%HI, scale=tracer%conc_scale) + call hchksum(tracer%t, "after HBD "//tracer%name, G%HI, unscale=tracer%conc_scale) ! tracer (native grid) integrated tracer amounts before and after HBD tracer_int_prev = global_mass_integral(h, G, GV, tracer_old, scale=tracer%conc_scale) tracer_int_end = global_mass_integral(h, G, GV, tracer%t, scale=tracer%conc_scale) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index ce9b75efc5..4aacb66409 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -617,6 +617,8 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, character(len=40) :: mdl = "determine_temperature" ! This subroutine's name. logical :: domore(SZK_(GV)) ! Records which layers need additional iterations logical :: adjust_salt, fit_together, convergence_bug, do_any + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, itt @@ -631,12 +633,14 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, "based on the ratio of the thermal and haline coefficients. Otherwise try to "//& "match the density by only adjusting temperatures within a maximum range before "//& "revising estimates of the salinity.", default=.false., do_not_log=just_read) + call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(PF, mdl, "DETERMINE_TEMP_CONVERGENCE_BUG", convergence_bug, & "If true, use layout-dependent tests on the changes in temperature and salinity "//& "to determine when the iterations have converged when DETERMINE_TEMP_ADJUST_T_AND_S "//& "is false. For realistic equations of state and the default values of the "//& "various tolerances, this bug does not impact the solutions.", & - default=.true., do_not_log=just_read) !### Change the default to false. + default=enable_bugs, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_T_MIN", T_min, & "The minimum temperature that can be found by determine_temperature.", & diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 13fc5499c3..6ca6614791 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -680,15 +680,12 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! 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 ((.not.OBC%exterior_OBC_bug) .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 + do i=is,ie-1 + if (OBC%segnum_u(I,j) > 0) do_i(i+1,j) = .false. ! OBC_DIRECTION_E + if (OBC%segnum_u(I,j) < 0) do_i(i,j) = .false. ! OBC_DIRECTION_W + enddo endif endif endif @@ -1099,16 +1096,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & 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 + if (OBC%segnum_v(i,J-1) > 0) do_i(i,j) = .false. ! OBC_DIRECTION_N + if (OBC%segnum_v(i,J) < 0) do_i(i,j) = .false. ! OBC_DIRECTION_S enddo endif endif diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 21b7e820dc..fc6a6f7b1e 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1641,6 +1641,8 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_hor_diff" ! This module's name. + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. integer :: default_answer_date if (associated(CS)) then @@ -1718,10 +1720,12 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic "when DIFFUSE_ML_TO_INTERIOR is true.", & default=20240101, do_not_log=.not.CS%Diffuse_ML_interior) !### Change the default later to default_answer_date. + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "HOR_DIFF_LIMIT_BUG", CS%limit_bug, & "If true and the answer date is 20240330 or below, use a rotational symmetry "//& "breaking bug when limiting the tracer properties in tracer_epipycnal_ML_diff.", & - default=.true., do_not_log=((.not.CS%Diffuse_ML_interior).or.(CS%answer_date>=20240331))) + default=enable_bugs, do_not_log=((.not.CS%Diffuse_ML_interior).or.(CS%answer_date>=20240331))) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 1260711347..7a119d308c 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -494,7 +494,7 @@ end subroutine oil_tracer_end !! !! This tracer package was central to the simulations used by Adcroft et al., !! GRL 2010, to prove that the Deepwater Horizon spill was an important regional -!! event, with implications for dissolved oxygen levels in the Gulf of Mexico, -!! but not one that would directly impact the East Coast of the U.S. +!! event, with implications for dissolved oxygen levels in certains regions, +!! see above reference for details. end module oil_tracer diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index d9d46f7d6e..d8da7553d3 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -132,6 +132,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) logical :: continuous_Cd ! If true, use a continuous form for the simple drag coefficient as a ! function of wind speed with the idealized hurricane. When this is false, the ! linear shape for the mid-range wind speeds is specified separately. + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -238,11 +240,13 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_mode, & "Single Column mode switch used in the SCM idealized hurricane wind profile.", & default=.false.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "IDL_HURR_SCM_EDGE_TAPER_BUG", CS%edge_taper_bug, & "If true and IDL_HURR_SCM is true, use a bug that does all of the tapering and "//& "inflow angle calculations for radii between RAD_EDGE and RAD_AMBIENT as though "//& "they were at RAD_EDGE.", & - default=CS%SCM_mode, do_not_log=.not.CS%SCM_mode) !### Change the default to false. + default=CS%SCM_mode.and.enable_bugs, do_not_log=.not.CS%SCM_mode) if (.not.CS%SCM_mode) CS%edge_taper_bug = .false. call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%dy_from_center, & "Y distance of station used in the SCM idealized hurricane wind profile.", & diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index a18c5bd136..4993651d61 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -12,9 +12,8 @@ module Kelvin_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE -use MOM_open_boundary, only : OBC_segment_type, register_OBC -use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E -use MOM_open_boundary, only : OBC_DIRECTION_S, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_segment_type, register_OBC, rotate_OBC_segment_direction +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E, OBC_DIRECTION_S, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_registry_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -48,6 +47,8 @@ module Kelvin_initialization real :: OBC_nudging_time !< The timescale with which the inflowing open boundary velocities are nudged toward !! their intended values with the Kelvin wave test case [T ~> s], or a negative !! value to retain the value that is set when the OBC segments are initialized. + logical :: indexing_bugs !< If true, retain several horizontal indexing bugs that were in the + !! original version of Kelvin_set_OBC_data. end type Kelvin_OBC_CS ! This include declares and sets the variable "version". @@ -56,14 +57,15 @@ module Kelvin_initialization contains !> Add Kelvin wave to OBC registry. -function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) +logical function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. ! Local variables - logical :: register_Kelvin_OBC + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. character(len=40) :: mdl = "register_Kelvin_OBC" !< This subroutine's name. character(len=32) :: casename = "Kelvin wave" !< This case's name. character(len=200) :: config @@ -123,6 +125,11 @@ function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) "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? + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "KELVIN_SET_OBC_INDEXING_BUGS", CS%indexing_bugs, & + "If true, retain several horizontal indexing bugs that were in the original "//& + "version of Kelvin_set_OBC_data.", default=enable_bugs) ! Register the Kelvin open boundary. call register_OBC(casename, param_file, OBC_Reg) @@ -211,17 +218,25 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) 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 :: depth_tot_vel ! The total depth of the ocean at a velocity point [Z ~> m] + real :: depth_tot_corner ! The total depth of the ocean at a vorticity point [Z ~> m] + real :: Cor_vel ! The Coriolis parameter interpolated to a velocity point [T-1 ~> s-1] real :: mag_SSH ! An overall magnitude of the external wave sea surface height at the coastline [Z ~> m] real :: mag_int ! An overall magnitude of the internal wave at the coastline [L T-1 ~> m s-1] real :: x1, y1 ! Various positions [L ~> m] real :: x, y ! Various positions [L ~> m] - real :: val1 ! The periodicity factor [nondim] + real :: sin_wt ! The sine-based periodicity factor [nondim] + real :: cos_wt ! The cosine-based periodicity factor [nondim] real :: val2 ! The local wave amplitude [Z ~> m] real :: km_to_L_scale ! A scaling factor from longitudes in km to L [L km-1 ~> 1e3] real :: sina, cosa ! The sine and cosine of the coast angle [nondim] + real :: normal_sign ! A variable that corrects the sign of normal velocities for rotation [nondim] + real :: trans_sign ! A variable that corrects the sign of transverse velocities for rotation [nondim] type(OBC_segment_type), pointer :: segment => NULL() + integer :: unrot_dir ! The unrotated direction of the segment + integer :: turns ! Number of index quarter turns integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: IsdB, IedB, JsdB, JedB + integer :: IsdB, IedB, JsdB, JedB, isq, ieq, jsq, jeq, is_vel, ie_vel, js_vel, je_vel is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -235,6 +250,11 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) time_sec = US%s_to_T*time_type_to_real(Time) PI = 4.0*atan(1.0) + turns = modulo(G%HI%turns, 4) + + if (CS%indexing_bugs .and. (turns /= 0)) call MOM_error(FATAL, & + "Kelvin_set_OBC_data does not support grid rotation when KELVIN_SET_OBC_INDEXING_BUGS is true.") + do j=jsd,jed ; do i=isd,ied depth_tot(i,j) = 0.0 enddo ; enddo @@ -245,7 +265,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (CS%mode == 0) then mag_SSH = CS%ssh_amp omega = 2.0 * PI / CS%wave_period - val1 = sin(omega * time_sec) + sin_wt = sin(omega * time_sec) else mag_int = CS%inflow_amp N0 = sqrt((CS%rho_range / CS%rho_0) * (GV%g_Earth / CS%H0)) @@ -256,43 +276,74 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) ! lambda = CS%F_0 / CS%cg_mode ! omega = (4.0 * PI / (G%grid_unit_to_L*G%len_lon)) * CS%cg_mode endif + cos_wt = cos(omega * time_sec) sina = sin(CS%coast_angle) cosa = cos(CS%coast_angle) do n=1,OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle + + unrot_dir = segment%direction + if (turns /= 0) unrot_dir = rotate_OBC_segment_direction(segment%direction, -turns) + ! Apply values to the inflow end only. - if (segment%direction == OBC_DIRECTION_E) cycle - if (segment%direction == OBC_DIRECTION_N) cycle + if ((unrot_dir == OBC_DIRECTION_E) .or. (unrot_dir == OBC_DIRECTION_N)) cycle + + ! Set variables that correct for sign changes during rotation. + normal_sign = 1.0 + if ( (segment%is_E_or_W .and. ((turns == 1) .or. (turns == 2))) .or. & + (segment%is_N_or_S .and. ((turns == 2) .or. (turns == 3))) ) normal_sign = -1.0 ! If OBC_nudging_time is negative, the value of Velocity_nudging_timescale_in that was set ! when the segments are initialized is retained. if (CS%OBC_nudging_time >= 0.0) segment%Velocity_nudging_timescale_in = CS%OBC_nudging_time - 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 = G%grid_unit_to_L * G%geoLonCu(I,j) - y1 = G%grid_unit_to_L * G%geoLatCu(I,j) + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + if (unrot_dir == OBC_DIRECTION_W) then + if (segment%is_E_or_W) then + is_vel = IsdB ; ie_vel = IedB ; js_vel = jsd ; je_vel = jed + else + is_vel = isd ; ie_vel = ied ; js_vel = JsdB ; je_vel = JedB + endif + do j=js_vel,je_vel ; do I=is_vel,ie_vel + if (segment%is_E_or_W) then + x1 = G%grid_unit_to_L * G%geoLonCu(I,j) + y1 = G%grid_unit_to_L * G%geoLatCu(I,j) + else + x1 = G%grid_unit_to_L * G%geoLonCv(i,J) + y1 = G%grid_unit_to_L * G%geoLatCv(i,J) + endif x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = -(x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then ! Use inside bathymetry - cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) - val2 = mag_SSH * exp(- CS%F_0 * y / cff) - segment%SSH(I,j) = val2 * cos(omega * time_sec) - segment%normal_vel_bt(I,j) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) + if (segment%direction == OBC_DIRECTION_W) then + depth_tot_vel = depth_tot(i+1,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) + elseif (segment%direction == OBC_DIRECTION_S) then + depth_tot_vel = depth_tot(i,j+1) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) + elseif (segment%direction == OBC_DIRECTION_E) then + depth_tot_vel = depth_tot(i,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) + elseif (segment%direction == OBC_DIRECTION_N) then + depth_tot_vel = depth_tot(i,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) + endif + cff = sqrt(GV%g_Earth * depth_tot_vel ) + val2 = mag_SSH * exp(- Cor_vel * y / cff) + segment%SSH(I,j) = val2 * cos_wt + segment%normal_vel_bt(I,j) = (normal_sign*val2) * (sin_wt * cff * cosa / depth_tot_vel ) if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) + segment%nudged_normal_vel(I,j,k) = (normal_sign*val2) * (sin_wt * cff * cosa / depth_tot_vel ) enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) - segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + segment%normal_vel(I,j,k) = (normal_sign*val2) * (sin_wt * cff * cosa / depth_tot_vel ) enddo endif else @@ -300,65 +351,69 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) 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) + ! normal_vel(I,j,k) = CS%inflow_amp * CS%u_struct(k) * exp(-lambda * y) * cos_wt ! In addition, there should be a specification of the interface-height anomalies at the ! open boundaries that are specified as something like ! eta_anom(I,j,K) = (CS%inflow_amp*depth_tot/CS%cg_mode) * CS%w_struct(K) * & - ! exp(-lambda * y) * cos(omega * time_sec) + ! exp(-lambda * y) * cos_wt ! In these expressions CS%u_struct and CS%w_struct could be returned from the subroutine wave_speeds ! in MOM_wave_speed() based on the horizontally uniform initial state. if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = mag_int * & - exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & - cos(omega * time_sec) + segment%nudged_normal_vel(I,j,k) = (normal_sign*mag_int) * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cos_wt enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = mag_int * & - exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & - cos(omega * time_sec) - segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + segment%normal_vel(I,j,k) = (normal_sign*mag_int) * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cos_wt enddo endif endif enddo ; enddo - if (allocated(segment%tangential_vel)) then - do J=JsdB+1,JedB-1 ; do I=IsdB,IedB - 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) ) - val2 = mag_SSH * exp(- CS%F_0 * y / cff) - if (CS%mode == 0) then ; do k=1,nz - segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & - ( 0.5*(depth_tot(i+1,j+1) + depth_tot(i+1,j) ) ) + endif - enddo ; endif - enddo ; enddo + if (unrot_dir == OBC_DIRECTION_S) then + if (segment%is_E_or_W) then + is_vel = IsdB ; ie_vel = IedB ; js_vel = jsd ; je_vel = jed + else + is_vel = isd ; ie_vel = ied ; js_vel = JsdB ; je_vel = JedB endif - else ! Must be south - isd = segment%HI%isd ; ied = segment%HI%ied - JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - do J=JsdB,JedB ; do i=isd,ied - x1 = G%grid_unit_to_L * G%geoLonCv(i,J) - y1 = G%grid_unit_to_L * G%geoLatCv(i,J) + do J=js_vel,je_vel ; do i=is_vel,ie_vel + if (segment%is_E_or_W) then + x1 = G%grid_unit_to_L * G%geoLonCu(I,j) + y1 = G%grid_unit_to_L * G%geoLatCu(I,j) + else + x1 = G%grid_unit_to_L * G%geoLonCv(i,J) + y1 = G%grid_unit_to_L * G%geoLatCv(i,J) + endif x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) - val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) - segment%SSH(I,j) = val2 * cos(omega * time_sec) - segment%normal_vel_bt(I,j) = (val1 * cff * sina / depth_tot(i,j+1) ) * val2 + if (segment%direction == OBC_DIRECTION_W) then + depth_tot_vel = depth_tot(i+1,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) + elseif (segment%direction == OBC_DIRECTION_S) then + depth_tot_vel = depth_tot(i,j+1) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) + elseif (segment%direction == OBC_DIRECTION_E) then + depth_tot_vel = depth_tot(i,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) + elseif (segment%direction == OBC_DIRECTION_N) then + depth_tot_vel = depth_tot(i,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) + endif + cff = sqrt(GV%g_Earth * depth_tot_vel ) + val2 = mag_SSH * exp(- Cor_vel * y / cff) + segment%SSH(I,j) = val2 * cos_wt + segment%normal_vel_bt(I,j) = (sin_wt * cff * sina / depth_tot_vel ) * (normal_sign*val2) if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = (val1 * cff * sina / depth_tot(i,j+1)) * val2 + segment%nudged_normal_vel(I,j,k) = (sin_wt * cff * sina / depth_tot_vel) * (normal_sign*val2) enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = (val1 * cff * sina / depth_tot(i,j+1) ) * val2 - segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + segment%normal_vel(I,j,k) = (sin_wt * cff * sina / depth_tot_vel ) * (normal_sign*val2) enddo endif else @@ -367,33 +422,86 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) segment%normal_vel_bt(i,J) = 0.0 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(i,J,k) = mag_int * & + segment%nudged_normal_vel(i,J,k) = (normal_sign*mag_int) * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa + ! This is missing cos_wt enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(i,J,k) = mag_int * & + segment%normal_vel(i,J,k) = (normal_sign*mag_int) * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa - segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + ! This is missing cos_wt enddo endif endif enddo ; enddo - if (allocated(segment%tangential_vel)) then - do J=JsdB,JedB ; do I=IsdB+1,IedB-1 + endif + + if (allocated(segment%tangential_vel)) then + trans_sign = 1.0 + if (segment%is_E_or_W) then + Isq = IsdB ; Ieq = IedB ; Jsq = JsdB+1 ; Jeq = JedB-1 + if ((turns == 2) .or. (turns == 3)) trans_sign = -1.0 + else + Isq = IsdB+1 ; Ieq = IedB-1 ; Jsq = JsdB ; Jeq = JedB + if ((turns == 1) .or. (turns == 2)) trans_sign = -1.0 + endif + + if ((unrot_dir == OBC_DIRECTION_W) .or. (unrot_dir == OBC_DIRECTION_S)) then + do J=Jsq,Jeq ; do I=Isq,Ieq + if (segment%direction == OBC_DIRECTION_W) then + depth_tot_corner = 0.5*(depth_tot(i+1,j+1) + depth_tot(i+1,j)) + elseif (segment%direction == OBC_DIRECTION_E) then + depth_tot_corner = 0.5*(depth_tot(i,j+1) + depth_tot(i,j)) + elseif (segment%direction == OBC_DIRECTION_S) then + depth_tot_corner = 0.5*(depth_tot(i+1,j+1) + depth_tot(i,j+1)) + elseif (segment%direction == OBC_DIRECTION_N) then + depth_tot_corner = 0.5*(depth_tot(i+1,j) + depth_tot(i,j)) + endif x1 = G%grid_unit_to_L * G%geoLonBu(I,J) y1 = G%grid_unit_to_L * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) - val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + cff = sqrt(GV%g_Earth * depth_tot_corner ) + val2 = (trans_sign*mag_SSH) * exp(- G%CoriolisBu(I,J) * y / cff) + if (CS%indexing_bugs) then + if (unrot_dir == OBC_DIRECTION_W) then + cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) + val2 = (trans_sign*mag_SSH) * exp(- G%CoriolisBu(I,J) * y / cff) + endif + if (unrot_dir == OBC_DIRECTION_S) then + cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) + val2 = (trans_sign*mag_SSH) * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + endif + endif if (CS%mode == 0) then ; do k=1,nz - segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & - ( 0.5*(depth_tot(i+1,j+1) + depth_tot(i,j+1)) ) + segment%tangential_vel(I,J,k) = (sin_wt * val2 * cff * sina) / depth_tot_corner enddo ; endif enddo ; enddo endif endif + + if (segment%specified .and. (.not.segment%nudged) .and. & + ((unrot_dir == OBC_DIRECTION_S) .or. (unrot_dir == OBC_DIRECTION_W))) then + if (segment%direction == OBC_DIRECTION_W) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_E) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i,j,k) * G%dyCu(I,j) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_S) then + do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_N) then + do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j,k) * G%dxCv(i,J) + enddo ; enddo ; enddo + endif + endif + enddo end subroutine Kelvin_set_OBC_data diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index dc34768182..1d8d00f130 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -293,6 +293,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) character*(7), parameter :: COUPLER_STRING = "COUPLER" character*(5), parameter :: INPUT_STRING = "INPUT" integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: use_waves logical :: StatisticalWaves @@ -536,11 +538,12 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & "Flag (logical) if using misalignment between shear and waves in LA", & default=.false.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. call get_param(param_file, mdl, "LA_MISALIGNMENT_BUG", CS%LA_misalign_bug, & "If true, use a code with a sign error when calculating the misalignment between "//& "the shear and waves when LA_MISALIGNMENT is true.", & - default=CS%LA_Misalignment, do_not_log=.not.CS%LA_Misalignment) - !### Change the default for LA_MISALIGNMENT_BUG to .false. + default=CS%LA_Misalignment.and.enable_bugs, do_not_log=.not.CS%LA_Misalignment) call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & "A minimum value for all Langmuir numbers that is not physical, "//& "but is likely only encountered when the wind is very small and "//& diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 1570cab7d3..95fe3bf35f 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -72,7 +72,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C real :: min_depth ! The minimum depth of the ocean [Z ~> m] real :: dummy1 ! The position relative to the sponge width [nondim] real :: min_thickness ! A minimum layer thickness [H ~> m or kg m-2] (unused) - real :: lensponge ! The width of the sponge [km] + real :: lensponge ! The width of the sponge in axis units, [km] or [m] character(len=40) :: filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 0ae9f35e78..04af1d2d5b 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -115,7 +115,6 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, real :: S_range ! The range of salinities in this test case [S ~> ppt] real :: S_light, S_dense ! The lightest and densest salinities in the sponges [S ~> ppt]. real :: eta_IC_quanta ! The granularity of quantization of initial interface heights [Z-1 ~> m-1]. - real :: x ! Along-channel position in the axis units [m] or [km] or [deg] logical :: dbrotate ! If true, rotate the domain. logical :: use_ALE ! True if ALE is being used, False if in layered mode @@ -156,16 +155,10 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, default=.false., do_not_log=just_read) do j=js,je do i=is,ie - ! Compute normalized zonal coordinates (x,y=0 at center of domain) - if (dbrotate) then - ! This is really y in the rotated case - x = G%geoLatT(i,j) - else - x = G%geoLonT(i,j) - endif + ! Work relative to the center of the domain, where geoLonT and geoLatT are both 0. eta1D(1) = 0.0 eta1D(nz+1) = -depth_tot(i,j) - if (x<0.0) then + if (((.not.dbrotate) .and. (G%geoLonT(i,j)<0.0)) .or. (dbrotate .and. (G%geoLatT(i,j)<0.0))) then do k=nz,2, -1 eta1D(k) = eta1D(k+1) + min_thickness enddo diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index 2dde65148b..c4cf25281f 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -9,6 +9,7 @@ module dyed_channel_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_open_boundary, only : OBC_registry_type, register_OBC use MOM_time_manager, only : time_type, time_type_to_real @@ -30,6 +31,9 @@ module dyed_channel_initialization real :: zonal_flow = 8.57 !< Mean inflow [L T-1 ~> m s-1] real :: tidal_amp = 0.0 !< Sloshing amplitude [L T-1 ~> m s-1] real :: frequency = 0.0 !< Sloshing frequency [T-1 ~> s-1] + logical :: OBC_transport_bug !< If true and specified open boundary conditions are being + !! used, use a 1 m (if Boussienesq) or 1 kg m-2 layer thickness + !! instead of the actual thickness. end type dyed_channel_OBC_CS integer :: ntr = 0 !< Number of dye tracers @@ -38,13 +42,15 @@ module dyed_channel_initialization contains !> Add dyed channel to OBC registry. -function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) +logical function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + ! Local variables - logical :: register_dyed_channel_OBC + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. character(len=32) :: casename = "dyed channel" ! This case's name. character(len=40) :: mdl = "register_dyed_channel_OBC" ! This subroutine's name. @@ -64,6 +70,12 @@ function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & "Frequency of oscillating zonal flow.", & units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "CHANNEL_FLOW_OBC_TRANSPORT_BUG", CS%OBC_transport_bug, & + "If true and specified open boundary conditions are being used, use a 1 m "//& + "(if Boussienesq) or 1 kg m-2 layer thickness instead of the actual thickness.", & + default=enable_bugs) ! Register the open boundaries. call register_OBC(casename, param_file, OBC_Reg) @@ -131,7 +143,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) end subroutine dyed_channel_set_OBC_tracer_data !> This subroutine updates the long-channel flow -subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) +subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, h, Time) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. @@ -139,13 +151,19 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< model time. + ! Local variables real :: flow ! The OBC velocity [L T-1 ~> m s-1] real :: PI ! 3.1415926535... [nondim] real :: time_sec ! The elapsed time since the start of the calendar [T ~> s] - integer :: i, j, k, l, isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB + real :: fixed_thickness ! A fixed layer thickness, hard-coded to 1 mks unit, that is used to + ! reproduce a bug with the older versions of this code [H ~> m or kg m-2] + logical :: cross_channel ! True if the segment runs across the channel + integer :: turns ! Number of index quarter turns + integer :: i, j, k, l_seg, isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB, is, ie, js, je type(OBC_segment_type), pointer :: segment => NULL() if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & @@ -154,40 +172,82 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) time_sec = US%s_to_T * time_type_to_real(Time) PI = 4.0*atan(1.0) - do l=1, OBC%number_of_segments - segment => OBC%segment(l) + turns = modulo(G%HI%turns, 4) + + do l_seg=1, OBC%number_of_segments + segment => OBC%segment(l_seg) if (.not. segment%on_pe) cycle if (segment%gradient) cycle - if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle + if (segment%oblique .and. (.not. segment%nudged) .and. (.not. segment%Flather)) cycle + if (CS%frequency == 0.0) then + flow = CS%zonal_flow + else + flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) + endif + if ((turns==2) .or. (turns==3)) flow = -1.0 * flow + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB if (segment%is_E_or_W) then - jsd = segment%HI%jsd ; jed = segment%HI%jed - IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - if (CS%frequency == 0.0) then - flow = CS%zonal_flow + is = IsdB ; ie = IedB ; js = jsd ; je = jed + else + is = isd ; ie = ied ; js = JsdB ; je = JedB + endif + cross_channel = ((segment%is_E_or_W .and. ((turns==0) .or. (turns==2))) .or. & + (segment%is_N_or_S .and. ((turns==1) .or. (turns==3)))) + + if ((segment%specified .or. segment%nudged) .and. cross_channel) then + do k=1,GV%ke ; do j=js,je ; do I=is,ie + segment%normal_vel(I,j,k) = flow + enddo ; enddo ; enddo + endif + + if (segment%specified .and. cross_channel) then + if (CS%OBC_transport_bug) then + fixed_thickness = 1.0 / GV%H_to_mks ! This replicates the prevoius answers without rescaling. + if ((segment%direction == OBC_DIRECTION_W) .or. (segment%direction == OBC_DIRECTION_E)) then + do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * fixed_thickness + enddo ; enddo ; enddo + elseif ((segment%direction == OBC_DIRECTION_S) .or. (segment%direction == OBC_DIRECTION_N)) then + do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * fixed_thickness + enddo ; enddo ; enddo + endif else - flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) + if (segment%direction == OBC_DIRECTION_W) then + do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * h(i+1,j,k) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_E) then + do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * h(i,j,k) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_S) then + do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * h(i,j+1,k) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_N) then + do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * h(i,j,k) + enddo ; enddo ; enddo + endif endif - do k=1,GV%ke - do j=jsd,jed ; do I=IsdB,IedB - if (segment%specified .or. segment%nudged) then - segment%normal_vel(I,j,k) = flow - endif - if (segment%specified) then - segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) - endif - enddo ; enddo - enddo - do j=jsd,jed ; do I=IsdB,IedB + endif + + if (cross_channel) then + do j=js,je ; do I=is,ie segment%normal_vel_bt(I,j) = flow enddo ; enddo else - isd = segment%HI%isd ; ied = segment%HI%ied - JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - do J=JsdB,JedB ; do i=isd,ied + do J=js,je ; do i=is,ie segment%normal_vel_bt(i,J) = 0.0 enddo ; enddo endif + enddo end subroutine dyed_channel_update_flow diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index df46a142f1..1258bd405e 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -10,7 +10,7 @@ module shelfwave_initialization use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_segment_type, register_OBC -use MOM_open_boundary, only : OBC_registry_type +use MOM_open_boundary, only : OBC_registry_type, rotate_OBC_segment_direction use MOM_time_manager, only : time_type, time_type_to_real use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -29,14 +29,12 @@ module shelfwave_initialization !> Control structure for shelfwave open boundaries. type, public :: shelfwave_OBC_CS ; private real :: my_amp !< Amplitude of the open boundary current inflows [L T-1 ~> m s-1] - real :: Lx = 100.0 !< Long-shore length scale of bathymetry [km] or [m] - real :: Ly = 50.0 !< Cross-shore length scale [km] or [m] - real :: f0 = 1.e-4 !< Coriolis parameter [T-1 ~> s-1] - real :: jj = 1.0 !< Cross-shore wave mode [nondim] real :: kk !< Cross-shore wavenumber [km-1] or [m-1] real :: ll !< Longshore wavenumber [km-1] or [m-1] real :: alpha !< Exponential decay rate in the y-direction [km-1] or [m-1] real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] + logical :: shelfwave_correct_amplitude !< If true, SHELFWAVE_AMPLITUDE gives the actual inflow + !! velocity, rather than giving an overall scaling factor for the flow. end type shelfwave_OBC_CS contains @@ -53,6 +51,11 @@ function register_shelfwave_OBC(param_file, CS, G, US, OBC_Reg) ! Local variables real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] character(len=32) :: casename = "shelfwave" !< This case's name. + real :: jj ! Cross-shore wave mode [nondim] + real :: f0 ! Coriolis parameter [T-1 ~> s-1] + real :: Lx ! Long-shore length scale of bathymetry [km] or [m] + real :: Ly ! Cross-shore length scale [km] or [m] + real :: default_amp ! The default velocity amplitude [m s-1] or amplitude scaling factor [nondim] PI = 4.0*atan(1.0) @@ -65,25 +68,29 @@ function register_shelfwave_OBC(param_file, CS, G, US, OBC_Reg) ! Register the tracer for horizontal advection & diffusion. call register_OBC(casename, param_file, OBC_Reg) - call get_param(param_file, mdl, "F_0", CS%f0, & + call get_param(param_file, mdl, "F_0", f0, & default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) - call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH", CS%Lx, & + call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH", Lx, & "Length scale of shelfwave in x-direction.",& units=G%x_ax_unit_short, default=100.) - call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", CS%Ly, & + call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", Ly, & "Length scale of exponential dropoff of topography in the y-direction.", & units=G%y_ax_unit_short, default=50.) - call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", CS%jj, & + call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", jj, & "Cross-shore wave mode.", & units="nondim", default=1.) + call get_param(param_file, mdl, "SHELFWAVE_CORRECT_AMPLITUDE", CS%shelfwave_correct_amplitude, & + "If true, SHELFWAVE_AMPLITUDE gives the actual inflow velocity, rather than giving "//& + "an overall scaling factor for the flow.", default=.false.) !### Make the default .true.? + default_amp = 1.0 ; if (CS%shelfwave_correct_amplitude) default_amp = 0.1 call get_param(param_file, mdl, "SHELFWAVE_AMPLITUDE", CS%my_amp, & "Amplitude of the open boundary current inflows in the shelfwave configuration.", & - units="m s-1", default=1.0, scale=US%m_s_to_L_T) + units="m s-1", default=default_amp, scale=US%m_s_to_L_T) - CS%alpha = 1. / CS%Ly - CS%ll = 2. * PI / CS%Lx - CS%kk = CS%jj * PI / G%len_lat - CS%omega = 2 * CS%alpha * CS%f0 * CS%ll / & + CS%alpha = 1. / Ly + CS%ll = 2. * PI / Lx + CS%kk = jj * PI / G%len_lat + CS%omega = 2 * CS%alpha * f0 * CS%ll / & (CS%kk*CS%kk + CS%alpha*CS%alpha + CS%ll*CS%ll) register_shelfwave_OBC = .true. @@ -145,37 +152,61 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: time_sec ! The time in the run [T ~> s] real :: cos_wt, sin_wt ! Cosine and sine associated with the propagating x-direction structure [nondim] real :: cos_ky, sin_ky ! Cosine and sine associated with the y-direction structure [nondim] - real :: x, y ! Positions relative to the western and southern boundaries [km] or [m] or [degrees] - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, n - integer :: IsdB, IedB, JsdB, JedB + real :: x ! Position relative to the western boundary [km] or [m] or [degrees_E] + real :: y ! Position relative to the southern boundary [km] or [m] or [degrees_N] + real :: I_yscale ! A factor to give the correct inflow velocity [km-1] or [m-1] or [degrees_N-1] or + ! to compensate for the variable units of the y-coordinate [km axis_unit-1], usually 1 [nondim] + real :: my_amp ! Amplitude of the open boundary current inflows, including sign changes + ! to account for grid rotation [L T-1 ~> m s-1] + integer :: i, j, is, ie, js, je, n + integer :: turns ! Number of index quarter turns type(OBC_segment_type), pointer :: segment => NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (.not.associated(OBC)) return + turns = modulo(G%HI%turns, 4) + my_amp = CS%my_amp ; if ((turns==2) .or. (turns==3)) my_amp = -CS%my_amp + time_sec = US%s_to_T*time_type_to_real(Time) + if (CS%shelfwave_correct_amplitude) then + ! This makes the units and edge value of normal_vel_bt the same as my_amp. + I_yscale = 1.0 / CS%kk + else ! This preserves the previous answers. + if (G%grid_unit_to_L == 0.0) call MOM_error(FATAL, & + "shelfwave_set_OBC_data requires the use of Cartesian coordinates.") + I_yscale = (1.0e3 * US%m_to_L) / G%grid_unit_to_L + endif do n = 1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle - if (segment%direction /= OBC_DIRECTION_W) cycle - - IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - jsd = segment%HI%jsd ; jed = segment%HI%jed - do j=jsd,jed ; do I=IsdB,IedB - x = G%geoLonCu(I,j) - G%west_lon - y = G%geoLatCu(I,j) - G%south_lat + if (rotate_OBC_segment_direction(segment%direction, -turns) /= OBC_DIRECTION_W) cycle + + if (segment%is_E_or_W) then + ! segment thicknesses are defined at cell face centers. + is = segment%HI%isdB ; ie = segment%HI%iedB + js = segment%HI%jsd ; je = segment%HI%jed + else + is = segment%HI%isd ; ie = segment%HI%ied + js = segment%HI%jsdB ; je = segment%HI%jedB + endif + + do j=js,je ; do I=is,ie + if (segment%is_E_or_W) then + x = G%geoLonCu(I,j) - G%west_lon + y = G%geoLatCu(I,j) - G%south_lat + else + x = G%geoLonCv(i,J) - G%west_lon + y = G%geoLatCv(i,J) - G%south_lat + endif sin_wt = sin(CS%ll*x - CS%omega*time_sec) cos_wt = cos(CS%ll*x - CS%omega*time_sec) sin_ky = sin(CS%kk * y) cos_ky = cos(CS%kk * y) - segment%normal_vel_bt(I,j) = CS%my_amp * exp(- CS%alpha * y) * cos_wt * & - (CS%alpha * sin_ky + CS%kk * cos_ky) -! segment%tangential_vel_bt(I,j) = CS%my_amp * CS%ll * exp(- CS%alpha * y) * sin_wt * sin_ky -! segment%vorticity_bt(I,j) = CS%my_amp * exp(- CS%alpha * y) * cos_wt * sin_ky& -! (CS%ll**2 + CS%kk**2 + CS%alpha**2) + segment%normal_vel_bt(I,j) = my_amp * exp(- CS%alpha * y) * cos_wt * & + ((CS%alpha * sin_ky + CS%kk * cos_ky) * I_yscale) +! segment%tangential_vel_bt(I,j) = my_amp * (CS%ll * I_yscale) * exp(- CS%alpha * y) * sin_wt * sin_ky +! segment%vorticity_bt(I,j) = my_amp * exp(- CS%alpha * y) * cos_wt * sin_ky * & +! ((CS%ll**2 + CS%kk**2 + CS%alpha**2) * (I_yscale / G%grid_unit_to_L)) enddo ; enddo enddo diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index ddb38a9cdf..4d4bd68f84 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -7,7 +7,8 @@ module supercritical_initialization use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_segment_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, rotate_OBC_segment_direction +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_time_manager, only : time_type, time_type_to_real use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -32,6 +33,8 @@ subroutine supercritical_set_OBC_data(OBC, G, GV, US, param_file) ! Local variables character(len=40) :: mdl = "supercritical_set_OBC_data" ! This subroutine's name. real :: zonal_flow ! Inflow speed [L T-1 ~> m s-1] + integer :: unrot_dir ! The unrotated direction of the segment + integer :: turns ! Number of index quarter turns integer :: i, j, k, l integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list @@ -43,13 +46,18 @@ subroutine supercritical_set_OBC_data(OBC, G, GV, US, param_file) "Constant zonal flow imposed at upstream open boundary.", & units="m/s", default=8.57, scale=US%m_s_to_L_T) + turns = modulo(G%HI%turns, 4) + do l=1, OBC%number_of_segments segment => OBC%segment(l) if (.not. segment%on_pe) cycle if (segment%gradient) cycle if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle - if (segment%is_E_or_W) then + unrot_dir = segment%direction + if (turns /= 0) unrot_dir = rotate_OBC_segment_direction(segment%direction, -turns) + + if ((unrot_dir == OBC_DIRECTION_E) .or. (unrot_dir == OBC_DIRECTION_W)) then jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB do k=1,GV%ke diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 5b300a4d05..24aefe2bb1 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -9,7 +9,7 @@ module tidal_bay_initialization use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : OBC_segment_type, register_OBC use MOM_open_boundary, only : OBC_registry_type use MOM_unit_scaling, only : unit_scale_type @@ -75,10 +75,12 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) ! The following variables are used to set up the transport in the tidal_bay example. real :: time_sec ! Elapsed model time [T ~> s] real :: cff_eta ! The sea surface height anomalies associated with the inflow [Z ~> m] - real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] + real :: my_flux ! The volume flux through the face [L2 Z T-1 ~> m3 s-1] real :: total_area ! The total face area of the OBCs [L Z ~> m2] + real :: normal_vel ! The normal velocity through the inflow face [L T-1 ~> m s-1] real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] real, allocatable :: my_area(:,:) ! The total OBC inflow area [L Z ~> m2] + integer :: turns ! Number of index quarter turns integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() @@ -89,32 +91,63 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) PI = 4.0*atan(1.0) - if (.not.associated(OBC)) return + turns = modulo(G%HI%turns, 4) - allocate(my_area(1:1,js:je)) + if (.not.associated(OBC)) return 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 - my_flux = 0.0 + segment => OBC%segment(1) - do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB - if (OBC%segnum_u(I,j) /= OBC_NONE) then - do k=1,nz - 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 + if (turns == 0) then + allocate(my_area(1:1,js:je), source=0.0) + do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB + if (OBC%segnum_u(I,j) > 0) then ! (segment%direction == OBC_DIRECTION_E) + do k=1,nz + my_area(1,j) = my_area(1,j) + h(i,j,k)*(GV%H_to_m*US%m_to_Z)*G%dyCu(I,j) + enddo + endif + enddo ; enddo + elseif (turns == 1) then + allocate(my_area(is:ie,1:1), source=0.0) + do J=segment%HI%JscB,segment%HI%JecB ; do i=segment%HI%isc,segment%HI%iec + if (OBC%segnum_v(i,J) > 0) then ! (segment%direction == OBC_DIRECTION_N) + do k=1,nz + my_area(i,1) = my_area(i,1) + h(i,j,k)*(GV%H_to_m*US%m_to_Z)*G%dxCv(i,J) + enddo + endif + enddo ; enddo + elseif (turns == 2) then + allocate(my_area(1:1,js:je), source=0.0) + do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB + if (OBC%segnum_u(I,j) < 0) then ! (segment%direction == OBC_DIRECTION_W) + do k=1,nz + my_area(1,j) = my_area(1,j) + h(i+1,j,k)*(GV%H_to_m*US%m_to_Z)*G%dyCu(I,j) + enddo + endif + enddo ; enddo + elseif (turns == 3) then + allocate(my_area(is:ie,1:1), source=0.0) + do J=segment%HI%JscB,segment%HI%JecB ; do i=segment%HI%isc,segment%HI%iec + if (OBC%segnum_v(i,J) < 0) then ! (segment%direction == OBC_DIRECTION_S) + do k=1,nz + my_area(i,1) = my_area(i,1) + h(i,j+1,k)*(GV%H_to_m*US%m_to_Z)*G%dxCv(i,J) + enddo + endif + enddo ; enddo + endif + total_area = reproducing_sum(my_area, unscale=US%Z_to_m*US%L_to_m) my_flux = - CS%tide_flow * SIN(2.0*PI*time_sec / CS%tide_period) + normal_vel = my_flux / total_area + if ((turns==2) .or. (turns==3)) normal_vel = -1.0 * normal_vel do n = 1, OBC%number_of_segments segment => OBC%segment(n) - if (.not. segment%on_pe) cycle - segment%normal_vel_bt(:,:) = my_flux / total_area + segment%normal_vel_bt(:,:) = normal_vel segment%SSH(:,:) = cff_eta enddo ! end segment loop