diff --git a/.github/actions/macos-setup/action.yml b/.github/actions/macos-setup/action.yml
index caa6f193bb..0c1116f25b 100644
--- a/.github/actions/macos-setup/action.yml
+++ b/.github/actions/macos-setup/action.yml
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
name: 'install-macos-prerequisites'
description: 'Install prerequisites for Mac OS compilation'
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/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml
index 0f53a68c70..22d8ae897a 100644
--- a/.github/actions/ubuntu-setup/action.yml
+++ b/.github/actions/ubuntu-setup/action.yml
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
name: 'install-ubuntu-prerequisites'
description: 'Install prerequisites for Ubuntu Linux compilation'
diff --git a/.github/workflows/verify-linux.yml b/.github/workflows/verify-linux.yml
index c15daee448..39c902d743 100644
--- a/.github/workflows/verify-linux.yml
+++ b/.github/workflows/verify-linux.yml
@@ -1,16 +1,23 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
name: Linux verification
on: [push, pull_request]
+env:
+ MOM_TARGET_SLUG: ${{ github.repository }}
+ MOM_TARGET_LOCAL_BRANCH: ${{ github.base_ref }}
+
jobs:
# Documentation
+
check-style-and-docstrings:
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- name: Check white space (non-blocking)
run: |
@@ -38,320 +45,277 @@ 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
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile dependencies
+ run: |
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
- name: Compile MOM6 with symmetric indexing
- run: |
- make -C .testing 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
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile dependencies
+ run: |
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
- name: Compile MOM6 with asymmetric indexing
- run: |
- make -C .testing 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
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
-
- - name: Compile repro
+ - name: Compile dependencies
run: |
- make -C .testing build/repro/MOM6 -j \
- -o build/deps/lib/libFMS.a
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
+
+ - name: Compile MOM6 with bit-reproducible optimization
+ run: make -C .testing -j build/repro/MOM6
+
+ - name: Prepare artifact
+ run: tar -cf mom6-repro.tar .testing/build/repro/MOM6
- uses: actions/upload-artifact@v4
with:
name: mom6-repro-artifact
- path: .testing/build/repro/MOM6
+ path: mom6-repro.tar
retention-days: 1
build-openmp:
+ # temporarily disable until we get GCC to accept OpenMP target directives
+ if: false
+
runs-on: ubuntu-latest
- needs: build-fms
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile dependencies
+ run: |
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
- name: Compile MOM6 supporting OpenMP
- run: make -C .testing 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
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile target depedencies
+ run: |
+ make -C .testing \
+ DO_REGRESSION_TESTS=1 \
+ build/target_codebase
+ make -C .testing/build/target_codebase/.testing -j \
+ build/deps/lib/libFMS.a
- name: Compile target MOM6
run: |
- make -C .testing 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
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
-
- - name: Compile optimized model
+ - name: Compile dependencies
run: |
- make -C .testing build/opt/MOM6 -j \
- -o build/deps/lib/libFMS.a
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
- - uses: actions/upload-artifact@v4
- with:
- name: mom6-opt-artifact
- path: .testing/build/opt/MOM6
- retention-days: 1
+ - name: Compile MOM6 with aggressive optimization
+ run: make -C .testing -j build/opt/MOM6
+
+ - name: Compile timing tests
+ run: make -C .testing build.timing
- - name: 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
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile target dependencies
+ run: |
+ make -C .testing \
+ DO_REGRESSION_TESTS=1 \
+ build/target_codebase
+ make -C .testing/build/target_codebase/.testing -j \
+ build/deps/lib/libFMS.a
- name: Compile target MOM6
run: |
- make -C .testing 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
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile dependencies
+ run: |
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
- name: Compile MOM6 with code coverage
- run: make -C .testing 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
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile dependencies
+ run: |
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
- name: Compile MOM6 for the GFDL coupled driver
- run: |
- make -C .testing 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
@@ -361,8 +325,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -370,19 +332,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
@@ -390,8 +356,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -399,12 +363,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
@@ -412,8 +379,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -421,43 +386,22 @@ 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
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -465,43 +409,22 @@ 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
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -509,102 +432,51 @@ 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
- with:
- submodules: recursive
- 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
+ - name: Unpack artifacts
+ run: tar -xpvf mom6-symmetric.tar
- test-dim-r:
- runs-on: ubuntu-latest
- needs: build-symmetric
-
- steps:
- - uses: actions/checkout@v4
- with:
- submodules: recursive
-
- - uses: ./.github/actions/ubuntu-setup
-
- - name: Download Artifacts
- uses: actions/download-artifact@v4
- with:
- name: mom6-symmetric-artifact
- path: .testing/build/symmetric/
-
- - name: Verify density dimensional invariance
+ - 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:
+ if: false
runs-on: ubuntu-latest
needs:
- build-symmetric
@@ -612,8 +484,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -621,19 +491,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: |
+ tar -xpvf mom6-symmetric.tar
+ tar -xpvf mom6-openmp.tar
+
+ - name: Run OpenMP test
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
+ make -C .testing -j \
+ -o build/symmetric/MOM6 \
+ -o build/openmp/MOM6 \
+ test.openmp
test-repro:
runs-on: ubuntu-latest
@@ -643,8 +517,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -652,21 +524,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'
@@ -677,8 +551,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -686,22 +558,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
@@ -709,8 +583,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/ubuntu-setup
@@ -718,46 +590,65 @@ 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
+
+ - 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:
@@ -766,82 +657,74 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- 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
@@ -849,7 +732,7 @@ jobs:
id-token: write
needs:
- test-grid
- - test-openmp
+ #- test-openmp
- test-repro
- run-coverage
@@ -857,9 +740,8 @@ jobs:
- uses: geekyeggo/delete-artifact@v5
with:
name: |
- fms-artifact
mom6-asymmetric-artifact
- mom6-openmp-artifact
+ #mom6-openmp-artifact
mom6-repro-artifact
mom6-coverage-artifact
@@ -876,22 +758,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-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 +781,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-openmp
- test-repro
- - run-coverage
- test-regression
- - run-timings
+ - compare-timings
steps:
- uses: geekyeggo/delete-artifact@v5
@@ -924,5 +796,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..feb93c53b8 100644
--- a/.github/workflows/verify-macos.yml
+++ b/.github/workflows/verify-macos.yml
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
name: MacOS verification
on: [push, pull_request]
@@ -5,164 +9,149 @@ 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
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
-
- - name: Compile symmetric index layout
+ - name: Compile dependencies
run: |
- make -C .testing build/symmetric/MOM6 -j -o build/deps/lib/libFMS.a
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
+
+ - name: Compile MOM6 with symmetric indexing
+ run: make -C .testing -j build/symmetric/MOM6
+
+ - name: Prepare artifact
+ run: tar -cf mom6-symmetric.tar .testing/build/symmetric/MOM6
- uses: actions/upload-artifact@v4
with:
name: mom6-symmetric-artifact
- path: .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
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
-
- - name: Compile asymmetric index layout
+ - name: Compile dependencies
run: |
- make -C .testing build/asymmetric/MOM6 -j -o build/deps/lib/libFMS.a
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
+
+ - name: Compile MOM6 with asymmetric indexing
+ run: make -C .testing -j build/asymmetric/MOM6
+
+ - name: Prepare artifact
+ run: tar -cf mom6-asymmetric.tar .testing/build/asymmetric/MOM6
- uses: actions/upload-artifact@v4
with:
name: mom6-asymmetric-artifact
- path: .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
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile dependencies
+ run: |
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
+
+ - name: Compile MOM6 with bit-reproducible optimization
+ run: make -C .testing -j build/repro/MOM6
- - name: 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
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile dependencies
+ run: |
+ make -C .testing -j build/deps/lib/libFMS.a
+ make -C .testing -j PKG= build/deps/lib/libgsw.a
+ make -C .testing -j PKG= build/deps/lib/libcvmix.a
- name: Compile MOM6 supporting OpenMP
- run: make -C .testing 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
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup/
- - uses: actions/download-artifact@v4
- with:
- name: fms-artifact
- path: .testing/build/deps/
+ - name: Compile target dependencies
+ run: |
+ make -C .testing \
+ DO_REGRESSION_TESTS=1 \
+ build/target_codebase
+ make -C .testing/build/target_codebase/.testing -j \
+ build/deps/lib/libFMS.a
- name: Compile target MOM6
run: |
- make -C .testing 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
@@ -172,8 +161,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup
@@ -181,21 +168,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
@@ -203,8 +192,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup
@@ -212,13 +199,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
@@ -226,8 +215,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup
@@ -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
@@ -248,8 +238,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup
@@ -257,12 +245,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
@@ -270,8 +261,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup
@@ -279,144 +268,48 @@ 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: Unpack artifacts
+ run: tar -xpvf mom6-symmetric.tar
- - name: Verify horizontal length dimensional invariance
+ - name: Run NaN initialization test
run: |
- chmod u+rx .testing/build/symmetric/MOM6
- make -C .testing test.dim.l -o build/symmetric/MOM6
-
- test-dim-h:
- runs-on: macos-latest
- needs: build-symmetric
-
- steps:
- - uses: actions/checkout@v4
- with:
- submodules: recursive
-
- - uses: ./.github/actions/macos-setup
-
- - name: Download Artifacts
- uses: actions/download-artifact@v4
- with:
- name: mom6-symmetric-artifact
- path: .testing/build/symmetric/
-
- - name: Verify vertical thickness dimensional invariance
- run: |
- chmod u+rx .testing/build/symmetric/MOM6
- make -C .testing test.dim.h -o build/symmetric/MOM6
+ 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
- with:
- submodules: recursive
- 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
-
- test-dim-r:
- runs-on: macos-latest
- needs: build-symmetric
+ - name: Unpack artifacts
+ run: tar -xpvf mom6-symmetric.tar
- 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
@@ -426,8 +319,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup
@@ -435,19 +326,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: |
+ tar -xpvf mom6-symmetric.tar
+ tar -xpvf mom6-openmp.tar
+
+ - name: Run OpenMP test
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
+ make -C .testing -j \
+ -o build/symmetric/MOM6 \
+ -o build/openmp/MOM6 \
+ test.openmp
test-repro:
runs-on: macOS-latest
@@ -457,8 +352,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup
@@ -466,19 +359,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: |
+ 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 -k test.repro -o build/symmetric/MOM6 -o build/repro/MOM6
+ make -C .testing -j \
+ -o build/symmetric/MOM6 \
+ -o build/repro/MOM6 \
+ test.repro
test-regression:
if: github.event_name == 'pull_request'
@@ -489,8 +386,6 @@ jobs:
steps:
- uses: actions/checkout@v4
- with:
- submodules: recursive
- uses: ./.github/actions/macos-setup
@@ -498,45 +393,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/.gitignore b/.gitignore
index c57b950fc2..d246027b44 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,23 +1,2 @@
-# Ignore vim and emacs files
-*.swp
-*~
-html
-
-
# Build output
-*.o
-*.mod
-MOM6
build/
-deps/
-pkg/MARBL
-
-
-# Autoconf output
-aclocal.m4
-autom4te.cache/
-config.log
-config.status
-configure
-/Makefile
-Makefile.mkmf
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 5aa48ae919..b1f7f4bf4d 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
stages:
- setup
- builds
diff --git a/.gitlab/mom6-ci-run-gnu-restarts-script.sh b/.gitlab/mom6-ci-run-gnu-restarts-script.sh
index 02af3460b4..104dc40567 100644
--- a/.gitlab/mom6-ci-run-gnu-restarts-script.sh
+++ b/.gitlab/mom6-ci-run-gnu-restarts-script.sh
@@ -1,4 +1,7 @@
#!/bin/bash
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
sect=none
clean_stats () { # fn to clean up stats files
diff --git a/.gitlab/mom6-ci-run-gnu-script.sh b/.gitlab/mom6-ci-run-gnu-script.sh
index 8577eff6d2..13dfe00111 100644
--- a/.gitlab/mom6-ci-run-gnu-script.sh
+++ b/.gitlab/mom6-ci-run-gnu-script.sh
@@ -1,4 +1,7 @@
#!/bin/bash
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
sect=none
clean_stats () { # fn to clean up stats files
diff --git a/.gitlab/mom6-ci-run-intel-script.sh b/.gitlab/mom6-ci-run-intel-script.sh
index 875d60c191..01a2888e80 100644
--- a/.gitlab/mom6-ci-run-intel-script.sh
+++ b/.gitlab/mom6-ci-run-intel-script.sh
@@ -1,4 +1,7 @@
#!/bin/bash
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
sect=none
clean_stats () { # fn to clean up stats files
diff --git a/.gitlab/mom6-ci-run-pgi-script.sh b/.gitlab/mom6-ci-run-pgi-script.sh
index 27216e4a9f..4e55b5ced8 100644
--- a/.gitlab/mom6-ci-run-pgi-script.sh
+++ b/.gitlab/mom6-ci-run-pgi-script.sh
@@ -1,4 +1,7 @@
#!/bin/bash
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
sect=none
clean_stats () { # fn to clean up stats files
diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh
index d948b72008..018e0e3a08 100755
--- a/.gitlab/pipeline-ci-tool.sh
+++ b/.gitlab/pipeline-ci-tool.sh
@@ -1,4 +1,7 @@
#!/bin/bash
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
# Environment variables set by gitlab (the CI environment)
if [ -z $JOB_DIR ]; then
@@ -161,7 +164,14 @@ nolibs-ocean-ice-compile () {
mkdir -p build-ocean-ice-nolibs-$1
cd build-ocean-ice-nolibs-$1
make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. ENVIRON=../../environ -s
- ../src/mkmf/bin/list_paths -l ../src/MOM6/config_src/{drivers/FMS_cap,memory/dynamic_symmetric,infra/FMS1,ext*} ../src/MOM6/src ../src/SIS2/*src ../src/icebergs/src ../src/{FMS1,coupler,ice_param,land_null,atmos_null}
+ ../src/mkmf/bin/list_paths -l \
+ ../src/MOM6/config_src/{drivers/FMS_cap,memory/dynamic_symmetric,infra/FMS1,ext*} \
+ ../src/MOM6/src \
+ ../src/SIS2/src \
+ ../src/SIS2/config_src/dynamic_symmetric \
+ ../src/SIS2/config_src/external/Icepack_interfaces \
+ ../src/icebergs/src \
+ ../src/{FMS1,coupler,ice_param,land_null,atmos_null}
sed -i '/FMS1\/.*\/test_/d' path_names
../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc5-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names
(source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j)
diff --git a/.testing/Makefile b/.testing/Makefile
index ec6e5d1075..e40dd9f551 100644
--- a/.testing/Makefile
+++ b/.testing/Makefile
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
# MOM6 Test suite Makefile
#
# Usage:
@@ -71,14 +75,15 @@ MAKEFLAGS += --no-builtin-variables
.SUFFIXES:
# Determine the MOM6 autoconf srcdir
-AC_SRCDIR := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))../ac
+CODEBASE := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))..
+AC_SRCDIR := $(CODEBASE)/ac
# User-defined configuration
-include config.mk
# Set the FMS library
-FMS_COMMIT ?= 2023.03
-FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git
+FMS_COMMIT ?= 7e526687b96ca685100f73edf7ef49214d5d5a19
+FMS_URL ?= https://github.com/TURBO-ESM/FMS.git
export FMS_COMMIT
export FMS_URL
@@ -144,6 +149,10 @@ BUILD ?= $(WORKSPACE)/build
DEPS ?= $(BUILD)/deps
WORK ?= $(WORKSPACE)/work
+# External tools
+MAKEDEP ?= $(abspath $(AC_SRCDIR)/makedep)
+PKG ?= $(abspath $(CODEBASE)/pkg)
+
# Experiment configuration
EXECS ?= symmetric/MOM6 asymmetric/MOM6 openmp/MOM6
CONFIGS ?= $(wildcard tc*)
@@ -213,10 +222,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 +237,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 +246,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)
@@ -260,6 +267,7 @@ $(BUILD)/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS)
$(BUILD)/timing/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS)
# Configure script flags
+MOM_ACFLAGS := --with-gsw --with-cvmix
$(BUILD)/openmp/Makefile: MOM_ACFLAGS += --enable-openmp
$(BUILD)/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap
$(BUILD)/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap
@@ -271,12 +279,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 +306,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
@@ -309,8 +321,8 @@ FORCE:
$(BUILD)/%/Makefile: $(BUILD)/%/Makefile.in $(BUILD)/%/config.status
cd $(@D) && ./config.status
-$(BUILD)/%/config.status: $(BUILD)/%/configure $(DEPS)/lib/libFMS.a
- cd $(@D) && $(MOM_ENV) ./configure -n --srcdir=$(AC_SRCDIR) $(MOM_ACFLAGS) \
+$(BUILD)/%/config.status: $(BUILD)/%/configure $(DEPS)/lib/libFMS.a $(DEPS)/lib/libgsw.a $(DEPS)/lib/libcvmix.a
+ cd $(@D) && $(MOM_ENV) ./configure -n --srcdir=$(CODEBASE) $(MOM_ACFLAGS) \
|| (cat config.log && false)
$(BUILD)/%/Makefile.in: ../ac/Makefile.in | $(BUILD)/%/
@@ -330,25 +342,26 @@ 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
+## Dependencies
# Set up the FMS build environment variables
-FMS_ENV = \
- PATH="${PATH}:$(realpath ../ac)" \
+DEPS_ENV = \
FCFLAGS="$(FCFLAGS_FMS)" \
+ MAKEDEP=$(MAKEDEP) \
REPORT_ERROR_LOGS="$(REPORT_ERROR_LOGS)"
-$(DEPS)/lib/libFMS.a: $(DEPS)/Makefile $(DEPS)/Makefile.fms.in $(DEPS)/configure.fms.ac $(DEPS)/m4
- $(FMS_ENV) $(MAKE) -C $(DEPS) lib/libFMS.a
+# FMS
-$(DEPS)/Makefile: ../ac/deps/Makefile | $(DEPS)
- cp ../ac/deps/Makefile $(DEPS)/Makefile
+$(DEPS)/lib/libFMS.a: $(DEPS)/Makefile $(DEPS)/Makefile.fms.in $(DEPS)/configure.fms.ac $(DEPS)/m4
+ $(DEPS_ENV) $(MAKE) -C $(DEPS) lib/libFMS.a
$(DEPS)/Makefile.fms.in: ../ac/deps/Makefile.fms.in | $(DEPS)
cp ../ac/deps/Makefile.fms.in $(DEPS)/Makefile.fms.in
@@ -356,12 +369,40 @@ $(DEPS)/Makefile.fms.in: ../ac/deps/Makefile.fms.in | $(DEPS)
$(DEPS)/configure.fms.ac: ../ac/deps/configure.fms.ac | $(DEPS)
cp ../ac/deps/configure.fms.ac $(DEPS)/configure.fms.ac
+# GSW
+
+$(DEPS)/lib/libgsw.a: $(DEPS)/Makefile $(DEPS)/Makefile.gsw.in $(DEPS)/configure.gsw.ac $(DEPS)/m4
+ $(DEPS_ENV) PKG=$(PKG) $(MAKE) -C $(DEPS) lib/libgsw.a
+
+$(DEPS)/Makefile.gsw.in: ../ac/deps/Makefile.gsw.in | $(DEPS)
+ cp ../ac/deps/Makefile.gsw.in $(DEPS)/Makefile.gsw.in
+
+$(DEPS)/configure.gsw.ac: ../ac/deps/configure.gsw.ac | $(DEPS)
+ cp ../ac/deps/configure.gsw.ac $(DEPS)/configure.gsw.ac
+
+# CVMix
+
+$(DEPS)/lib/libcvmix.a: $(DEPS)/Makefile $(DEPS)/Makefile.cvmix.in $(DEPS)/configure.cvmix.ac $(DEPS)/m4
+ $(DEPS_ENV) PKG=$(PKG) $(MAKE) -C $(DEPS) lib/libcvmix.a
+
+$(DEPS)/Makefile.cvmix.in: ../ac/deps/Makefile.cvmix.in | $(DEPS)
+ cp ../ac/deps/Makefile.cvmix.in $(DEPS)/Makefile.cvmix.in
+
+$(DEPS)/configure.cvmix.ac: ../ac/deps/configure.cvmix.ac | $(DEPS)
+ cp ../ac/deps/configure.cvmix.ac $(DEPS)/configure.cvmix.ac
+
+# Generic dependency content
+
+$(DEPS)/Makefile: ../ac/deps/Makefile | $(DEPS)
+ cp ../ac/deps/Makefile $(DEPS)/Makefile
+
$(DEPS)/m4: ../ac/deps/m4 | $(DEPS)
cp -r ../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 +649,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 +707,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/tc0/MOM_input b/.testing/tc0/MOM_input
index 7a107486b2..17f4826c8c 100644
--- a/.testing/tc0/MOM_input
+++ b/.testing/tc0/MOM_input
@@ -233,9 +233,11 @@ ENERGYSAVEDAYS = 1.0
DIAG_AS_CHKSUM = True
DEBUG = True
-GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True
-USE_GM_WORK_BUG = True ! [Boolean] default = True
-FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False
+
USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False
GUST_CONST = 0.02 ! [Pa] default = 0.02
-FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
+
+! These are no longer necessary, as they are using the default value.
+GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False
+USE_GM_WORK_BUG = False ! [Boolean] default = False
+USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
diff --git a/.testing/tc1.a/MOM_tc_variant b/.testing/tc1.a/MOM_tc_variant
index 26407baf50..88a38a8fa8 100644
--- a/.testing/tc1.a/MOM_tc_variant
+++ b/.testing/tc1.a/MOM_tc_variant
@@ -1,2 +1,3 @@
-#override SPLIT=False
-#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False
+#override SPLIT = False
+#override UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False
+#override EQN_OF_STATE = "ROQUET_RHO" ! default = "WRIGHT_FULL"
diff --git a/.testing/tc1.b/MOM_tc_variant b/.testing/tc1.b/MOM_tc_variant
index 173196f164..7e3d0aa6bd 100644
--- a/.testing/tc1.b/MOM_tc_variant
+++ b/.testing/tc1.b/MOM_tc_variant
@@ -1,3 +1,7 @@
-#override SPLIT=False
-#override USE_RK2=True
-#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False
+#override SPLIT = False
+#override USE_RK2 = True
+#override UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False
+
+! There may be a problem with one of these settings.
+! #override EQN_OF_STATE = "ROQUET_SPV" ! default = "WRIGHT_FULL"
+! #override BOUSSINESQ = FALSE
diff --git a/.testing/tc1/MOM_input b/.testing/tc1/MOM_input
index 098952ccc2..c7add5d5b7 100644
--- a/.testing/tc1/MOM_input
+++ b/.testing/tc1/MOM_input
@@ -584,14 +584,27 @@ ENERGYSAVEDAYS = 0.125 ! [days] default = 3600.0
DIAG_AS_CHKSUM = True
DEBUG = True
USE_PSURF_IN_EOS = False ! [Boolean] default = False
-GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True
INTERPOLATE_RES_FN = True ! [Boolean] default = True
GILL_EQUATORIAL_LD = False ! [Boolean] default = False
-USE_GM_WORK_BUG = True ! [Boolean] default = True
USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False
-KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True
-KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True
-BULKML_CONV_MOMENTUM_BUG = True ! [Boolean] default = True
PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001
GUST_CONST = 0.02 ! [Pa] default = 0.02
-FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
+
+
+! Updated defaults reflecting the model status in late 2025
+DRAG_DIFFUSIVITY_ANSWER_DATE = 20251231
+EQN_OF_STATE = "WRIGHT_FULL" ! default = "WRIGHT_FULL"
+HOR_DIFF_ANSWER_DATE = 20251231
+MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = True ! [Boolean] default = True
+
+! These are no longer necessary, as they are using the default value.
+HOR_DIFF_LIMIT_BUG = False ! [Boolean] default = False
+GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False
+USE_GM_WORK_BUG = False ! [Boolean] default = False
+USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
+KAPPA_SHEAR_ITER_BUG = False ! [Boolean] default = False
+KAPPA_SHEAR_ALL_LAYER_TKE_BUG = False ! [Boolean] default = False
+VISC_REM_BUG = False ! [Boolean] default = False
+FRICTWORK_BUG = False ! [Boolean] default = False
+BULKML_CONV_MOMENTUM_BUG = False ! [Boolean] default = False
+
diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input
index c8aad58e92..fea7ca25d1 100644
--- a/.testing/tc2/MOM_input
+++ b/.testing/tc2/MOM_input
@@ -616,14 +616,29 @@ ENERGYSAVEDAYS = 0.5 ! [days] default = 3600.0
! energies of the run and other globally summed diagnostics.
DIAG_AS_CHKSUM = True
DEBUG = True
-USE_GM_WORK_BUG = False
+
USE_PSURF_IN_EOS = False ! [Boolean] default = False
-GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True
REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = True
USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False
-KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True
-KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True
USE_MLD_ITERATION = False ! [Boolean] default = False
PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001
GUST_CONST = 0.02 ! [Pa] default = 0.02
-FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
+
+! Updated defaults reflecting the model status in late 2025
+EQN_OF_STATE = "WRIGHT" ! default = "WRIGHT_FULL"
+TIDES_ANSWER_DATE = 20251231
+NDIFF_ANSWER_DATE = 20251231
+DRAG_DIFFUSIVITY_ANSWER_DATE = 20251231
+MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = True ! [Boolean] default = True
+
+! These are no longer necessary, as they are using the default value.
+GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False
+USE_GM_WORK_BUG = False ! [Boolean] default = False
+USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
+KAPPA_SHEAR_ITER_BUG = False ! [Boolean] default = False
+KAPPA_SHEAR_ALL_LAYER_TKE_BUG = False ! [Boolean] default = False
+VISC_REM_BUG = False ! [Boolean] default = False
+FRICTWORK_BUG = False ! [Boolean] default = False
+
+
+BACKSCATTER_UNDERBOUND = True
diff --git a/.testing/tc2/MOM_tc_variant b/.testing/tc2/MOM_tc_variant
index 8cdbf69de8..f2668c75de 100644
--- a/.testing/tc2/MOM_tc_variant
+++ b/.testing/tc2/MOM_tc_variant
@@ -10,3 +10,7 @@ TIDE_Q1 = True
TIDE_MF = True
TIDE_MM = True
TIDE_SAL_SCALAR_VALUE = 1.
+BT_STRONG_DRAG = True ! [Boolean] default = False
+
+! Disabled for dev/gpu merge
+!RESCALE_STRONG_DRAG = True ! [Boolean] default = False
diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input
index 6a1238ee96..0c6a503db4 100644
--- a/.testing/tc3/MOM_input
+++ b/.testing/tc3/MOM_input
@@ -473,10 +473,18 @@ ENERGYSAVEDAYS = 3.0 ! [hours] default = 1.44E+04
DIAG_AS_CHKSUM = True
DEBUG = True
OBC_RADIATION_MAX = 10.0 ! [nondim] default = 10.0
-GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True
-USE_GM_WORK_BUG = True ! [Boolean] default = True
+
USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False
-KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True
-KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True
GUST_CONST = 0.02 ! [Pa] default = 0.02
-FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
+
+! Updated defaults reflecting the model status in late 2025
+DRAG_DIFFUSIVITY_ANSWER_DATE = 20251231
+
+! These are no longer necessary, as they are using the default value.
+GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False
+USE_GM_WORK_BUG = False ! [Boolean] default = False
+USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
+KAPPA_SHEAR_ITER_BUG = False ! [Boolean] default = False
+KAPPA_SHEAR_ALL_LAYER_TKE_BUG = False ! [Boolean] default = False
+VISC_REM_BUG = False ! [Boolean] default = False
+FRICTWORK_BUG = False ! [Boolean] default = False
diff --git a/.testing/tc4/.gitignore b/.testing/tc4/.gitignore
index 4f9cc2826f..0532a48da7 100644
--- a/.testing/tc4/.gitignore
+++ b/.testing/tc4/.gitignore
@@ -3,7 +3,9 @@ aclocal.m4
autom4te.cache/
config.log
config.status
+configure
configure~
+Makefile
# Output
gen_grid
diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input
index b985b8e082..fc9c42298d 100644
--- a/.testing/tc4/MOM_input
+++ b/.testing/tc4/MOM_input
@@ -92,10 +92,6 @@ ROTATION = "betaplane" ! default = "2omegasinlat"
! USER - call a user modified routine.
F_0 = 1.0E-04 ! [s-1] default = 0.0
! The reference value of the Coriolis parameter with the betaplane option.
-GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = False
- ! If true, use an older algorithm to calculate the sine and cosines needed
- ! rotate between grid-oriented directions and true north and east. Differences
- ! arise at the tripolar fold.
! === module MOM_tracer_registry ===
@@ -234,9 +230,6 @@ KV = 1.0E-04 ! [m2 s-1]
! === module MOM_thickness_diffuse ===
KHTH = 500.0 ! [m2 s-1] default = 0.0
! The background horizontal thickness diffusivity.
-USE_GM_WORK_BUG = True ! [Boolean] default = False
- ! If true, compute the top-layer work tendency on the u-grid with the incorrect
- ! sign, for legacy reproducibility.
! === module MOM_porous_barriers ===
@@ -381,9 +374,6 @@ WIND_CONFIG = "zero" !
! options include (file), (2gyre), (1gyre), (gyres), (zero), and (USER).
GUST_CONST = 0.02 ! [Pa] default = 0.0
! The background gustiness in the winds.
-FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = True
- ! If true correct a bug in the time-averaging of the gustless wind friction
- ! velocity
! === module MOM_main (MOM_driver) ===
DAYMAX = 0.25 ! [days]
@@ -411,9 +401,16 @@ DEBUG = True
INTERPOLATE_RES_FN = True ! [Boolean] default = True
GILL_EQUATORIAL_LD = False ! [Boolean] default = False
-FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False
USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False
-KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True
-KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True
USE_MLD_ITERATION = False ! [Boolean] default = False
+MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = True ! [Boolean] default = True
+
+! These are no longer necessary, as they are using the default value.
+GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False
+USE_GM_WORK_BUG = False ! [Boolean] default = False
+USTAR_GUSTLESS_BUG = False ! [Boolean] default = False
+KAPPA_SHEAR_ITER_BUG = False ! [Boolean] default = False
+KAPPA_SHEAR_ALL_LAYER_TKE_BUG = False ! [Boolean] default = False
+VISC_REM_BUG = False ! [Boolean] default = False
+FRICTWORK_BUG = False ! [Boolean] default = False
diff --git a/.testing/tc4/Makefile.in b/.testing/tc4/Makefile.in
index 714a8f19f1..4d2e40a1bb 100644
--- a/.testing/tc4/Makefile.in
+++ b/.testing/tc4/Makefile.in
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
FC = @FC@
LD = @LD@
FCFLAGS = @FCFLAGS@
diff --git a/.testing/tc4/configure.ac b/.testing/tc4/configure.ac
index c431ad65ef..2ec7e2af44 100644
--- a/.testing/tc4/configure.ac
+++ b/.testing/tc4/configure.ac
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
# tc4 preprocessor configuration
AC_PREREQ([2.63])
AC_INIT([], [])
@@ -47,24 +51,29 @@ AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [
])
# Confirm that the Fortran compiler can link to the netCDF Fortran library.
-# NOTE:
-# - We test nf_create, rather than nf90_create, since AX_FC_CHECK_LIB can
-# not currently probe the Fortran 90 interfaces.
-# - nf-config does not have --libdir, so we parse the --flibs output.
-AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [
- AS_UNSET([ax_fc_cv_lib_netcdff_nf_create])
- AC_PATH_PROG([NF_CONFIG], [nf-config])
- AS_IF([test -n "$NF_CONFIG"], [
- AC_SUBST([LDFLAGS],
- ["$LDFLAGS $($NF_CONFIG --flibs | xargs -n1 | grep "^-L" | sort -u | xargs)"]
+# NOTE: nf-config does not have --libdir, so we parse the --flibs output.
+MOM6_FC_CHECK_LIB([netcdff], [nf90_create], [netcdf], [path,cmode,ncid], [rc], [
+ character :: path
+ integer :: cmode, ncid, rc],
+ [], [
+ AS_UNSET([mom6_fc_cv_lib_netcdff_nf90_create])
+ AC_PATH_PROG([NF_CONFIG], [nf-config])
+ AS_IF([test -n "$NF_CONFIG"], [
+ AC_SUBST([LDFLAGS],
+ ["$LDFLAGS $($NF_CONFIG --flibs | xargs -n1 | grep "^-L" | sort -u | xargs)"]
+ )
+ ], [
+ AC_MSG_ERROR([Could not find nf-config.])
+ ])
+ MOM6_FC_CHECK_LIB([netcdff], [nf90_create], [netcdf], [path,cmode,ncid], [rc], [
+ character :: path
+ integer :: cmode, ncid, rc],
+ [], [
+ AC_MSG_ERROR([Could not find netCDF Fortran library.])
+ ]
)
- ], [
- AC_MSG_ERROR([Could not find nf-config.])
- ])
- AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [
- AC_MSG_ERROR([Could not find netCDF Fortran library.])
- ])
-])
+ ]
+)
AC_CONFIG_FILES([Makefile])
diff --git a/.testing/tc4/gen_data.F90 b/.testing/tc4/gen_data.F90
index 8f44aa1465..406d44e54a 100644
--- a/.testing/tc4/gen_data.F90
+++ b/.testing/tc4/gen_data.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
use netcdf
implicit none
diff --git a/.testing/tc4/gen_grid.F90 b/.testing/tc4/gen_grid.F90
index e76a681924..4ddabb7846 100644
--- a/.testing/tc4/gen_grid.F90
+++ b/.testing/tc4/gen_grid.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
use netcdf
implicit none
diff --git a/.testing/tools/cmp_diag.sh b/.testing/tools/cmp_diag.sh
index 03f29a5fd2..8bf0fd806f 100755
--- a/.testing/tools/cmp_diag.sh
+++ b/.testing/tools/cmp_diag.sh
@@ -1,4 +1,7 @@
#!/bin/bash
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
for chk in $1 $2; do
awk '{print $(NF-2) " " $(NF-1) " " $(NF),$0}' ${chk} | sort > ${chk}.sorted
diff --git a/.testing/tools/compare_clocks.py b/.testing/tools/compare_clocks.py
index 77198fda6a..09e6fe2439 100755
--- a/.testing/tools/compare_clocks.py
+++ b/.testing/tools/compare_clocks.py
@@ -1,4 +1,8 @@
#!/usr/bin/env python
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
import argparse
import json
diff --git a/.testing/tools/compare_perf.py b/.testing/tools/compare_perf.py
index 7b1f3fda8d..65afc58c01 100755
--- a/.testing/tools/compare_perf.py
+++ b/.testing/tools/compare_perf.py
@@ -1,4 +1,8 @@
#!/usr/bin/env python
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
import argparse
import json
diff --git a/.testing/tools/diff_diag.sh b/.testing/tools/diff_diag.sh
index de9745df6a..edbd0c934f 100755
--- a/.testing/tools/diff_diag.sh
+++ b/.testing/tools/diff_diag.sh
@@ -1,4 +1,7 @@
#!/bin/bash
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
for chk in $1 $2; do
awk '{print $(NF-2) " " $(NF-1) " " $(NF),$0}' ${chk} | sort > ${chk}.sorted
diff --git a/.testing/tools/disp_timing.py b/.testing/tools/disp_timing.py
index ac90ef2b55..55637abbef 100755
--- a/.testing/tools/disp_timing.py
+++ b/.testing/tools/disp_timing.py
@@ -1,4 +1,7 @@
#!/usr/bin/env python3
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
from __future__ import print_function
@@ -12,11 +15,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 +41,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 +117,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/.testing/tools/parse_fms_clocks.py b/.testing/tools/parse_fms_clocks.py
index fd3e7179d7..4125f09475 100755
--- a/.testing/tools/parse_fms_clocks.py
+++ b/.testing/tools/parse_fms_clocks.py
@@ -1,4 +1,8 @@
#!/usr/bin/env python
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
import argparse
import collections
import json
diff --git a/.testing/tools/parse_perf.py b/.testing/tools/parse_perf.py
index efcfa13b4f..4673022756 100755
--- a/.testing/tools/parse_perf.py
+++ b/.testing/tools/parse_perf.py
@@ -1,4 +1,8 @@
#!/usr/bin/env python
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
import argparse
import collections
import json
diff --git a/.testing/tools/report_test_results.sh b/.testing/tools/report_test_results.sh
index 24bab45507..bc5376a837 100755
--- a/.testing/tools/report_test_results.sh
+++ b/.testing/tools/report_test_results.sh
@@ -1,4 +1,8 @@
#!/bin/sh
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
RESULTS=${1:-${PWD}/results}
GREEN="\033[0;32m"
diff --git a/.testing/trailer.py b/.testing/trailer.py
index 64f016275f..495f1cc6e3 100755
--- a/.testing/trailer.py
+++ b/.testing/trailer.py
@@ -1,4 +1,8 @@
#!/usr/bin/env python
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
"""Subroutines for Validating the whitespace of the source code."""
import argparse
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000000..f433b1a53f
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,177 @@
+
+ Apache License
+ Version 2.0, January 2004
+ http://www.apache.org/licenses/
+
+ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
+
+ 1. Definitions.
+
+ "License" shall mean the terms and conditions for use, reproduction,
+ and distribution as defined by Sections 1 through 9 of this document.
+
+ "Licensor" shall mean the copyright owner or entity authorized by
+ the copyright owner that is granting the License.
+
+ "Legal Entity" shall mean the union of the acting entity and all
+ other entities that control, are controlled by, or are under common
+ control with that entity. For the purposes of this definition,
+ "control" means (i) the power, direct or indirect, to cause the
+ direction or management of such entity, whether by contract or
+ otherwise, or (ii) ownership of fifty percent (50%) or more of the
+ outstanding shares, or (iii) beneficial ownership of such entity.
+
+ "You" (or "Your") shall mean an individual or Legal Entity
+ exercising permissions granted by this License.
+
+ "Source" form shall mean the preferred form for making modifications,
+ including but not limited to software source code, documentation
+ source, and configuration files.
+
+ "Object" form shall mean any form resulting from mechanical
+ transformation or translation of a Source form, including but
+ not limited to compiled object code, generated documentation,
+ and conversions to other media types.
+
+ "Work" shall mean the work of authorship, whether in Source or
+ Object form, made available under the License, as indicated by a
+ copyright notice that is included in or attached to the work
+ (an example is provided in the Appendix below).
+
+ "Derivative Works" shall mean any work, whether in Source or Object
+ form, that is based on (or derived from) the Work and for which the
+ editorial revisions, annotations, elaborations, or other modifications
+ represent, as a whole, an original work of authorship. For the purposes
+ of this License, Derivative Works shall not include works that remain
+ separable from, or merely link (or bind by name) to the interfaces of,
+ the Work and Derivative Works thereof.
+
+ "Contribution" shall mean any work of authorship, including
+ the original version of the Work and any modifications or additions
+ to that Work or Derivative Works thereof, that is intentionally
+ submitted to Licensor for inclusion in the Work by the copyright owner
+ or by an individual or Legal Entity authorized to submit on behalf of
+ the copyright owner. For the purposes of this definition, "submitted"
+ means any form of electronic, verbal, or written communication sent
+ to the Licensor or its representatives, including but not limited to
+ communication on electronic mailing lists, source code control systems,
+ and issue tracking systems that are managed by, or on behalf of, the
+ Licensor for the purpose of discussing and improving the Work, but
+ excluding communication that is conspicuously marked or otherwise
+ designated in writing by the copyright owner as "Not a Contribution."
+
+ "Contributor" shall mean Licensor and any individual or Legal Entity
+ on behalf of whom a Contribution has been received by Licensor and
+ subsequently incorporated within the Work.
+
+ 2. Grant of Copyright License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ copyright license to reproduce, prepare Derivative Works of,
+ publicly display, publicly perform, sublicense, and distribute the
+ Work and such Derivative Works in Source or Object form.
+
+ 3. Grant of Patent License. Subject to the terms and conditions of
+ this License, each Contributor hereby grants to You a perpetual,
+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+ (except as stated in this section) patent license to make, have made,
+ use, offer to sell, sell, import, and otherwise transfer the Work,
+ where such license applies only to those patent claims licensable
+ by such Contributor that are necessarily infringed by their
+ Contribution(s) alone or by combination of their Contribution(s)
+ with the Work to which such Contribution(s) was submitted. If You
+ institute patent litigation against any entity (including a
+ cross-claim or counterclaim in a lawsuit) alleging that the Work
+ or a Contribution incorporated within the Work constitutes direct
+ or contributory patent infringement, then any patent licenses
+ granted to You under this License for that Work shall terminate
+ as of the date such litigation is filed.
+
+ 4. Redistribution. You may reproduce and distribute copies of the
+ Work or Derivative Works thereof in any medium, with or without
+ modifications, and in Source or Object form, provided that You
+ meet the following conditions:
+
+ (a) You must give any other recipients of the Work or
+ Derivative Works a copy of this License; and
+
+ (b) You must cause any modified files to carry prominent notices
+ stating that You changed the files; and
+
+ (c) You must retain, in the Source form of any Derivative Works
+ that You distribute, all copyright, patent, trademark, and
+ attribution notices from the Source form of the Work,
+ excluding those notices that do not pertain to any part of
+ the Derivative Works; and
+
+ (d) If the Work includes a "NOTICE" text file as part of its
+ distribution, then any Derivative Works that You distribute must
+ include a readable copy of the attribution notices contained
+ within such NOTICE file, excluding those notices that do not
+ pertain to any part of the Derivative Works, in at least one
+ of the following places: within a NOTICE text file distributed
+ as part of the Derivative Works; within the Source form or
+ documentation, if provided along with the Derivative Works; or,
+ within a display generated by the Derivative Works, if and
+ wherever such third-party notices normally appear. The contents
+ of the NOTICE file are for informational purposes only and
+ do not modify the License. You may add Your own attribution
+ notices within Derivative Works that You distribute, alongside
+ or as an addendum to the NOTICE text from the Work, provided
+ that such additional attribution notices cannot be construed
+ as modifying the License.
+
+ You may add Your own copyright statement to Your modifications and
+ may provide additional or different license terms and conditions
+ for use, reproduction, or distribution of Your modifications, or
+ for any such Derivative Works as a whole, provided Your use,
+ reproduction, and distribution of the Work otherwise complies with
+ the conditions stated in this License.
+
+ 5. Submission of Contributions. Unless You explicitly state otherwise,
+ any Contribution intentionally submitted for inclusion in the Work
+ by You to the Licensor shall be under the terms and conditions of
+ this License, without any additional terms or conditions.
+ Notwithstanding the above, nothing herein shall supersede or modify
+ the terms of any separate license agreement you may have executed
+ with Licensor regarding such Contributions.
+
+ 6. Trademarks. This License does not grant permission to use the trade
+ names, trademarks, service marks, or product names of the Licensor,
+ except as required for reasonable and customary use in describing the
+ origin of the Work and reproducing the content of the NOTICE file.
+
+ 7. Disclaimer of Warranty. Unless required by applicable law or
+ agreed to in writing, Licensor provides the Work (and each
+ Contributor provides its Contributions) on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+ implied, including, without limitation, any warranties or conditions
+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+ PARTICULAR PURPOSE. You are solely responsible for determining the
+ appropriateness of using or redistributing the Work and assume any
+ risks associated with Your exercise of permissions under this License.
+
+ 8. Limitation of Liability. In no event and under no legal theory,
+ whether in tort (including negligence), contract, or otherwise,
+ unless required by applicable law (such as deliberate and grossly
+ negligent acts) or agreed to in writing, shall any Contributor be
+ liable to You for damages, including any direct, indirect, special,
+ incidental, or consequential damages of any character arising as a
+ result of this License or out of the use or inability to use the
+ Work (including but not limited to damages for loss of goodwill,
+ work stoppage, computer failure or malfunction, or any and all
+ other commercial damages or losses), even if such Contributor
+ has been advised of the possibility of such damages.
+
+ 9. Accepting Warranty or Additional Liability. While redistributing
+ the Work or Derivative Works thereof, You may choose to offer,
+ and charge a fee for, acceptance of support, warranty, indemnity,
+ or other liability obligations and/or rights consistent with this
+ License. However, in accepting such obligations, You may act only
+ on Your own behalf and on Your sole responsibility, not on behalf
+ of any other Contributor, and only if You agree to indemnify,
+ defend, and hold each Contributor harmless for any liability
+ incurred by, or claims asserted against, such Contributor by reason
+ of your accepting any such warranty or additional liability.
+
+ END OF TERMS AND CONDITIONS
diff --git a/LICENSE.md b/LICENSE.md
deleted file mode 100644
index 5528208587..0000000000
--- a/LICENSE.md
+++ /dev/null
@@ -1,173 +0,0 @@
-This file is part of the Modular Ocean Model, referred to as MOM, which is made
-available under version 3 of the Gnu Lesser General Public License, which is
-provided below.
-
-The intent of this license is to ensure free and unrestricted access to the MOM
-software, and to pass on those rights to modified versions this software.
-
-
- GNU LESSER GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc.
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-
- This version of the GNU Lesser General Public License incorporates
-the terms and conditions of version 3 of the GNU General Public
-License, supplemented by the additional permissions listed below.
-
- 0. Additional Definitions.
-
- As used herein, "this License" refers to version 3 of the GNU Lesser
-General Public License, and the "GNU GPL" refers to version 3 of the GNU
-General Public License.
-
- "The Library" refers to a covered work governed by this License,
-other than an Application or a Combined Work as defined below.
-
- An "Application" is any work that makes use of an interface provided
-by the Library, but which is not otherwise based on the Library.
-Defining a subclass of a class defined by the Library is deemed a mode
-of using an interface provided by the Library.
-
- A "Combined Work" is a work produced by combining or linking an
-Application with the Library. The particular version of the Library
-with which the Combined Work was made is also called the "Linked
-Version".
-
- The "Minimal Corresponding Source" for a Combined Work means the
-Corresponding Source for the Combined Work, excluding any source code
-for portions of the Combined Work that, considered in isolation, are
-based on the Application, and not on the Linked Version.
-
- The "Corresponding Application Code" for a Combined Work means the
-object code and/or source code for the Application, including any data
-and utility programs needed for reproducing the Combined Work from the
-Application, but excluding the System Libraries of the Combined Work.
-
- 1. Exception to Section 3 of the GNU GPL.
-
- You may convey a covered work under sections 3 and 4 of this License
-without being bound by section 3 of the GNU GPL.
-
- 2. Conveying Modified Versions.
-
- If you modify a copy of the Library, and, in your modifications, a
-facility refers to a function or data to be supplied by an Application
-that uses the facility (other than as an argument passed when the
-facility is invoked), then you may convey a copy of the modified
-version:
-
- a) under this License, provided that you make a good faith effort to
- ensure that, in the event an Application does not supply the
- function or data, the facility still operates, and performs
- whatever part of its purpose remains meaningful, or
-
- b) under the GNU GPL, with none of the additional permissions of
- this License applicable to that copy.
-
- 3. Object Code Incorporating Material from Library Header Files.
-
- The object code form of an Application may incorporate material from
-a header file that is part of the Library. You may convey such object
-code under terms of your choice, provided that, if the incorporated
-material is not limited to numerical parameters, data structure
-layouts and accessors, or small macros, inline functions and templates
-(ten or fewer lines in length), you do both of the following:
-
- a) Give prominent notice with each copy of the object code that the
- Library is used in it and that the Library and its use are
- covered by this License.
-
- b) Accompany the object code with a copy of the GNU GPL and this license
- document.
-
- 4. Combined Works.
-
- You may convey a Combined Work under terms of your choice that,
-taken together, effectively do not restrict modification of the
-portions of the Library contained in the Combined Work and reverse
-engineering for debugging such modifications, if you also do each of
-the following:
-
- a) Give prominent notice with each copy of the Combined Work that
- the Library is used in it and that the Library and its use are
- covered by this License.
-
- b) Accompany the Combined Work with a copy of the GNU GPL and this license
- document.
-
- c) For a Combined Work that displays copyright notices during
- execution, include the copyright notice for the Library among
- these notices, as well as a reference directing the user to the
- copies of the GNU GPL and this license document.
-
- d) Do one of the following:
-
- 0) Convey the Minimal Corresponding Source under the terms of this
- License, and the Corresponding Application Code in a form
- suitable for, and under terms that permit, the user to
- recombine or relink the Application with a modified version of
- the Linked Version to produce a modified Combined Work, in the
- manner specified by section 6 of the GNU GPL for conveying
- Corresponding Source.
-
- 1) Use a suitable shared library mechanism for linking with the
- Library. A suitable mechanism is one that (a) uses at run time
- a copy of the Library already present on the user's computer
- system, and (b) will operate properly with a modified version
- of the Library that is interface-compatible with the Linked
- Version.
-
- e) Provide Installation Information, but only if you would otherwise
- be required to provide such information under section 6 of the
- GNU GPL, and only to the extent that such information is
- necessary to install and execute a modified version of the
- Combined Work produced by recombining or relinking the
- Application with a modified version of the Linked Version. (If
- you use option 4d0, the Installation Information must accompany
- the Minimal Corresponding Source and Corresponding Application
- Code. If you use option 4d1, you must provide the Installation
- Information in the manner specified by section 6 of the GNU GPL
- for conveying Corresponding Source.)
-
- 5. Combined Libraries.
-
- You may place library facilities that are a work based on the
-Library side by side in a single library together with other library
-facilities that are not Applications and are not covered by this
-License, and convey such a combined library under terms of your
-choice, if you do both of the following:
-
- a) Accompany the combined library with a copy of the same work based
- on the Library, uncombined with any other library facilities,
- conveyed under the terms of this License.
-
- b) Give prominent notice with the combined library that part of it
- is a work based on the Library, and explaining where to find the
- accompanying uncombined form of the same work.
-
- 6. Revised Versions of the GNU Lesser General Public License.
-
- The Free Software Foundation may publish revised and/or new versions
-of the GNU Lesser General Public License from time to time. Such new
-versions will be similar in spirit to the present version, but may
-differ in detail to address new problems or concerns.
-
- Each version is given a distinguishing version number. If the
-Library as you received it specifies that a certain numbered version
-of the GNU Lesser General Public License "or any later version"
-applies to it, you have the option of following the terms and
-conditions either of that published version or of any later version
-published by the Free Software Foundation. If the Library as you
-received it does not specify a version number of the GNU Lesser
-General Public License, you may choose any version of the GNU Lesser
-General Public License ever published by the Free Software Foundation.
-
- If the Library as you received it specifies that a proxy can decide
-whether future versions of the GNU Lesser General Public License shall
-apply, that proxy's public statement of acceptance of any version is
-permanent authorization for you to choose that version for the
-Library.
diff --git a/ac/Makefile.in b/ac/Makefile.in
index c4d23efdfb..148c2af534 100644
--- a/ac/Makefile.in
+++ b/ac/Makefile.in
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
# Makefile template for MOM6
#
# Compiler flags are configured by autoconf's configure script.
@@ -14,8 +18,7 @@ CPPFLAGS = @CPPFLAGS@
FCFLAGS = @FCFLAGS@
LDFLAGS = @LDFLAGS@
LIBS = @LIBS@
-SRC_DIRS = @SRC_DIRS@
-
+MAKEDEP_FLAGS = @MAKEDEP_FLAGS@
-include Makefile.dep
@@ -31,8 +34,8 @@ rwildcard=$(foreach d,$(wildcard $(1:=/*)),$(call rwildcard,$d,$2) $(filter $(su
# Generate dependencies
.PHONY: depend
depend: Makefile.dep
-Makefile.dep: $(MAKEDEP) $(call rwildcard,$(SRC_DIRS),*.h *.c *.inc *.F90)
- $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e $(SRC_DIRS)
+Makefile.dep: $(call rwildcard,$(SRC_DIRS),*.h *.c *.inc *.F90)
+ $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep $(MAKEDEP_FLAGS)
# Delete any files associated with configuration (including the Makefile).
diff --git a/ac/configure.ac b/ac/configure.ac
index 071f43f5a9..6d5e29105c 100644
--- a/ac/configure.ac
+++ b/ac/configure.ac
@@ -1,45 +1,26 @@
-# Autoconf configuration
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
-# NOTE:
-# - We currently do not use a MOM6 version tag, but this would be one option in
-# the future:
-# [m4_esyscmd_s([git describe])]
-# - Another option is `git rev-parse HEAD` for the full hash.
-# - We would probably run this inside of a script to avoid the explicit
-# dependency on git.
+# Autoconf configuration
AC_PREREQ([2.63])
AC_INIT(
[MOM6],
- [ ],
+ [],
[https://github.com/NOAA-GFDL/MOM6/issues],
[],
- [https://github.com/NOAA-GFDL/MOM6])
+ [https://github.com/NOAA-GFDL/MOM6]
+)
-#---
-# NOTE: For the autoconf-adverse, the configuration files and autoreconf output
-# are kept in the `ac` directory.
-#
-# This breaks the convention where configure.ac resides in the top directory.
-#
-# As a result, $srcdir initially points to the `ac` directory, rather than the
-# top directory of the codebase.
-#
-# In order to balance this, we up-path (../) srcdir and point AC_CONFIG_SRCDIR
-# to srcdir and point AC_CONFIG_SRCDIR to the parent directory.
-#
-# Someday we may revert this and work from the top-level directory. But for
-# now we will isolate autoconf to a subdirectory.
-#---
# Validate srdcir and configure input
-AC_CONFIG_SRCDIR([../src/core/MOM.F90])
+AC_CONFIG_SRCDIR([src/core/MOM.F90])
AC_CONFIG_MACRO_DIR([m4])
-srcdir=$srcdir/..
-# Configure the memory layout header
+# MOM6 memory layout configuration
AC_ARG_VAR([MOM_MEMORY],
[Path to MOM_memory.h header, describing the field memory layout: dynamic
@@ -51,7 +32,7 @@ AS_VAR_IF([MOM_MEMORY], [],
)
# Confirm that MOM_MEMORY is named 'MOM_memory.h'
-AS_IF([test $(basename "${MOM_MEMORY}") == "MOM_memory.h"], [],
+AS_IF([test $(basename "${MOM_MEMORY}") = "MOM_memory.h"], [],
[AC_MSG_ERROR([MOM_MEMORY header ${MOM_MEMORY} must be named 'MOM_memory.h'])]
)
@@ -64,16 +45,33 @@ MOM_MEMORY_DIR=$(AS_DIRNAME(["${MOM_MEMORY}"]))
AC_SUBST([MOM_MEMORY_DIR])
-# Default to solo_driver
+# Driver configuration
DRIVER_DIR=${srcdir}/config_src/drivers/solo_driver
AC_ARG_WITH([driver],
AS_HELP_STRING(
- [--with-driver=coupled_driver|solo_driver|unit_tests],
+ [--with-driver=FMS_cap|solo_driver|unit_tests],
[Select directory for driver source code]
)
)
-AS_IF([test "x$with_driver" != "x"],
- [DRIVER_DIR=${srcdir}/config_src/drivers/${with_driver}])
+AS_IF([test -n "$with_driver"],
+ [DRIVER_DIR=${srcdir}/config_src/drivers/${with_driver}]
+)
+
+# External library configuration
+AC_ARG_WITH([gsw],
+ [AS_HELP_STRING(
+ [--with-gsw],
+ [use external Gibbs Sea Water library instead of linked source]
+ )], [], [with_gsw=no]
+)
+
+AC_ARG_WITH([cvmix],
+ [AS_HELP_STRING(
+ [--with-cvmix],
+ [use external CVMix library instead of linked source]
+ )], [], [with_cvmix=no]
+)
+
# TODO: Rather than point to a pre-configured header file, autoconf could be
# used to configure a header based on a template.
@@ -138,31 +136,41 @@ AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [
])
# Confirm that the Fortran compiler can link to the netCDF Fortran library.
-# NOTE:
-# - We test nf_create, rather than nf90_create, since AX_FC_CHECK_LIB can
-# not currently probe the Fortran 90 interfaces.
-# - nf-config does not have --libdir, so we parse the --flibs output.
-AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [
- AS_UNSET([ax_fc_cv_lib_netcdff_nf_create])
- AC_PATH_PROG([NF_CONFIG], [nf-config])
- AS_IF([test -n "$NF_CONFIG"], [
- AC_SUBST([LDFLAGS],
- ["$LDFLAGS $($NF_CONFIG --flibs | xargs -n1 | grep "^-L" | sort -u | xargs)"]
+# NOTE: nf-config does not have --libdir, so we parse the --flibs output.
+MOM6_FC_CHECK_LIB([netcdff], [nf90_create], [netcdf], [path,cmode,ncid], [rc], [
+ character :: path
+ integer :: cmode, ncid, rc],
+ [], [
+ AS_UNSET([mom6_fc_cv_lib_netcdff_nf90_create])
+ AC_PATH_PROG([NF_CONFIG], [nf-config])
+ AS_IF([test -n "$NF_CONFIG"], [
+ AC_SUBST([LDFLAGS],
+ ["$LDFLAGS $($NF_CONFIG --flibs | xargs -n1 | grep "^-L" | sort -u | xargs)"]
+ )
+ ], [
+ AC_MSG_ERROR([Could not find nf-config.])
+ ])
+ MOM6_FC_CHECK_LIB([netcdff], [nf90_create], [netcdf], [path,cmode,ncid], [rc], [
+ character :: path
+ integer :: cmode, ncid, rc],
+ [], [
+ AC_MSG_ERROR([Could not find netCDF Fortran library.])
+ ]
)
- ], [
- AC_MSG_ERROR([Could not find nf-config.])
- ])
- AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [
- AC_MSG_ERROR([Could not find netCDF Fortran library.])
- ])
-])
+ ]
+)
# Force 8-byte reals
AX_FC_REAL8
AS_IF(
[test "$enable_real8" != no],
- [FCFLAGS="$FCFLAGS $REAL8_FCFLAGS"])
+ [FCFLAGS="$FCFLAGS $REAL8_FCFLAGS"]
+)
+
+
+# Do concurrent configuration
+MOM6_FC_DO_CONCURRENT_LOCAL
# OpenMP configuration
@@ -192,19 +200,22 @@ AX_FC_CHECK_MODULE([fms_mod], [], [
AX_FC_CHECK_MODULE([fms_mod],
[AC_SUBST([FCFLAGS], ["-I${srcdir}/ac/deps/include $FCFLAGS"])],
[AC_MSG_ERROR([Could not find fms_mod Fortran module.])],
- [-I${srcdir}/ac/deps/include])
+ [-I${srcdir}/ac/deps/include]
+ )
])
# Test for fms_init to verify FMS library linking
-AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod],
+MOM6_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [], [], [],
[], [
- AS_UNSET([ax_fc_cv_lib_FMS_fms_init])
- AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [
- AC_SUBST([LDFLAGS], ["-L${srcdir}/ac/deps/lib $LDFLAGS"])
- AC_SUBST([LIBS], ["-lFMS $LIBS"])
- ],
- [AC_MSG_ERROR([Could not find FMS library.])],
- [-L${srcdir}/ac/deps/lib])
+ AS_UNSET([mom6_fc_cv_lib_FMS_fms_init])
+ MOM6_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [], [], [],
+ [
+ AC_SUBST([LDFLAGS], ["-L${srcdir}/ac/deps/lib $LDFLAGS"])
+ AC_SUBST([LIBS], ["-lFMS $LIBS"])
+ ], [
+ AC_MSG_ERROR([Could not find FMS library.])
+ ], [-L${srcdir}/ac/deps/lib]
+ )
]
)
@@ -231,7 +242,33 @@ AX_FC_CHECK_MODULE([fms2_io_mod], [
])
-# Python interpreter test
+# GSW configuration
+AS_IF([test "$with_gsw" = yes], [
+ AX_FC_CHECK_MODULE([gsw_mod_toolbox], [], [
+ AC_MSG_ERROR([Could not find module gsw_mod_toolbox.])
+ ])
+ MOM6_FC_CHECK_LIB([gsw], [gsw_rho], [gsw_mod_toolbox], [sa,ct,p], [rho], [],
+ [], [
+ AC_MSG_ERROR([Could not find gsw_rho in gsw_mod_toolbox.])
+ ]
+ )
+])
+
+
+# CVMix configuration
+AS_IF([test "$with_cvmix" = yes], [
+ AX_FC_CHECK_MODULE([cvmix_kpp], [], [
+ AC_MSG_ERROR([Could not find module cvmix_kpp.])
+ ])
+ MOM6_FC_CHECK_LIB([cvmix], [cvmix_init_kpp], [cvmix_kpp], [], [], [],
+ [], [
+ AC_MSG_ERROR([Could not find cvmix_update_wrap in cvmix_utils.])
+ ]
+ )
+])
+
+
+# Python configuration
# Declare the Python interpreter variable
AC_ARG_VAR([PYTHON], [Python interpreter command])
@@ -250,19 +287,36 @@ AS_VAR_IF([PYTHON], [none], [
])
-# Makedep test
+# Makedep configuration
AC_PATH_PROG([MAKEDEP], [makedep], [${srcdir}/ac/makedep])
AC_SUBST([MAKEDEP])
+# Generate Makedep source list and configure dependency command
+MAKEDEP_FLAGS="-e"
+
+# Exclude linked source files from makedep search
+AS_IF([test "$with_gsw" = yes], [
+ MAKEDEP_FLAGS="${MAKEDEP_FLAGS} \\
+ -s ${srcdir}/src/equation_of_state/TEOS10"
+])
-# Generate source list and configure dependency command
-AC_SUBST([SRC_DIRS], ["\\
+AS_IF([test "$with_cvmix" = yes], [
+ MAKEDEP_FLAGS="${MAKEDEP_FLAGS} \\
+ -s ${srcdir}/src/parameterizations/CVmix"
+])
+
+SRC_DIRS="\\
${srcdir}/src \\
${MODEL_FRAMEWORK} \\
${srcdir}/config_src/external \\
${DRIVER_DIR} \\
- ${MOM_MEMORY_DIR}"]
-)
+ ${MOM_MEMORY_DIR}"
+MAKEDEP_FLAGS="${MAKEDEP_FLAGS} ${SRC_DIRS}"
+
+MAKEDEP_FLAGS="${MAKEDEP_FLAGS# }"
+AC_SUBST([MAKEDEP_FLAGS])
+
+# Add makedep to config.status
AC_CONFIG_COMMANDS(Makefile.dep, [make depend])
@@ -323,5 +377,5 @@ AC_LANG_POP([C])
# Prepare output
AC_SUBST([CPPFLAGS])
-AC_CONFIG_FILES([Makefile:${srcdir}/ac/Makefile.in])
+AC_CONFIG_FILES([Makefile:Makefile.in])
AC_OUTPUT
diff --git a/ac/deps/.gitignore b/ac/deps/.gitignore
index 8cfaa6ebcb..80256cfe1d 100644
--- a/ac/deps/.gitignore
+++ b/ac/deps/.gitignore
@@ -1,5 +1,7 @@
/bin/
/fms/
+/gsw/
+/cvmix/
/include/
/lib/
/mkmf/
diff --git a/ac/deps/Makefile b/ac/deps/Makefile
index 01431cef8c..d693efd128 100644
--- a/ac/deps/Makefile
+++ b/ac/deps/Makefile
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
SHELL = bash
# Disable implicit rules
@@ -7,8 +11,14 @@ SHELL = bash
MAKEFLAGS += -R
# FMS framework
-FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git
-FMS_COMMIT ?= 2023.03
+FMS_URL ?= https://github.com/TURBO-ESM/FMS.git
+FMS_COMMIT ?= 7e526687b96ca685100f73edf7ef49214d5d5a19
+
+GSW_URL ?= https://github.com/mom-ocean/GSW-Fortran.git
+GSW_COMMIT ?= 29e64d652786e1d076a05128c920f394202bfe10
+
+CVMIX_URL ?= https://github.com/mom-ocean/CVMix-src.git
+CVMIX_COMMIT ?= 14939c5704d57b4d68d86b57b13161ea59ab6b5c
# List of source files to link this Makefile's dependencies to model Makefiles
@@ -18,64 +28,102 @@ SOURCE = \
$(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext)))
FMS_SOURCE = $(call SOURCE,fms/src)
+GSW_SOURCE = $(call SOURCE,gsw/src)
+CVMIX_SOURCE = $(call SOURCE,CVMix-src/src/shared)
# If `true`, print logs if an error is encountered.
REPORT_ERROR_LOGS ?=
+# If set, use the submodule repositories in pkg/
+PKG ?= $(abspath ../../pkg)
+MAKEDEP ?= $(abspath ../makedep)
+
#---
# Rules
.PHONY: all
all: lib/libFMS.a
+all: lib/libgsw.a
+all: lib/libcvmix.a
-#---
-# FMS build
+# Library build rules template
+#
+# $(1): target library
+# $(2): dependency label
+# $(3): library source files
-# NOTE: We emulate the automake `make install` stage by storing libFMS.a to
-# ${srcdir}/deps/lib and copying module files to ${srcdir}/deps/include.
-lib/libFMS.a: fms/build/libFMS.a
- mkdir -p lib include
- cp fms/build/libFMS.a lib/libFMS.a
- cp fms/build/*.mod include
+define LIB_RULES
+lib/$(1): $(2)/build/$(1)
+ mkdir -p $$(@D) include/
+ cp $$< $$@
+ cp $$(dir $$<)/*.mod include/
-fms/build/libFMS.a: fms/build/Makefile
- $(MAKE) -C fms/build libFMS.a
+$(2)/build/$(1): $(2)/build/Makefile
+ $$(MAKE) -C $$(@D) $(1)
-fms/build/Makefile: fms/build/Makefile.in fms/build/configure
- cd $(@D) && { \
+$(2)/build/Makefile: $(2)/build/Makefile.in $(2)/build/configure
+ cd $$(@D) && { \
+ MAKEDEP=$$(MAKEDEP) \
./configure --srcdir=../src \
|| { \
- if [ "${REPORT_ERROR_LOGS}" = true ]; then cat config.log ; fi ; \
+ if [ "$${REPORT_ERROR_LOGS}" = true ]; then cat config.log ; fi ; \
false; \
} \
}
-fms/build/Makefile.in: Makefile.fms.in | fms/build
- cp Makefile.fms.in fms/build/Makefile.in
+$(2)/build/Makefile.in: Makefile.$(2).in | $(2)/build
+ cp $$< $$@
+
+$(2)/build/configure: $(2)/build/configure.ac $(3) | $(2)/src
+ autoreconf $$(@D)
+
+$(2)/build/configure.ac: configure.$(2).ac m4 | $(2)/build
+ cp $$< $$@
+ cp -r m4 $$(@D)
-fms/build/configure: fms/build/configure.ac $(FMS_SOURCE) | fms/src
- autoreconf fms/build
+$(2)/build:
+ mkdir -p $$@
+endef
-fms/build/configure.ac: configure.fms.ac m4 | fms/build
- cp configure.fms.ac fms/build/configure.ac
- cp -r m4 fms/build
+$(eval $(call LIB_RULES,libFMS.a,fms,$(FMS_SOURCE)))
+$(eval $(call LIB_RULES,libgsw.a,gsw,$(GSW_SOURCE)))
+$(eval $(call LIB_RULES,libcvmix.a,cvmix,$(CVMIX_SOURCE)))
-fms/build:
- mkdir -p fms/build
+
+# Dependency source
fms/src:
git clone $(FMS_URL) $@
git -C $@ checkout $(FMS_COMMIT)
+
+ifdef PKG
+gsw/src: | gsw/build
+ ln -s $(PKG)/GSW-Fortran gsw/src
+
+cvmix/src: | cvmix/build
+ ln -s $(PKG)/CVMix-src cvmix/src
+
+else
+gsw/src:
+ git clone $(GSW_URL) $@
+ git -C $@ checkout $(GSW_COMMIT)
+
+cvmix/src:
+ git clone $(CVMIX_URL) $@
+ git -C $@ checkout $(CVMIX_COMMIT)
+endif
+
+
# Cleanup
.PHONY: clean
clean:
- rm -rf fms/build lib include
+ rm -rf fms/build gsw/build cvmix/build lib include
.PHONY: distclean
distclean: clean
- rm -rf fms
+ rm -rf fms gsw cvmix
diff --git a/ac/deps/Makefile.cvmix.in b/ac/deps/Makefile.cvmix.in
new file mode 100644
index 0000000000..b8254d9b11
--- /dev/null
+++ b/ac/deps/Makefile.cvmix.in
@@ -0,0 +1,30 @@
+# Makefile template for CVMix
+#
+# Compiler flags are configured by autoconf's configure script.
+#
+# Source code dependencies are configured by makedep and saved to Makefile.dep.
+
+FC = @FC@
+LD = @FC@
+AR = @AR@
+PYTHON = @PYTHON@
+MAKEDEP = @MAKEDEP@
+
+DEFS = @DEFS@
+CPPFLAGS = @CPPFLAGS@
+FCFLAGS = @FCFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+ARFLAGS = @ARFLAGS@
+
+-include Makefile.dep
+
+# Generate Makefile from template
+Makefile: Makefile.in config.status
+ ./config.status
+
+
+.PHONY: depend
+depend: Makefile.dep
+Makefile.dep:
+ $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e -x libcvmix.a @srcdir@/src/shared
diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in
index e4617f1428..05680c5af1 100644
--- a/ac/deps/Makefile.fms.in
+++ b/ac/deps/Makefile.fms.in
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
# Makefile template for FMS
#
# Compiler flags are configured by autoconf's configure script.
diff --git a/ac/deps/Makefile.gsw.in b/ac/deps/Makefile.gsw.in
new file mode 100644
index 0000000000..5cbc14bbbe
--- /dev/null
+++ b/ac/deps/Makefile.gsw.in
@@ -0,0 +1,30 @@
+# Makefile template for GSW
+#
+# Compiler flags are configured by autoconf's configure script.
+#
+# Source code dependencies are configured by makedep and saved to Makefile.dep.
+
+FC = @FC@
+LD = @FC@
+AR = @AR@
+PYTHON = @PYTHON@
+MAKEDEP = @MAKEDEP@
+
+DEFS = @DEFS@
+CPPFLAGS = @CPPFLAGS@
+FCFLAGS = @FCFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+ARFLAGS = @ARFLAGS@
+
+-include Makefile.dep
+
+# Generate Makefile from template
+Makefile: Makefile.in config.status
+ ./config.status
+
+
+.PHONY: depend
+depend: Makefile.dep
+Makefile.dep:
+ $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e -x libgsw.a @srcdir@
diff --git a/ac/deps/configure.cvmix.ac b/ac/deps/configure.cvmix.ac
new file mode 100644
index 0000000000..714ab803a4
--- /dev/null
+++ b/ac/deps/configure.cvmix.ac
@@ -0,0 +1,91 @@
+# Autoconf configuration
+AC_PREREQ([2.63])
+
+AC_INIT(
+ [GSW],
+ [ ],
+ [https://github.com/TEOS-10/GSW-Fortran/issues])
+
+# Validate srdcir and configure input
+AC_CONFIG_SRCDIR([src/shared/cvmix_utils.F90])
+AC_CONFIG_MACRO_DIR([m4])
+
+
+# Build dependencies
+AC_ARG_VAR([PYTHON], [Python interpreter command])
+AC_ARG_VAR([MAKEDEP], [Makefile dependency generator])
+
+
+# Fortran configuration
+AC_LANG([Fortran])
+AC_FC_SRCEXT([f90])
+AC_PROG_FC
+
+
+# netCDF configuration
+
+# Check for netcdf.h header function declarations.
+# If unavailable, then try to invoke nc-create.
+AC_LANG_PUSH([C])
+AC_CHECK_HEADERS([netcdf.h], [], [
+ AS_UNSET([ac_cv_header_netcdf_h])
+ AC_PATH_PROG([NC_CONFIG], [nc-config])
+ AS_IF([test -n "$NC_CONFIG"], [
+ AC_SUBST([CPPFLAGS], ["$CPPFLAGS -I$($NC_CONFIG --includedir)"])
+ ],
+ [AC_MSG_ERROR([Could not find nc-config.])]
+ )
+ AC_CHECK_HEADERS([netcdf.h], [], [
+ AC_MSG_ERROR([Could not find netcdf.h])
+ ])
+])
+AC_LANG_POP([C])
+
+# Search for the Fortran netCDF module, fallback to nf-config.
+AX_FC_CHECK_MODULE([netcdf], [], [
+ AS_UNSET([ax_fc_cv_mod_netcdf])
+ AC_PATH_PROG([NF_CONFIG], [nf-config])
+ AS_IF([test -n "$NF_CONFIG"], [
+ AC_SUBST([FCFLAGS], ["$FCFLAGS -I$($NF_CONFIG --includedir)"])
+ ],
+ [AC_MSG_ERROR([Could not find nf-config.])]
+ )
+ AX_FC_CHECK_MODULE([netcdf], [], [
+ AC_MSG_ERROR([Could not find netcdf module.])
+ ])
+])
+
+
+# Verify that Python is available
+AS_IF([test -z "$PYTHON"], [
+ AC_PATH_PROGS([PYTHON], [python python3 python2])
+])
+AS_IF([test -z "$PYTHON"], [
+ AC_MSG_ERROR([Could not find python.])
+])
+AC_SUBST([PYTHON])
+
+
+# Verify that makedep is available
+AS_IF([test -z "$MAKEDEP"], [
+ AC_PATH_PROG([MAKEDEP], [makedep])
+])
+AS_IF([test -z "$MAKEDEP"], [
+ AC_MSG_ERROR([Could not find makedep.])
+])
+AC_SUBST([MAKEDEP])
+
+
+# Autoconf does not configure the archiver (ar), as it is handled by Automake.
+AR=ar
+ARFLAGS=rv
+AC_SUBST([AR])
+AC_SUBST([ARFLAGS])
+
+AC_CONFIG_COMMANDS([Makefile.dep], [make depend])
+
+AC_SUBST([CPPFLAGS])
+
+# Prepare output
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac
index 7d68daa3c7..f00c4343e7 100644
--- a/ac/deps/configure.fms.ac
+++ b/ac/deps/configure.fms.ac
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
# Autoconf configuration
AC_PREREQ([2.63])
@@ -11,6 +15,11 @@ AC_CONFIG_SRCDIR([fms/fms.F90])
AC_CONFIG_MACRO_DIR([m4])
+# Build dependencies
+AC_ARG_VAR([PYTHON], [Python interpreter command])
+AC_ARG_VAR([MAKEDEP], [Makefile dependency generator])
+
+
# C configuration
# Autoconf assumes that LDFLAGS can be passed to CFLAGS, even though this is
@@ -68,7 +77,7 @@ AC_CHECK_FUNCS([sched_getaffinity], [], [AC_DEFINE([__APPLE__])])
LDFLAGS="$FC_LDFLAGS"
-# Standard Fortran configuration
+# Fortran configuration
AC_LANG([Fortran])
AC_FC_SRCEXT([f90])
AC_PROG_FC
@@ -171,19 +180,23 @@ FCFLAGS="$FCFLAGS $ALLOW_ARG_MISMATCH_FCFLAGS"
# Verify that Python is available
-AC_PATH_PROGS([PYTHON], [python python3 python2], [
+AS_IF([test -z "$PYTHON"], [
+ AC_PATH_PROGS([PYTHON], [python python3 python2])
+])
+AS_IF([test -z "$PYTHON"], [
AC_MSG_ERROR([Could not find python.])
])
-AC_ARG_VAR([PYTHON], [Python interpreter command])
+AC_SUBST([PYTHON])
# Verify that makedep is available
-AC_PATH_PROGS([MAKEDEP], [makedep], [], ["${PATH}:${srcdir}/../../.."])
-AS_IF([test -n "${MAKEDEP}"], [
- AC_SUBST([MAKEDEP])
-], [
- AC_MSG_ERROR(["Could not find makedep."])
+AS_IF([test -z "$MAKEDEP"], [
+ AC_PATH_PROG([MAKEDEP], [makedep])
+])
+AS_IF([test -z "$MAKEDEP"], [
+ AC_MSG_ERROR([Could not find makedep.])
])
+AC_SUBST([MAKEDEP])
# Autoconf does not configure the archiver (ar), as it is handled by Automake.
diff --git a/ac/deps/configure.gsw.ac b/ac/deps/configure.gsw.ac
new file mode 100644
index 0000000000..be61eb7040
--- /dev/null
+++ b/ac/deps/configure.gsw.ac
@@ -0,0 +1,90 @@
+# Autoconf configuration
+AC_PREREQ([2.63])
+
+AC_INIT(
+ [GSW],
+ [ ],
+ [https://github.com/TEOS-10/GSW-Fortran/issues])
+
+# Validate srdcir and configure input
+AC_CONFIG_SRCDIR([modules/gsw_mod_toolbox.f90])
+AC_CONFIG_MACRO_DIR([m4])
+
+# Dependency configuration
+AC_ARG_VAR([PYTHON], [Python interpreter command])
+AC_ARG_VAR([MAKEDEP], [Makefile dependency generator])
+
+
+# Fortran compiler test
+AC_LANG([Fortran])
+AC_FC_SRCEXT([f90])
+AC_PROG_FC
+
+
+# netCDF configuration
+
+# Check for netcdf.h header function declarations.
+# If unavailable, then try to invoke nc-create.
+AC_LANG_PUSH([C])
+AC_CHECK_HEADERS([netcdf.h], [], [
+ AS_UNSET([ac_cv_header_netcdf_h])
+ AC_PATH_PROG([NC_CONFIG], [nc-config])
+ AS_IF([test -n "$NC_CONFIG"], [
+ AC_SUBST([CPPFLAGS], ["$CPPFLAGS -I$($NC_CONFIG --includedir)"])
+ ],
+ [AC_MSG_ERROR([Could not find nc-config.])]
+ )
+ AC_CHECK_HEADERS([netcdf.h], [], [
+ AC_MSG_ERROR([Could not find netcdf.h])
+ ])
+])
+AC_LANG_POP([C])
+
+# Search for the Fortran netCDF module, fallback to nf-config.
+AX_FC_CHECK_MODULE([netcdf], [], [
+ AS_UNSET([ax_fc_cv_mod_netcdf])
+ AC_PATH_PROG([NF_CONFIG], [nf-config])
+ AS_IF([test -n "$NF_CONFIG"], [
+ AC_SUBST([FCFLAGS], ["$FCFLAGS -I$($NF_CONFIG --includedir)"])
+ ],
+ [AC_MSG_ERROR([Could not find nf-config.])]
+ )
+ AX_FC_CHECK_MODULE([netcdf], [], [
+ AC_MSG_ERROR([Could not find netcdf module.])
+ ])
+])
+
+
+# Verify that Python is available
+AS_IF([test -z "$PYTHON"], [
+ AC_PATH_PROGS([PYTHON], [python python3 python2])
+])
+AS_IF([test -z "$PYTHON"], [
+ AC_MSG_ERROR([Could not find python.])
+])
+AC_SUBST([PYTHON])
+
+
+# Verify that makedep is available
+AS_IF([test -z "$MAKEDEP"], [
+ AC_PATH_PROG([MAKEDEP], [makedep])
+])
+AS_IF([test -z "$MAKEDEP"], [
+ AC_MSG_ERROR([Could not find makedep.])
+])
+AC_SUBST([MAKEDEP])
+
+
+# Autoconf does not configure the archiver (ar), as it is handled by Automake.
+AR=ar
+ARFLAGS=rv
+AC_SUBST([AR])
+AC_SUBST([ARFLAGS])
+
+AC_CONFIG_COMMANDS([Makefile.dep], [make depend])
+
+AC_SUBST([CPPFLAGS])
+
+# Prepare output
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
diff --git a/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 b/ac/deps/m4/ax_fc_allow_arg_mismatch.m4
index cffa302c66..a525e4f28a 100644
--- a/ac/deps/m4/ax_fc_allow_arg_mismatch.m4
+++ b/ac/deps/m4/ax_fc_allow_arg_mismatch.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl Test if mismatched function arguments are permitted.
dnl
dnl This macro tests if a flag is required to enable mismatched functions in
diff --git a/ac/deps/m4/ax_fc_allow_invalid_boz.m4 b/ac/deps/m4/ax_fc_allow_invalid_boz.m4
index 5d4521b5fb..ef2b20342f 100644
--- a/ac/deps/m4/ax_fc_allow_invalid_boz.m4
+++ b/ac/deps/m4/ax_fc_allow_invalid_boz.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl Test if BOZ literal assignment is supported.
dnl
dnl This macro tests if a flag is required to enable BOZ literal assignments
diff --git a/ac/deps/m4/ax_fc_check_c_lib.m4 b/ac/deps/m4/ax_fc_check_c_lib.m4
index af5765282a..692fe722df 100644
--- a/ac/deps/m4/ax_fc_check_c_lib.m4
+++ b/ac/deps/m4/ax_fc_check_c_lib.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION,
dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],
dnl [OTHER-LDFLAGS], [OTHER-LIBS])
diff --git a/ac/deps/m4/ax_fc_check_lib.m4 b/ac/deps/m4/ax_fc_check_lib.m4
index a7f848cd60..4074b52e46 100644
--- a/ac/deps/m4/ax_fc_check_lib.m4
+++ b/ac/deps/m4/ax_fc_check_lib.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl AX_FC_CHECK_LIB(LIBRARY, FUNCTION,
dnl [MODULE], [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],
dnl [OTHER-LDFLAGS], [OTHER-LIBS])
diff --git a/ac/deps/m4/ax_fc_check_module.m4 b/ac/deps/m4/ax_fc_check_module.m4
index 1cfd0c5a5d..e902882524 100644
--- a/ac/deps/m4/ax_fc_check_module.m4
+++ b/ac/deps/m4/ax_fc_check_module.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl AX_FC_CHECK_MODULE(MODULE,
dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],
dnl [OTHER-FCFLAGS])
diff --git a/ac/deps/m4/ax_fc_cray_pointer.m4 b/ac/deps/m4/ax_fc_cray_pointer.m4
index 57ed186afa..aef870c75d 100644
--- a/ac/deps/m4/ax_fc_cray_pointer.m4
+++ b/ac/deps/m4/ax_fc_cray_pointer.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl AX_FC_CRAY_POINTER([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE])
dnl
dnl This macro tests if any flags are required to enable Cray pointers.
diff --git a/ac/deps/m4/ax_fc_line_length.m4 b/ac/deps/m4/ax_fc_line_length.m4
index 97271da1f6..90770469da 100644
--- a/ac/deps/m4/ax_fc_line_length.m4
+++ b/ac/deps/m4/ax_fc_line_length.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
# AX_FC_LINE_LENGTH([LENGTH], [ACTION-IF-SUCCESS],
# [ACTION-IF-FAILURE = FAILURE])
# ------------------------------------------------
diff --git a/ac/deps/m4/ax_fc_real8.m4 b/ac/deps/m4/ax_fc_real8.m4
index 565018a984..15f0acda22 100644
--- a/ac/deps/m4/ax_fc_real8.m4
+++ b/ac/deps/m4/ax_fc_real8.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl Determine the flag required to force 64-bit reals.
dnl
dnl Many applications do not specify the kind of its real variables, even
diff --git a/ac/m4/ax_fc_check_bind_c.m4 b/ac/m4/ax_fc_check_bind_c.m4
index 9b9f821d4c..e2a42f1bfb 100644
--- a/ac/m4/ax_fc_check_bind_c.m4
+++ b/ac/m4/ax_fc_check_bind_c.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl AX_FC_CHECK_C_LIB(FUNCTION,
dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],
dnl [OTHER-LDFLAGS], [OTHER-LIBS])
diff --git a/ac/m4/ax_fc_check_c_lib.m4 b/ac/m4/ax_fc_check_c_lib.m4
index af5765282a..692fe722df 100644
--- a/ac/m4/ax_fc_check_c_lib.m4
+++ b/ac/m4/ax_fc_check_c_lib.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION,
dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],
dnl [OTHER-LDFLAGS], [OTHER-LIBS])
diff --git a/ac/m4/ax_fc_check_lib.m4 b/ac/m4/ax_fc_check_lib.m4
index a7f848cd60..4074b52e46 100644
--- a/ac/m4/ax_fc_check_lib.m4
+++ b/ac/m4/ax_fc_check_lib.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl AX_FC_CHECK_LIB(LIBRARY, FUNCTION,
dnl [MODULE], [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],
dnl [OTHER-LDFLAGS], [OTHER-LIBS])
diff --git a/ac/m4/ax_fc_check_module.m4 b/ac/m4/ax_fc_check_module.m4
index 1cfd0c5a5d..e902882524 100644
--- a/ac/m4/ax_fc_check_module.m4
+++ b/ac/m4/ax_fc_check_module.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl AX_FC_CHECK_MODULE(MODULE,
dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],
dnl [OTHER-FCFLAGS])
diff --git a/ac/m4/ax_fc_real8.m4 b/ac/m4/ax_fc_real8.m4
index 565018a984..15f0acda22 100644
--- a/ac/m4/ax_fc_real8.m4
+++ b/ac/m4/ax_fc_real8.m4
@@ -1,3 +1,7 @@
+dnl This file is part of MOM6, the Modular Ocean Model version 6.
+dnl See the LICENSE file for licensing information.
+dnl SPDX-License-Identifier: Apache-2.0
+dnl
dnl Determine the flag required to force 64-bit reals.
dnl
dnl Many applications do not specify the kind of its real variables, even
diff --git a/ac/m4/mom6_fc_check_lib.m4 b/ac/m4/mom6_fc_check_lib.m4
new file mode 100644
index 0000000000..03f6496acb
--- /dev/null
+++ b/ac/m4/mom6_fc_check_lib.m4
@@ -0,0 +1,82 @@
+dnl MOM6_FC_CHECK_LIB(LIBRARY, PROCEDURE,
+dnl [MODULE], [ARGS], [FUNC-RESULT], [DECLS],
+dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND],
+dnl [OTHER-LDFLAGS], [OTHER-LIBS])
+dnl
+dnl This macro checks if a Fortran library containing a designated function
+dnl is available to the compiler. For the most part, this macro should behave
+dnl like the Autoconf AC_CHECK_LIB macro.
+dnl
+dnl This macro differs from AC_CHECK_LIB, since it includes several additional
+dnl arguments. Although the next four arguments are optional, they are
+dnl required for many function tests.
+dnl
+dnl - MODULE specifies the Fortran module containing the procedure.
+dnl
+dnl - ARGS is used to specify any arguments of the procedure.
+dnl
+dnl - FUNC-RESULT, if set, identifies the procedure as a function rather than
+dnl a subroutine, and specifies the function test result.
+dnl
+dnl - DECLS is used as a code block to explicitly declare variables, when
+dnl implicit typing is not sufficient.
+dnl
+dnl The following argument has also been added.
+dnl
+dnl - OTHER-LDFLAGS allows specification of supplemental LDFLAGS arguments.
+dnl This can be used, for example, to test for the library with different
+dnl -L flags, or perhaps other ld configurations.
+dnl
+dnl Results are cached in the mom6_fc_cv_lib_LIBRARY_PROCEDURE variable.
+dnl
+AC_DEFUN([MOM6_FC_CHECK_LIB],[
+ AS_VAR_PUSHDEF([mom6_fc_Lib], [mom6_fc_cv_lib_$1_$2])
+ m4_ifval([$9],
+ [mom6_fc_lib_msg_LDFLAGS=" with $9"],
+ [mom6_fc_lib_msg_LDFLAGS=""]
+ )
+ AC_CACHE_CHECK(
+ [for $2 in -l$1$mom6_fc_lib_msg_LDFLAGS],
+ [mom6_fc_Lib],[
+ mom6_fc_check_lib_save_LDFLAGS=$LDFLAGS
+ LDFLAGS="$9 $LDFLAGS"
+ mom6_fc_check_lib_save_LIBS=$LIBS
+ LIBS="-l$1 $10 $LIBS"
+ AS_IF([test -n "$3"],
+ [mom6_fc_use_mod="use $3"],
+ [mom6_fc_use_mod=""]
+ )
+ AS_IF([test -n "$5"],
+ [mom6_fc_proc="$5 = $2"],
+ [mom6_fc_proc="call $2"]
+ )
+ AS_IF([test -n "$4"],
+ [mom6_fc_proc="${mom6_fc_proc}($4)"]
+ )
+ AS_IF([test -n "$6"],
+ [mom6_fc_decls="$6"],
+ [mom6_fc_decls=""]
+ )
+ AC_LANG_PUSH([Fortran])
+ AC_LINK_IFELSE([dnl
+dnl Begin 7-column code block
+AC_LANG_PROGRAM([], [dnl
+ $mom6_fc_use_mod
+ $mom6_fc_decls
+ $mom6_fc_proc])dnl
+dnl End code block
+ ],
+ [AS_VAR_SET([mom6_fc_Lib], [yes])],
+ [AS_VAR_SET([mom6_fc_Lib], [no])]
+ )
+ AC_LANG_POP([Fortran])
+ LIBS=$mom6_fc_check_lib_save_LIBS
+ LDFLAGS=$mom6_fc_check_lib_save_LDFLAGS
+ ]
+ )
+ AS_VAR_IF([mom6_fc_Lib], [yes],
+ [m4_default([$7], [LIBS="-l$1 $LIBS"])],
+ [$8]
+ )
+ AS_VAR_POPDEF([mom6_fc_Lib])
+])
diff --git a/ac/m4/mom6_fc_do_concurrent_local.m4 b/ac/m4/mom6_fc_do_concurrent_local.m4
new file mode 100644
index 0000000000..34de5d15fe
--- /dev/null
+++ b/ac/m4/mom6_fc_do_concurrent_local.m4
@@ -0,0 +1,32 @@
+dnl MOM6_FC_DO_CONCURRENT_LOCAL
+dnl
+dnl Determine if the compiler support do-concurrent locality specifiers.
+dnl Currently only LOCAL is tested, but this should also include LOCAL_INIT,
+dnl SHARED, and DEFAULT(NONE).
+dnl
+dnl Results are cached in the `mom6_cv_fc_do_concurrent_local` variable.
+dnl
+AC_DEFUN([MOM6_FC_DO_CONCURRENT_LOCAL], [
+ AC_REQUIRE([AC_PROG_FC])
+ AC_LANG_PUSH([Fortran])
+ AC_CACHE_CHECK([whether $FC supports do concurrent locality specifiers],
+ [mom6_cv_fc_do_concurrent_local], [
+ mom6_cv_fc_do_concurrent_local=no
+ AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([], [
+dnl ---
+ do concurrent(i=1:2) local(a,b)
+ end do
+dnl ---
+ ])
+ ], [
+ mom6_cv_fc_do_concurrent_local=yes
+ ])
+ ]
+ )
+ AS_IF([test "x$mom6_cv_fc_do_concurrent_local" = "xyes"], [
+ AC_DEFINE([HAVE_FC_DO_CONCURRENT_LOCAL], [1],
+ [Define if do concurrent supports locality specifiers.])
+ ])
+ AC_LANG_POP([Fortran])
+])
diff --git a/ac/makedep b/ac/makedep
index 3ae3567d20..65a79044c0 100755
--- a/ac/makedep
+++ b/ac/makedep
@@ -1,4 +1,4 @@
-#!/usr/bin/env python
+#!/usr/bin/env python3
from __future__ import print_function
@@ -389,7 +389,9 @@ def scan_fortran_file(src_file, defines=None):
cpp_defines = defines if defines is not None else []
- cpp_macros = dict([t.split('=') for t in cpp_defines])
+ cpp_macros = dict(
+ [t.split('=') if '=' in t else (t, None) for t in cpp_defines]
+ )
cpp_group_stack = []
with io.open(src_file, 'r', errors='replace') as file:
@@ -454,13 +456,14 @@ def scan_fortran_file(src_file, defines=None):
# Activate a new macro (ignoring the value)
match = re_cpp_define.match(line)
if match:
+ # TODO: Tokenize this, don't hunt for `(` in `macro`.
tokens = line.strip()[1:].split(maxsplit=2)
macro = tokens[1]
value = tokens[2] if tokens[2:] else None
if '(' in macro:
# TODO: Actual handling of function macros
macro, arg = macro.split('(', maxsplit=1)
- value = '(' + arg + value
+ value = '(' + arg + value if value else '(' + arg
cpp_macros[macro] = value
# Deactivate a macro
diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90
index 07bff26395..cf616fce4f 100644
--- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90
+++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90
@@ -1,6 +1,8 @@
-module MOM_surface_forcing_gfdl
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
-! This file is part of MOM6. See LICENSE.md for the license.
+module MOM_surface_forcing_gfdl
!#CTRL# use MOM_controlled_forcing, only : apply_ctrl_forcing, register_ctrl_forcing_restarts
!#CTRL# use MOM_controlled_forcing, only : controlled_forcing_init, controlled_forcing_end
@@ -109,6 +111,7 @@ module MOM_surface_forcing_gfdl
real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which sea-ice viscosity
!! becomes effective [R Z ~> kg m-2], typically of order 1000 kg m-2.
logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments
+ logical :: allow_carbon_flux_exchange !< If true, allows fluxes and diagnostics of carbon in runoff.
logical :: restore_salt !< If true, the coupled MOM driver adds a term to restore surface
!! salinity to a specified value.
@@ -189,6 +192,7 @@ module MOM_surface_forcing_gfdl
real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip [kg m-2 s-1]
real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip [kg m-2 s-1]
real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff [kg m-2 s-1]
+ real, pointer, dimension(:,:) :: runoff_carbon =>NULL() !< mass flux of carbon in liquid runoff [kg m-2 s-1]
real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff [kg m-2 s-1]
real, pointer, dimension(:,:) :: stress_mag =>NULL() !< The time-mean magnitude of the stress on the ocean [Pa]
real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m s-1]
@@ -287,7 +291,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G,
! flux type has been used.
if (fluxes%dt_buoy_accum < 0) then
call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.not.CS%nonBous, press=.true., &
- fix_accum_bug=.not.CS%ustar_gustless_bug, tau_mag=CS%nonBous)
+ fix_accum_bug=.not.CS%ustar_gustless_bug, tau_mag=CS%nonBous,&
+ carbon=CS%allow_carbon_flux_exchange)
call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed)
call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed)
@@ -503,6 +508,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G,
call check_mask_val_consistency(IOB%runoff_hflx(i-i0,j-j0), G%mask2dT(i,j), i, j, 'runoff_hflx', G)
endif
+ if (associated(IOB%runoff_carbon) .and. CS%allow_carbon_flux_exchange) then
+ fluxes%carbon_content_lrunoff(i,j) = US%kg_m2s_to_RZ_T * IOB%runoff_carbon(i-i0,j-j0) * G%mask2dT(i,j)
+ if (CS%check_no_land_fluxes) &
+ call check_mask_val_consistency(IOB%runoff_carbon(i-i0,j-j0), G%mask2dT(i,j), i, j, 'runoff_carbon', G)
+ endif
+
if (associated(IOB%calving_hflx)) then
fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j)
if (CS%check_no_land_fluxes) &
@@ -1196,7 +1207,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes)
integer :: isc, iec, jsc, jec, i, j
logical :: overrode_h
- isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec
+ isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec
call data_override(G%Domain, 'hflx_adj', temp_at_h, Time, override=overrode_h, &
scale=US%W_m2_to_QRZ_T)
@@ -1246,7 +1257,7 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces)
real :: zonal_tau, merid_tau ! True zonal and meridional wind stresses [R Z L T-2 ~> Pa]
logical :: overrode_x, overrode_y
- isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec
+ isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec
tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0
! Either reads data or leaves contents unchanged
@@ -1385,7 +1396,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger)
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous)
call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, &
@@ -1449,11 +1460,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger)
"due to internal corrections.", default=.false.)
if (present(wind_stagger)) then
- if (wind_stagger == AGRID) then ; stagger = 'AGRID'
+ if (wind_stagger == AGRID) then ; stagger = 'AGRID'
elseif (wind_stagger == BGRID_NE) then ; stagger = 'BGRID_NE'
elseif (wind_stagger == CGRID_NE) then ; stagger = 'CGRID_NE'
else ; stagger = 'UNKNOWN' ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// &
- trim(stagger)// "is invalid."); endif
+ trim(stagger)// "is invalid.") ; endif
call log_param(param_file, mdl, "WIND_STAGGER", stagger, &
"The staggering of the input wind stress field "//&
"from the coupler that is actually used.")
@@ -1463,7 +1474,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger)
"A case-insensitive character string to indicate the "//&
"staggering of the input wind stress field. Valid "//&
"values are 'A', 'B', or 'C'.", default="C")
- if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID
+ if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID
elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE
elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE
else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// &
@@ -1610,13 +1621,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger)
utide_2d(:,:) = 0.0
call read_netCDF_data(TideAmp_file, 'tideamp', utide_2d, G%Domain, &
rescale=US%m_to_Z*US%T_to_s)
- do j=jsd, jed; do i=isd, ied
+ do j=jsd,jed ; do i=isd,ied
utide = utide_2d(i,j)
CS%BBL_tidal_dis(i,j) = G%mask2dT(i,j)*rho_TKE_tidal*CS%cd_tides*(utide*utide*utide)
CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide
enddo ; enddo
else
- do j=jsd,jed; do i=isd,ied
+ do j=jsd,jed ; do i=isd,ied
utide = CS%utide
CS%BBL_tidal_dis(i,j) = rho_TKE_tidal*CS%cd_tides*(utide*utide*utide)
CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide
@@ -1706,8 +1717,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger)
call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, &
"If true, makes available diagnostics of fluxes from icebergs "//&
"as seen by MOM6.", default=.false.)
+ call get_param(param_file, mdl, "ALLOW_CARBON_FLUX_EXCHANGE", CS%allow_carbon_flux_exchange, &
+ "If true, makes available fluxes and diagnostics of carbon in runoff "//&
+ "within MOM6.", default=.false.)
call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles, &
- use_berg_fluxes=iceberg_flux_diags)
+ use_berg_fluxes=iceberg_flux_diags, &
+ use_carbon_runoff=CS%allow_carbon_flux_exchange)
call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, &
"If true, allows flux adjustments to specified via the "//&
@@ -1723,7 +1738,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger)
if (CS%restore_salt) then
salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file)
CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, MOM_domain=G%Domain)
- call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0
+ call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed) ; CS%srestore_mask(:,:) = 1.0
if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes
flnam = trim(CS%inputdir) // 'salt_restore_mask.nc'
call MOM_read_data(flnam,'mask', CS%srestore_mask, G%domain, timelevel=1)
@@ -1733,7 +1748,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger)
if (CS%restore_temp) then
temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file)
CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, MOM_domain=G%Domain)
- call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0
+ call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed) ; CS%trestore_mask(:,:) = 1.0
if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes
flnam = trim(CS%inputdir) // 'temp_restore_mask.nc'
call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1)
diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90
index e3b7b0cec7..755d87a47a 100644
--- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90
+++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Top-level module for the MOM6 ocean model in coupled mode.
module ocean_model_mod
-! This file is part of MOM6. See LICENSE.md for the license.
-
! This is the top level module for the MOM6 ocean model. It contains routines
! for initialization, termination and update of ocean model state. This
! particular version wraps all of the calls for MOM6 in the calls that had
@@ -45,7 +47,7 @@ module ocean_model_mod
use MOM_time_manager, only : time_type, operator(>), operator(+), operator(-)
use MOM_time_manager, only : operator(*), operator(/), operator(/=)
use MOM_time_manager, only : operator(<=), operator(>=), operator(<)
-use MOM_time_manager, only : real_to_time, time_type_to_real
+use MOM_time_manager, only : real_to_time, time_to_real
use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init
use MOM_tracer_flow_control, only : call_tracer_flux_init
use MOM_unit_scaling, only : unit_scale_type
@@ -54,7 +56,7 @@ module ocean_model_mod
use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS
use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces
use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart
-use MOM_ice_shelf, only : ice_sheet_calving_to_ocean_sfc
+use MOM_ice_shelf, only : ice_sheet_calving_to_ocean_sfc, adjust_ice_sheet_frazil
use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init
use MOM_wave_interface, only: Update_Surface_Waves
use iso_fortran_env, only : int64
@@ -282,7 +284,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas
OS%Time = Time_in ; OS%Time_dyn = Time_in
! Call initialize MOM with an optional Ice Shelf CS which, if present triggers
! initialization of ice shelf parameters and arrays.
- point_calving=.false.; if (present(calve_ice_shelf_bergs)) point_calving=calve_ice_shelf_bergs
+ point_calving = .false. ; if (present(calve_ice_shelf_bergs)) point_calving = calve_ice_shelf_bergs
call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, &
Time_in, offline_tracer_mode=OS%offline_tracer_mode, &
diag_ptr=OS%diag, count_calls=.true., ice_shelf_CSp=OS%ice_shelf_CSp, &
@@ -340,7 +342,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas
call get_param(param_file, mdl, "RHO_0", Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=OS%US%kg_m3_to_R)
call get_param(param_file, mdl, "G_EARTH", G_Earth, &
@@ -372,7 +374,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas
!allocate(OS%sfc_state)
call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, do_integrals=.true., &
- gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot)
+ gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot, &
+ use_iceshelves=OS%use_ice_shelf)
if (present(wind_stagger)) then
call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, &
@@ -410,6 +413,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas
call extract_surface_state(OS%MOM_CSp, OS%sfc_state)
+ if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US)
endif
@@ -491,7 +497,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda
integer :: is, ie, js, je
call callTree_enter("update_ocean_model(), ocean_model_MOM.F90")
- dt_coupling = OS%US%s_to_T*time_type_to_real(Ocean_coupling_time_step)
+ dt_coupling = time_to_real(Ocean_coupling_time_step, scale=OS%US%s_to_T)
if (.not.associated(OS)) then
call MOM_error(FATAL, "update_ocean_model called with an unassociated "// &
@@ -653,7 +659,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda
if (step_thermo) then
! Back up Time1 to the start of the thermodynamic segment.
- Time1 = Time1 - real_to_time(OS%US%T_to_s*(dtdia - dt_dyn))
+ Time1 = Time1 - real_to_time(dtdia - dt_dyn, unscale=OS%US%T_to_s)
call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, &
Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., &
start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling)
@@ -661,7 +667,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda
endif
t_elapsed_seg = t_elapsed_seg + dt_dyn
- Time1 = Time_seg_start + real_to_time(OS%US%T_to_s*t_elapsed_seg)
+ Time1 = Time_seg_start + real_to_time(t_elapsed_seg, unscale=OS%US%T_to_s)
enddo
endif
@@ -679,6 +685,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda
call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles)
endif
+ !only ,ale ice-shelf frazil adjustments if sfc_state%frazil was updated (do_thermo=True)
+ if (do_thermo .and. OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
! Translate state into Ocean.
! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US, &
! OS%fluxes%p_surf_full, OS%press_to_z)
@@ -987,6 +997,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc)
call extract_surface_state(OS%MOM_CSp, OS%sfc_state)
+ if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US)
end subroutine ocean_model_init_sfc
diff --git a/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90
index d1c46f4254..e37b3ccb89 100644
--- a/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90
+++ b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Top-level module for the MOM6 ocean model in coupled mode.
module MOM_ocean_model_mct
-! This file is part of MOM6. See LICENSE.md for the license.
-
! This is the top level module for the MOM6 ocean model. It contains routines
! for initialization, termination and update of ocean model state. This
! particular version wraps all of the calls for MOM6 in the calls that had
@@ -51,6 +53,7 @@ module MOM_ocean_model_mct
use MOM_verticalGrid, only : verticalGrid_type
use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS
use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart
+use MOM_ice_shelf, only : adjust_ice_sheet_frazil
use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type
use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums
use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data
@@ -133,7 +136,7 @@ module MOM_ocean_model_mct
!> The ocean_state_type contains all information about the state of the ocean,
!! with a format that is private so it can be readily changed without disrupting
!! other coupled components.
-type, public :: ocean_state_type ;
+type, public :: ocean_state_type
! This type is private, and can therefore vary between different ocean models.
logical :: is_ocean_PE = .false. !< True if this is an ocean PE.
type(time_type) :: Time !< The ocean model's time and master clock.
@@ -332,7 +335,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i
call get_param(param_file, mdl, "RHO_0", Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0)
call get_param(param_file, mdl, "G_EARTH", G_Earth, &
@@ -362,7 +365,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i
! Consider using a run-time flag to determine whether to do the diagnostic
! vertical integrals, since the related 3-d sums are not negligible in cost.
call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, &
- do_integrals=.true., gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot)
+ do_integrals=.true., gas_fields_ocn=gas_fields_ocn, &
+ use_meltpot=use_melt_pot, use_iceshelves=OS%use_ice_shelf)
call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, &
OS%forcing_CSp, OS%restore_salinity, OS%restore_temp)
@@ -401,6 +405,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i
call extract_surface_state(OS%MOM_CSp, OS%sfc_state)
+ if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US)
endif
@@ -578,7 +585,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, &
call disable_averaging(OS%diag)
Master_time = OS%Time ; Time1 = OS%Time
- if(OS%offline_tracer_mode) then
+ if (OS%offline_tracer_mode) then
call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp)
elseif ((.not.do_thermo) .or. (.not.do_dyn)) then
@@ -658,6 +665,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, &
call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles)
endif
+ !only make ice-shelf frazil adjustments if sfc_state%frazil was updated (do_thermo=True)
+ if (do_thermo .and. OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
! Translate state into Ocean.
! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, &
! Ice_ocean_boundary%p, OS%press_to_z)
@@ -731,9 +742,11 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time)
call ocean_model_save_restart(Ocean_state, Time)
call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.)
! print time stats
- call MOM_infra_end
call MOM_end(Ocean_state%MOM_CSp)
if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp)
+
+ ! This closes out the infrastructure, including clocks, I/O and message passing communicators.
+ call MOM_infra_end()
end subroutine ocean_model_end
!> ocean_model_save_restart causes restart files associated with the ocean to be
@@ -795,7 +808,7 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap,
call mpp_get_layout(input_domain,layout)
call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz)
- if(PRESENT(maskmap)) then
+ if (PRESENT(maskmap)) then
call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap)
else
call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain)
@@ -970,6 +983,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc)
call extract_surface_state(OS%MOM_CSp, OS%sfc_state)
+ if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US)
end subroutine ocean_model_init_sfc
diff --git a/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90
index e5c5943d4f..bc193face8 100644
--- a/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90
+++ b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90
@@ -1,6 +1,8 @@
-module MOM_surface_forcing_mct
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
-! This file is part of MOM6. See LICENSE.md for the license.
+module MOM_surface_forcing_mct
use MOM_coms, only : reproducing_sum, field_chksum
use MOM_constants, only : hlv, hlf
@@ -418,7 +420,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G,
endif
! obtain fluxes from IOB; note the staggering of indices
- i0 = 0; j0 = 0
+ i0 = 0 ; j0 = 0
do j=js,je ; do i=is,ie
! liquid precipitation (rain)
if (associated(IOB%lprec)) &
@@ -437,14 +439,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G,
fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j)
else if (associated(IOB%runoff)) then
fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j)
- end if
+ endif
! ice runoff flux
if (associated(IOB%rofi_flux)) then
fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j)
else if (associated(IOB%calving)) then
fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j)
- end if
+ endif
if (associated(IOB%ustar_berg)) &
fluxes%ustar_berg(i,j) = US%m_to_Z*US%T_to_s * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j)
@@ -639,7 +641,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS)
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1
!i0 = is - isc_bnd ; j0 = js - jsc_bnd
- i0 = 0; j0 = 0
+ i0 = 0 ; j0 = 0
Irho0 = US%L_to_Z / CS%Rho0
Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z
@@ -897,7 +899,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes)
integer :: isc, iec, jsc, jec, i, j
logical :: overrode_h
- isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec
+ isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec
overrode_h = .false.
call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h)
@@ -947,7 +949,7 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces)
real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1]
logical :: overrode_x, overrode_y
- isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec
+ isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec
Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z
tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0
@@ -1066,7 +1068,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt,
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, &
@@ -1225,13 +1227,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt,
if (CS%read_TIDEAMP) then
TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file)
call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s)
- do j=jsd, jed; do i=isd, ied
+ do j=jsd,jed ; do i=isd,ied
utide = CS%TKE_tidal(i,j)
CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide)
CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide
enddo ; enddo
else
- do j=jsd,jed; do i=isd,ied
+ do j=jsd,jed ; do i=isd,ied
utide = CS%utide
CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide)
CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide
@@ -1325,7 +1327,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt,
if (present(restore_salt)) then ; if (restore_salt) then
salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file)
CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain)
- call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0
+ call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed) ; CS%srestore_mask(:,:) = 1.0
if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes
flnam = trim(CS%inputdir) // 'salt_restore_mask.nc'
call MOM_read_data(flnam,'mask', CS%srestore_mask, G%domain, timelevel=1)
@@ -1335,7 +1337,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt,
if (present(restore_temp)) then ; if (restore_temp) then
temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file)
CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain)
- call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0
+ call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed) ; CS%trestore_mask(:,:) = 1.0
if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes
flnam = trim(CS%inputdir) // 'temp_restore_mask.nc'
call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1)
@@ -1401,7 +1403,7 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt)
chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks
chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks
chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks
- chks = field_chksum( iobt%seaice_melt_heat); if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks
+ chks = field_chksum( iobt%seaice_melt_heat) ; if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks
chks = field_chksum( iobt%seaice_melt) ; if (root) write(outunit,100) 'iobt%seaice_melt ', chks
chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks
chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks
diff --git a/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90
index 0b7a331458..372f4f32f0 100644
--- a/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90
+++ b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
module ocn_cap_methods
use ESMF, only: ESMF_clock, ESMF_time, ESMF_ClockGet, ESMF_TimeGet
@@ -40,7 +44,7 @@ subroutine ocn_import(x2o, ind, grid, ice_ocean_boundary, ocean_public, logunit,
character(*), parameter :: F01 = "('(ocn_import) ',a,4(i6,2x),d21.14)"
!-----------------------------------------------------------------------
- isc = GRID%isc; iec = GRID%iec ; jsc = GRID%jsc; jec = GRID%jec
+ isc = GRID%isc ; iec = GRID%iec ; jsc = GRID%jsc ; jec = GRID%jec
k = 0
do j = jsc, jec
@@ -232,7 +236,7 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day)
endif
sshx(i,j) = slope * grid%US%m_to_L*grid%IdxT(i,j) * grid%mask2dT(i,j)
if (grid%mask2dT(i,j)==0.) sshx(i,j) = 0.0
- enddo; enddo
+ enddo ; enddo
! d/dy ssh
do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec
@@ -259,7 +263,7 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day)
endif
sshy(i,j) = slope * grid%US%m_to_L*grid%IdyT(i,j) * grid%mask2dT(i,j)
if (grid%mask2dT(i,j)==0.) sshy(i,j) = 0.0
- enddo; enddo
+ enddo ; enddo
! rotate ssh gradients from local coordinates to true zonal/meridional (inverse transformation)
n = 0
@@ -267,7 +271,7 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day)
n = n+1
o2x(ind%o2x_So_dhdx, n) = grid%cos_rot(i,j) * sshx(i,j) + grid%sin_rot(i,j) * sshy(i,j)
o2x(ind%o2x_So_dhdy, n) = grid%cos_rot(i,j) * sshy(i,j) - grid%sin_rot(i,j) * sshx(i,j)
- enddo; enddo
+ enddo ; enddo
end subroutine ocn_export
diff --git a/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90
index 85b7350b77..d55d70c116 100644
--- a/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90
+++ b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This is the main driver for MOM6 in CIME
module ocn_comp_mct
-! This file is part of MOM6. See LICENSE.md for the license.
-
! mct modules
use ESMF, only: ESMF_clock, ESMF_time, ESMF_timeInterval
use ESMF, only: ESMF_ClockGet, ESMF_TimeGet, ESMF_TimeIntervalGet
@@ -29,7 +31,7 @@ module ocn_comp_mct
use MOM_variables, only: surface
use MOM_domains, only: MOM_infra_init
use MOM_restart, only: save_restart
-use MOM_ice_shelf, only: ice_shelf_save_restart
+use MOM_ice_shelf, only: ice_shelf_save_restart, adjust_ice_sheet_frazil
use MOM_domains, only: num_pes, root_pe, pe_here
use MOM_grid, only: ocean_grid_type, get_global_grid_size
use MOM_error_handler, only: MOM_error, FATAL, is_root_pe, WARNING
@@ -59,7 +61,7 @@ module ocn_comp_mct
use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data
! By default make data private
-implicit none; private
+implicit none ; private
#include
@@ -199,7 +201,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename )
! set the shr log io unit number
call shr_file_setLogUnit(stdout)
- end if
+ endif
call set_calendar_type(NOLEAP) !TODO: confirm this
@@ -278,7 +280,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename )
"Coeff. used to convert net shortwave rad. into "//&
"near-IR, diffuse shortwave.", units="nondim", default=0.215)
else
- glb%c1 = 0.0; glb%c2 = 0.0; glb%c3 = 0.0; glb%c4 = 0.0
+ glb%c1 = 0.0 ; glb%c2 = 0.0 ; glb%c3 = 0.0 ; glb%c4 = 0.0
endif
! Close param file before it gets opened by ocean_model_init again.
@@ -314,13 +316,13 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename )
close(nu)
if (is_root_pe()) then
write(stdout,*) 'Reading restart file(s): ',trim(restartfiles)
- end if
+ endif
call shr_file_freeUnit(nu)
call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfiles))
endif
if (is_root_pe()) then
write(stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========'
- end if
+ endif
! Initialize ocn_state%sfc_state out of sight
call ocean_model_init_sfc(glb%ocn_state, glb%ocn_public)
@@ -382,14 +384,14 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename )
if (mom_cpl_dt /= ocn_cpl_dt) then
write(stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical'
call exit(0)
- end if
+ endif
! send initial state to driver
!TODO:
! if ( lsend_precip_fact ) then
! call seq_infodata_PutData( infodata, precip_fact=precip_fact)
- ! end if
+ ! endif
if (debug .and. root_pe().eq.pe_here()) print *, "calling ocn_export"
call ocn_export(glb%ind, glb%ocn_public, glb%grid, o2x_o%rattr, mom_cpl_dt, ncouple_per_day)
@@ -410,7 +412,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename )
if (is_root_pe()) then
call shr_file_setLogUnit (shrlogunit)
call shr_file_setLogLevel(shrloglev)
- end if
+ endif
end subroutine ocn_init_mct
@@ -486,10 +488,10 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o)
time_start = time_start-coupling_timestep
! double the first coupling interval (to account for the missing coupling interval to due to lag)
coupling_timestep = coupling_timestep*2
- end if
+ endif
firstCall = .false.
- end if
+ endif
! Debugging clocks
if (debug .and. is_root_pe()) then
@@ -524,7 +526,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o)
c1=glb%c1, c2=glb%c2, c3=glb%c3, c4=glb%c4)
else
call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, stdout, Eclock )
- end if
+ endif
! Update internal ocean
call update_ocean_model(ice_ocean_boundary, glb%ocn_state, glb%ocn_public, time_start, coupling_timestep)
@@ -758,7 +760,7 @@ end subroutine ocn_domain_mct
else
write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype'
call exit(0)
- end if
+ endif
return
end function
@@ -779,6 +781,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc)
call extract_surface_state(OS%MOM_CSp, OS%sfc_state)
+ if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US)
end subroutine ocean_model_init_sfc
diff --git a/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 b/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90
index 3f47c01903..68b6537662 100644
--- a/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90
+++ b/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
module ocn_cpl_indices
use mct_mod, only: mct_avect_init, mct_avect_indexra, mct_aVect_clean, mct_aVect
diff --git a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90
index fb9fbe3e22..a8e11fbe34 100644
--- a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90
+++ b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A dummy version of atmos_ocean_fluxes_mod module for
!! use when the vastly larger FMS package is not needed.
module atmos_ocean_fluxes_mod
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public :: aof_set_coupler_flux
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..42444878ee 100644
--- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90
+++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90
@@ -1,6 +1,8 @@
-program Shelf_main
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
-! This file is part of MOM6. See LICENSE.md for the license.
+program Shelf_main
!********+*********+*********+*********+*********+*********+*********+**
!* *
@@ -43,9 +45,10 @@ program Shelf_main
use MOM_io, only : APPEND_FILE, READONLY_FILE, SINGLE_FILE
use MOM_open_boundary, only : ocean_OBC_type
use MOM_restart, only : save_restart
+ use MOM_shared_initialization, only : write_ocean_geometry_file
use MOM_string_functions,only : uppercase
use MOM_time_manager, only : time_type, set_date, get_date
- use MOM_time_manager, only : real_to_time, time_type_to_real
+ use MOM_time_manager, only : real_to_time, time_to_real
use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/)
use MOM_time_manager, only : operator(>), operator(<), operator(>=)
use MOM_time_manager, only : increment_date, set_calendar_type, month_name
@@ -202,11 +205,11 @@ program Shelf_main
call close_file(unit)
else
calendar = uppercase(calendar)
- if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN
- elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN
- elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP
- elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS
- elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR
+ if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN
+ elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN
+ elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP
+ elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS
+ elseif (calendar(1:11)=='NO_CALENDAR') then ; calendar_type = NO_CALENDAR
elseif (calendar(1:1) /= ' ') then
call MOM_error(FATAL,'Shelf_driver: Invalid namelist value '//trim(calendar)//' for calendar')
else
@@ -217,8 +220,8 @@ program Shelf_main
if (sum(date_init) > 0) then
- Start_time = set_date(date_init(1),date_init(2), date_init(3), &
- date_init(4),date_init(5),date_init(6))
+ Start_time = set_date(date_init(1), date_init(2), date_init(3), &
+ date_init(4), date_init(5), date_init(6))
else
Start_time = real_to_time(0.0)
endif
@@ -268,7 +271,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)
@@ -297,8 +303,8 @@ program Shelf_main
segment_start_time = Time
elapsed_time = 0.0
- Time_step_shelf = real_to_time(US%T_to_s*time_step)
- elapsed_time_master = (abs(time_step - US%s_to_T*time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step)
+ Time_step_shelf = real_to_time(time_step, unscale=US%T_to_s)
+ elapsed_time_master = (abs(time_step - time_to_real(Time_step_shelf, scale=US%s_to_T)) > 1.0e-12*time_step)
if (elapsed_time_master) &
call MOM_mesg("Using real elapsed time for the master clock.", 2)
@@ -407,12 +413,12 @@ program Shelf_main
! does not lose resolution of order the timetype's resolution, provided that the timestep and
! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller
! value would be required.
- time_chg = real_to_time(US%T_to_s*elapsed_time)
+ time_chg = real_to_time(elapsed_time, unscale=US%T_to_s)
segment_start_time = segment_start_time + time_chg
- elapsed_time = elapsed_time - US%s_to_T*time_type_to_real(time_chg)
+ elapsed_time = elapsed_time - time_to_real(time_chg, scale=US%s_to_T)
endif
if (elapsed_time_master) then
- Master_Time = segment_start_time + real_to_time(US%T_to_s*elapsed_time)
+ Master_Time = segment_start_time + real_to_time(elapsed_time, unscale=US%T_to_s)
else
Master_Time = Master_Time + Time_step_shelf
endif
diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90
index 2c8271a028..40fc2e5b77 100644
--- a/config_src/drivers/nuopc_cap/mom_cap.F90
+++ b/config_src/drivers/nuopc_cap/mom_cap.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains a set of subroutines that are required by NUOPC.
module MOM_cap_mod
@@ -31,11 +35,13 @@ module MOM_cap_mod
use MOM_ensemble_manager, only: ensemble_manager_init
use MOM_coms, only: sum_across_PEs
+! stub routines for CESMCOUPLED
+use mom_cap_outputlog, only: outputlog_init, outputlog_run, outputlog_restart
#ifdef CESMCOUPLED
use shr_log_mod, only: shr_log_setLogUnit
use nuopc_shr_methods, only: get_component_instance
#endif
-use time_utils_mod, only: esmf2fms_time
+use time_utils_mod, only: esmf2fms_time
use, intrinsic :: iso_fortran_env, only: output_unit
@@ -91,11 +97,13 @@ module MOM_cap_mod
use NUOPC_Model, only: model_label_Finalize => label_Finalize
use NUOPC_Model, only: SetVM
+use mom_inline_mod, only : mom_inline_init, mom_inline_run
#ifndef CESMCOUPLED
- use shr_is_restart_fh_mod, only : init_is_restart_fh, is_restart_fh, is_restart_fh_type
+use shr_is_restart_fh_mod, only : init_is_restart_fh, is_restart_fh, is_restart_fh_type
#endif
+use mom_cap_profiling, only: cap_profiling_init, cap_profiling
-implicit none; private
+implicit none ; private
public SetServices
public SetVM
@@ -140,7 +148,9 @@ module MOM_cap_mod
logical :: grid_attach_area = .false.
logical :: use_coldstart = .true.
logical :: use_mommesh = .true.
+logical :: set_missing_stks_to_zero = .false.
logical :: restart_eor = .false.
+logical :: use_cdeps_inline = .false.
character(len=128) :: scalar_field_name = ''
integer :: scalar_field_count = 0
integer :: scalar_field_idx_grid_nx = 0
@@ -160,6 +170,7 @@ module MOM_cap_mod
character(len=16) :: inst_suffix = ''
logical :: pointer_date = .true. ! append date to rpointer
real(8) :: timere
+integer :: localPet = -1
contains
@@ -177,8 +188,18 @@ subroutine SetServices(gcomp, rc)
! local variables
character(len=*),parameter :: subname='(MOM_cap:SetServices)'
+ type(ESMF_VM) :: vm
+
rc = ESMF_SUCCESS
+ call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_VMGet(vm, localpet=localPet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ if (localPet == 0) call cap_profiling_init()
+ if (localPet == 0) call cap_profiling("mom", "SetServices", "B")
+
! the NUOPC model component will register the generic methods
call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -218,6 +239,8 @@ subroutine SetServices(gcomp, rc)
specRoutine=ocean_model_finalize, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (localPet == 0) call cap_profiling("mom", "SetServices", "E")
+
end subroutine SetServices
!> First initialize subroutine called by NUOPC. The purpose
@@ -244,10 +267,11 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc)
character(len=64) :: value, logmsg
character(len=*),parameter :: subname='(MOM_cap:InitializeP0)'
type(ESMF_VM) :: vm
- integer :: mype
rc = ESMF_SUCCESS
+ if (localPet == 0) call cap_profiling("mom", "InitializeP0", "B")
+
! Switch to IPDv03 by filtering all other phaseMap entries
call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, &
acceptStringList=(/"IPDv03p"/), rc=rc)
@@ -367,6 +391,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc)
write(logmsg,*) use_coldstart
call ESMF_LogWrite('MOM_cap:use_coldstart = '//trim(logmsg), ESMF_LOGMSG_INFO)
+ set_missing_stks_to_zero = .false.
+ call NUOPC_CompAttributeGet(gcomp, name="set_missing_stks_to_zero", value=value, &
+ isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) set_missing_stks_to_zero=(trim(value)=="true")
+ write(logmsg,*) set_missing_stks_to_zero
+ call ESMF_LogWrite('MOM_cap:set_missing_stks_to_zero = '//trim(logmsg), ESMF_LOGMSG_INFO)
+
use_mommesh = .true.
call NUOPC_CompAttributeGet(gcomp, name="use_mommesh", value=value, &
isPresent=isPresent, isSet=isSet, rc=rc)
@@ -386,13 +418,22 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc)
geomtype = ESMF_GEOMTYPE_GRID
endif
+ call NUOPC_CompAttributeGet(gcomp, name="use_cdeps_inline", value=value, &
+ isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) use_cdeps_inline=(trim(value)=="true")
+ write(logmsg,*) use_cdeps_inline
+ call ESMF_LogWrite('MOM_cap:use_cdeps_inline = '//trim(logmsg), ESMF_LOGMSG_INFO)
+
! Read end of run restart config option
call NUOPC_CompAttributeGet(gcomp, name="write_restart_at_endofrun", value=value, &
isPresent=isPresent, isSet=isSet, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
if (isPresent .and. isSet) then
if (trim(value) .eq. '.true.') restart_eor = .true.
- end if
+ endif
+
+ if (localPet == 0) call cap_profiling("mom", "InitializeP0", "E")
end subroutine
@@ -445,7 +486,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
character(len=40) :: wave_method ! Wave coupling method.
logical :: use_MARBL ! If true, MARBL tracers are being used.
integer :: userRc
- integer :: localPet
integer :: localPeCount
integer :: iostat
integer :: readunit
@@ -463,7 +503,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
!--------------------------------
rc = ESMF_SUCCESS
- if(write_runtimelog) timeiads = MPI_Wtime()
+
+ if (localPet == 0) call cap_profiling("mom", "InitializeAdvertise", "B")
+
+ if (write_runtimelog) timeiads = MPI_Wtime()
call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO)
@@ -478,7 +521,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
call ESMF_VMGetCurrent(vm, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, localPet=localPet, rc=rc)
+ call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc)
@@ -503,7 +546,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
rpointer_filename = 'rpointer.ocn'//trim(inst_suffix)
if (pointer_date) then
- write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)'),year,month,day,hour*3600+minute*60+second
+ write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)')year,month,day,hour*3600+minute*60+second
inquire(file=trim(rpointer_filename//timestamp), exist=found)
! for backward compatibility
if (found) then
@@ -528,7 +571,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
if (cesm_coupled) then
! Multiinstance logfile name needs a correction
- if(len_trim(inst_suffix) > 0) then
+ if (len_trim(inst_suffix) > 0) then
n = index(logfile, '.')
logfile = logfile(1:n-1)//trim(inst_suffix)//logfile(n:)
endif
@@ -617,7 +660,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
if (is_root_pe()) then
write(stdout,*) 'ice_ncat = ', Ice_ocean_boundary%ice_ncat
endif
- end if
+ endif
if (is_root_pe()) then
write(stdout,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second
@@ -668,8 +711,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
call ESMF_LogWrite('MOM_cap: restart requested, using '//trim(rpointer_filename), ESMF_LOGMSG_WARNING)
call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call ESMF_VMGet(vm, localPet=localPet, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
if (localPet == 0) then
open(newunit=readunit, file=rpointer_filename, form='formatted', status='old', iostat=iostat)
@@ -904,7 +945,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, name=fldsFrOcn(n)%shortname, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
enddo
- if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeiads
+ if (write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeiads
+
+ if (localPet == 0) call cap_profiling("mom", "InitializeAdvertise", "E")
end subroutine InitializeAdvertise
@@ -960,7 +1003,6 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
real(ESMF_KIND_R8), pointer :: dataPtr_xcor(:,:)
real(ESMF_KIND_R8), pointer :: dataPtr_ycor(:,:)
integer :: mpicom
- integer :: localPet
integer :: localPeCount
integer :: lsize
integer :: ig,jg, ni,nj,k
@@ -999,7 +1041,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
!--------------------------------
rc = ESMF_SUCCESS
- if(write_runtimelog) timeirls = MPI_Wtime()
+
+ if (localPet == 0) call cap_profiling("mom", "InitializeRealize", "B")
+
+ if (write_runtimelog) timeirls = MPI_Wtime()
call shr_log_setLogUnit (stdout)
@@ -1021,7 +1066,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
call ESMF_VMGetCurrent(vm, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc)
+ call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
!---------------------------------
@@ -1208,7 +1253,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
do n = 1,numOwnedElements
lonMesh(n) = ownedElemCoords(2*n-1)
latMesh(n) = ownedElemCoords(2*n)
- end do
+ enddo
elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -1225,8 +1270,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
mask(n) = ocean_grid%mask2dT(ig,jg)
lon(n) = ocean_grid%geolonT(ig,jg)
lat(n) = ocean_grid%geolatT(ig,jg)
- end do
- end do
+ enddo
+ enddo
eps_omesh = get_eps_omesh(ocean_state)
do n = 1,lsize
@@ -1252,7 +1297,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
write(err_msg, frmt)n,maskMesh(n),mask(n)
call MOM_error(FATAL, err_msg)
endif
- end do
+ enddo
! realize the import and export fields using the mesh
call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", &
@@ -1297,8 +1342,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
mod2med_areacor(k) = model_areas(k) / mesh_areas(k)
med2mod_areacor(k) = mesh_areas(k) / model_areas(k)
endif
- end do
- end do
+ enddo
+ enddo
deallocate(mesh_areas)
deallocate(model_areas)
@@ -1573,6 +1618,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
!---------------------------------
call mom_set_geomtype(geomtype)
+ if (use_cdeps_inline) then
+ call mom_inline_init(gcomp, clock, eMesh, localPet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+
!---------------------------------
! write out diagnostics
!---------------------------------
@@ -1582,7 +1632,9 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
!if (ChkErr(rc,__LINE__,u_FILE_u)) return
timere = 0.
- if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeirls
+ if (write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeirls
+
+ if (localPet == 0) call cap_profiling("mom", "InitializeRealize", "E")
end subroutine InitializeRealize
@@ -1615,7 +1667,9 @@ subroutine DataInitialize(gcomp, rc)
real(8) :: MPI_Wtime, timedis
!--------------------------------
- if(write_runtimelog) timedis = MPI_Wtime()
+ if (localPet == 0) call cap_profiling("mom", "DataInitialize", "B")
+
+ if (write_runtimelog) timedis = MPI_Wtime()
! query the Component for its clock, importState and exportState
call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc)
@@ -1677,7 +1731,9 @@ subroutine DataInitialize(gcomp, rc)
enddo
endif
- if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timedis
+ if (write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timedis
+
+ if (localPet == 0) call cap_profiling("mom", "DataInitialize", "E")
end subroutine DataInitialize
@@ -1720,7 +1776,6 @@ subroutine ModelAdvance(gcomp, rc)
character(ESMF_MAXSTR) :: casename
integer :: iostat
integer :: writeunit
- integer :: localPet
type(ESMF_VM) :: vm
integer :: n, i
character(240) :: import_timestr, export_timestr
@@ -1735,10 +1790,13 @@ subroutine ModelAdvance(gcomp, rc)
logical :: write_restart_eor
rc = ESMF_SUCCESS
- if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ")
- if(write_runtimelog) then
+
+ if (localPet == 0) call cap_profiling("mom", "ModelAdvance", "B")
+
+ if (profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ")
+ if (write_runtimelog) then
timers = MPI_Wtime()
- if(timere>0. .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time since last time step ',timers-timere
+ if (timere>0. .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time since last time step ',timers-timere
endif
call shr_log_setLogUnit (stdout)
@@ -1765,7 +1823,9 @@ subroutine ModelAdvance(gcomp, rc)
call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO)
call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
Time_step_coupled = esmf2fms_time(timeStep)
Time = esmf2fms_time(currTime)
@@ -1844,9 +1904,15 @@ subroutine ModelAdvance(gcomp, rc)
! Import data
!---------------
- call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc)
+ call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, &
+ set_missing_stks_to_zero, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (use_cdeps_inline) then
+ call mom_inline_run(clock, ocean_public, ocean_grid, ice_ocean_boundary, dbug, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+
!---------------
! Update MOM6
!---------------
@@ -1867,7 +1933,7 @@ subroutine ModelAdvance(gcomp, rc)
call state_diagnose(exportState,subname//':ES ',rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
endif
- endif
+ endif ! do_advance
!---------------
! Get the stop alarm
@@ -1890,18 +1956,18 @@ subroutine ModelAdvance(gcomp, rc)
! turn off the alarm
call ESMF_AlarmRingerOff(restart_alarm, rc=rc )
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
+ endif
write_restart_eor = .false.
if (restart_eor) then
if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- write_restart_eor = .true.
- ! turn off the alarm
- call ESMF_AlarmRingerOff(stop_alarm, rc=rc )
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- end if
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ write_restart_eor = .true.
+ ! turn off the alarm
+ call ESMF_AlarmRingerOff(stop_alarm, rc=rc )
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+ endif
#ifndef CESMCOUPLED
call is_restart_fh(clock, restartfh_info, write_restartfh)
@@ -1920,10 +1986,8 @@ subroutine ModelAdvance(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call ESMF_VMGet(vm, localPet=localPet, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)'),year,month,day,hour*3600+minute*60+seconds
+ write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)')year,month,day,hour*3600+minute*60+seconds
rpointer_filename = 'rpointer.ocn'//trim(inst_suffix)
if (pointer_date) then
@@ -1973,8 +2037,10 @@ subroutine ModelAdvance(gcomp, rc)
! write restart file(s)
call ocean_model_restart(ocean_state, restartname=restartname, &
- stoch_restartname=stoch_restartname)
+ stoch_restartname=stoch_restartname, num_rest_files=num_rest_files)
+ call outputlog_restart(clock, num_rest_files, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
endif
if (is_root_pe()) then
@@ -1983,6 +2049,9 @@ subroutine ModelAdvance(gcomp, rc)
endif
endif ! restart_mode
+ call outputlog_run(clock, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
!---------------
! Write diagnostics
!---------------
@@ -2004,12 +2073,14 @@ subroutine ModelAdvance(gcomp, rc)
enddo
endif
- if(write_runtimelog) then
+ if (write_runtimelog) then
timere = MPI_Wtime()
- if(is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', timere-timers
+ if (is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', timere-timers
endif
- if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ")
+ if (profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ")
+
+ if (localPet == 0) call cap_profiling("mom", "ModelAdvance", "E")
end subroutine ModelAdvance
@@ -2039,6 +2110,8 @@ subroutine ModelSetRunClock(gcomp, rc)
rc = ESMF_SUCCESS
+ if (localPet == 0) call cap_profiling("mom", "ModelSetRunClock", "B")
+
! query the Component for its clock, importState and exportState
call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -2178,6 +2251,8 @@ subroutine ModelSetRunClock(gcomp, rc)
call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc)
call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO)
+ call outputlog_init(gcomp, mclock, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
first_time = .false.
endif
@@ -2192,6 +2267,8 @@ subroutine ModelSetRunClock(gcomp, rc)
call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (localPet == 0) call cap_profiling("mom", "ModelSetRunClock", "E")
+
end subroutine ModelSetRunClock
!===============================================================================
@@ -2218,11 +2295,13 @@ subroutine ocean_model_finalize(gcomp, rc)
character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)'
real(8) :: MPI_Wtime, timefs
+ if (localPet == 0) call cap_profiling("mom", "ocean_model_finalize", "B")
+
if (is_root_pe()) then
write(stdout,*) 'MOM: --- finalize called ---'
endif
rc = ESMF_SUCCESS
- if(write_runtimelog) timefs = MPI_Wtime()
+ if (write_runtimelog) timefs = MPI_Wtime()
call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -2251,7 +2330,15 @@ subroutine ocean_model_finalize(gcomp, rc)
call io_infra_end()
call MOM_infra_end()
- if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timefs
+ ! need to call twice to force logging of last output file
+ call outputlog_run(clock, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call outputlog_run(clock, .true., rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ if (write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timefs
+
+ if (localPet == 0) call cap_profiling("mom", "ocean_model_finalize", "E")
end subroutine ocean_model_finalize
diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90
index 809a507e5e..a978b4906a 100644
--- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90
+++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Contains import/export methods for CMEPS.
module MOM_cap_methods
@@ -23,7 +27,7 @@ module MOM_cap_methods
use mpp_domains_mod, only: mpp_get_compute_domain
! By default make data private
-implicit none; private
+implicit none ; private
! Public member functions
public :: mom_set_geomtype
@@ -72,12 +76,16 @@ end subroutine mom_set_geomtype
!> This function has a few purposes:
!! (1) it imports surface fluxes using data from the mediator; and
!! (2) it can apply restoring in SST and SSS.
-subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc)
- type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state
- type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid
- type(ESMF_State) , intent(inout) :: importState !< incoming data from mediator
- type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing
- integer , intent(inout) :: rc !< Return code
+!! (3) it can convert imported stokes drift components to zero if they are missing.
+subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, &
+ set_missing_stks_to_zero, rc)
+ type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state
+ type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid
+ logical , intent(in) :: set_missing_stks_to_zero !< If true, set
+ !! missing stokes drift to zero
+ type(ESMF_State) , intent(inout) :: importState !< incoming data from mediator
+ type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing
+ integer , intent(inout) :: rc !< Return code
! Local Variables
integer :: i, j, ib, ig, jg, n
@@ -241,7 +249,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
call state_getimport(importState, 'Foxx_hrain', isc, iec, jsc, jec, &
ice_ocean_boundary%hrain, areacor=med2mod_areacor, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
+ endif
!----
! enthalpy from frozen precipitation (hsnow)
@@ -250,7 +258,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
call state_getimport(importState, 'Foxx_hsnow', isc, iec, jsc, jec, &
ice_ocean_boundary%hsnow, areacor=med2mod_areacor, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
+ endif
!----
! enthalpy from liquid runoff (hrofl)
@@ -259,7 +267,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
call state_getimport(importState, 'Foxx_hrofl', isc, iec, jsc, jec, &
ice_ocean_boundary%hrofl, areacor=med2mod_areacor, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
+ endif
!----
! enthalpy from frozen runoff (hrofi)
@@ -268,7 +276,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
call state_getimport(importState, 'Foxx_hrofi', isc, iec, jsc, jec, &
ice_ocean_boundary%hrofi, areacor=med2mod_areacor, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
+ endif
!----
! enthalpy from liquid glc runoff (hrofl_glc)
@@ -277,7 +285,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
call state_getimport(importState, 'Foxx_hrofl_glc', isc, iec, jsc, jec, &
ice_ocean_boundary%hrofl_glc, areacor=med2mod_areacor, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
+ endif
!----
! enthalpy from frozen glc runoff (hrofi_glc)
@@ -286,7 +294,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
call state_getimport(importState, 'Foxx_hrofi_glc', isc, iec, jsc, jec, &
ice_ocean_boundary%hrofi_glc, areacor=med2mod_areacor, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
+ endif
!----
! enthalpy from evaporation (hevap)
!----
@@ -294,7 +302,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
call state_getimport(importState, 'Foxx_hevap', isc, iec, jsc, jec, &
ice_ocean_boundary%hevap, areacor=med2mod_areacor, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
+ endif
!----
! enthalpy from condensation (hcond)
@@ -383,7 +391,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
areacor=med2mod_areacor, do_sum=.true., esmf_ind=esmf_ind, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
enddo
- end if
+ endif
!----
! dust flux from sea ice
@@ -537,12 +545,26 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary,
do i = isc, iec
ig = i + ocean_grid%isc - isc
!rotate
- do ib = 1, nsc
- ice_ocean_boundary%ustkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stkx(i,j,ib) &
- - ocean_grid%sin_rot(ig,jg)*stky(i,j,ib)
- ice_ocean_boundary%vstkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stky(i,j,ib) &
- + ocean_grid%sin_rot(ig,jg)*stkx(i,j,ib)
- enddo
+ if (set_missing_stks_to_zero) then
+ do ib = 1, nsc
+ if ((abs(stkx(i,j,ib)-9.99E20_ESMF_KIND_R8) <= 0.01_ESMF_KIND_R8)) then
+ ice_ocean_boundary%ustkb(i,j,ib) = 0.0
+ ice_ocean_boundary%vstkb(i,j,ib) = 0.0
+ else
+ ice_ocean_boundary%ustkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stkx(i,j,ib) &
+ - ocean_grid%sin_rot(ig,jg)*stky(i,j,ib)
+ ice_ocean_boundary%vstkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stky(i,j,ib) &
+ + ocean_grid%sin_rot(ig,jg)*stkx(i,j,ib)
+ endif
+ enddo
+ else
+ do ib = 1, nsc
+ ice_ocean_boundary%ustkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stkx(i,j,ib) &
+ - ocean_grid%sin_rot(ig,jg)*stky(i,j,ib)
+ ice_ocean_boundary%vstkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stky(i,j,ib) &
+ + ocean_grid%sin_rot(ig,jg)*stkx(i,j,ib)
+ enddo
+ endif
! apply masks
ice_ocean_boundary%ustkb(i,j,:) = ice_ocean_boundary%ustkb(i,j,:) * ocean_grid%mask2dT(ig,jg)
ice_ocean_boundary%vstkb(i,j,:) = ice_ocean_boundary%vstkb(i,j,:) * ocean_grid%mask2dT(ig,jg)
diff --git a/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90 b/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90
new file mode 100644
index 0000000000..7b9b7595bd
--- /dev/null
+++ b/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90
@@ -0,0 +1,623 @@
+!> This module contains a set of subroutines that check if MOM restart and history files
+!! have been written and closed. This file is specific to UWM operational requirements
+!! and configurations (eg specific output frequencies in hours) and may break if used outside
+!! the scope of intended use.
+!! This module is a stub when CESMCOUPLED is defined
+module MOM_cap_outputlog
+
+#ifdef CESMCOUPLED
+use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_SUCCESS
+implicit none ; private
+
+public :: outputlog_init, outputlog_run, outputlog_restart
+contains
+subroutine outputlog_init(gcomp, mclock, rc)
+ type(ESMF_GridComp) :: gcomp !< an ESMF_GridComp object
+ type(ESMF_Clock) :: mclock !< the ESMF_clock for the model
+ integer, intent(out) :: rc !< return code
+ rc = ESMF_SUCCESS
+end subroutine outputlog_init
+subroutine outputlog_run(mclock, atStopTime, rc)
+ type(ESMF_Clock) :: mclock !< the ESMF_clock for the model
+ logical, intent(in), optional :: atStopTime !< if true, checks for final output file
+ integer, intent(out) :: rc !< return code
+ rc = ESMF_SUCCESS
+end subroutine outputlog_run
+subroutine outputlog_restart(mclock, num_rest_files, rc)
+ type(ESMF_Clock) :: mclock !< the ESMF_clock for the model
+ integer, intent(in) :: num_rest_files !< the number of restart files
+ integer, intent(out) :: rc !< return code
+ rc = ESMF_SUCCESS
+end subroutine outputlog_restart
+#else
+use MOM_error_handler , only : is_root_pe, MOM_error, FATAL
+use NUOPC , only : NUOPC_CompAttributeGet
+use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_VM, ESMF_VMGet
+use ESMF , only : ESMF_Time, ESMF_Clock, ESMF_ClockGet, ESMF_Alarm, ESMF_AlarmSet
+use ESMF , only : ESMF_ClockGetAlarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff
+use ESMF , only : ESMF_ClockGetNextTime, ESMF_TimeGet, ESMF_TimeInterval
+use ESMF , only : ESMF_AlarmGet, ESMF_TimeIntervalSet, ESMF_TimeIntervalPrint
+use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_VMBroadCast
+use ESMF , only : ESMF_LogSetError, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU
+use ESMF , only : operator(*), operator(+), operator(-), operator(>), operator(==)
+use MOM_cap_methods , only : ChkErr
+use MOM_cap_time , only : AlarmInit
+use shr_is_restart_fh_mod , only : log_restart_fh
+use netcdf
+
+implicit none ; private
+
+public :: outputlog_init, outputlog_run, outputlog_restart
+
+! the allowable output frequency for MOM6 history, in hours only
+integer, parameter :: n_freq = 3
+integer, parameter, dimension(n_freq) :: freq = (/3, 6, 24/)
+! TODO: for multiple output freq in same run, a different known filename
+! root for different freqs needs to be read in, consistent with the diag table
+
+! the tincrement interval (defined in minutes) is used to construct the output filename
+! the file name must be set as the mid-point of the averaging period via the diagtable
+! and the output filename timestrings are given by
+! T - (interval * 60 * increment + interval/2 * 60 * increment )
+! where T is the time when the file is closed
+!
+! 00 . 03 . 06 . 09
+! 1:30 = 6 - (3 + 1:30)
+! 4:30 = 9 - (3 + 1:30)
+!
+! 00 . 06 . 12 . 18
+! 03 = 12 - (6 + 3)
+! 09 = 18 - (6 + 3)
+!
+! 00 . 24 . 48 . 72
+! 12 = 48 - (24 + 12)
+! 36 = 72 - (24 + 12)
+!
+! when the model reaches the stop time, any 'pending' output file is closed, and the final
+! interval output is also closed
+!
+! stop
+! 18 . 24 . 30
+! 21 = 30 - (12 + 3)
+! 03 = 30 - (3)
+!
+! since both the final interval and the next-to-final interval can be closed at the stop time,
+! a different log file name is required for the final log file, otherwise the next-to-final
+! log is overwritten
+!
+! Depending on configuration, the output file can have an unlimited dimension >0 at creation time.
+! This necessitates checking for an additional criteria using the filesize at creation. An output file
+! is declared complete either when the unlimited dimension in the file is >0 or when the unlimited
+! dimension is >0 and the filesize is larger than the initial size.
+
+! When a file is determined to be complete, a log file is recorded containing the forecast hour, the valid
+! time, the name of the output file and the last completed restart file.
+
+type(ESMF_VM) :: vm
+type(ESMF_TimeInterval) :: tincrement
+type(ESMF_Time) :: lastrestart
+
+type :: outputlog_type
+ character(len=14) :: alarm_name
+ integer :: opt_n
+ logical :: chkfile_nextAdvance
+ logical :: use_filesize
+ character(len=256) :: filename
+ integer :: createsize
+ type(ESMF_Alarm) :: alarm
+ type(ESMF_TimeInterval) :: fhoffset
+ type(ESMF_TimeInterval) :: filename_fhoffset
+ type(ESMF_Time) :: time_lastrestart
+end type outputlog_type
+
+type(outputlog_type) :: olog(n_freq)
+
+integer :: toffset
+logical :: debug
+logical :: existflag
+character(len=256) :: restartdir
+character(len=256) :: outputdir
+character(len=2) :: output_fh
+character(len=*), parameter :: u_FILE_u = &
+ __FILE__
+
+contains
+!> Initialize a set of Alarms at the allowed output frequencies
+!!
+!! @param gcomp an ESMF_GridComp object
+!! @param clock an ESMF_Clock object
+!! @param rc return code
+subroutine outputlog_init(gcomp, mclock, rc)
+ type(ESMF_GridComp) :: gcomp
+ type(ESMF_Clock) :: mclock
+ integer, intent(out) :: rc
+
+ ! local variables
+ type(ESMF_Time) :: mcurrTime
+ type(ESMF_TimeInterval) :: alarmoffset
+ logical :: isPresent, isSet
+ integer :: n
+ integer :: year, month, day, hour
+ character(len=3) :: chour
+ character(len=256) :: msgString
+ character(len=256) :: value
+ character(len=256) :: subname='MOM_cap:(outputlog_init)'
+ !----------------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+ call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompAttributeGet(gcomp, name="mom6_restart_dir", value=value, &
+ isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) then
+ restartdir = trim(value)
+ else
+ restartdir = './'
+ endif
+ if (restartdir(len_trim(restartdir):len_trim(restartdir)) /= '/') then
+ restartdir = trim(restartdir)//'/'
+ endif
+ write(msgString,'(A)')'MOM_cap:MOM6 restart directory = '//trim(restartdir)
+ call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO)
+
+ call NUOPC_CompAttributeGet(gcomp, name="mom6_output_dir", value=value, &
+ isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) then
+ outputdir = trim(value)
+ else
+ outputdir = './'
+ endif
+ if (outputdir(len_trim(outputdir):len_trim(outputdir)) /= '/') then
+ outputdir = trim(outputdir)//'/'
+ endif
+ write(msgString,'(A)')'MOM_cap:MOM6 output directory = '//trim(outputdir)
+ call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO)
+
+ call NUOPC_CompAttributeGet(gcomp, name="mom6_output_fh", value=value, &
+ isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) then
+ if (len_trim(value) == 1) then
+ output_fh = '0'//trim(value)
+ else
+ output_fh = trim(value)
+ endif
+ else
+ output_fh = '06'
+ endif
+ write(msgString,'(A)')'MOM_cap:MOM6 output frequency = '//trim(output_fh)
+ call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO)
+
+ debug = .false.
+ call NUOPC_CompAttributeGet(gcomp, name="debug_outputlog", value=value, &
+ isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) debug=(trim(value)=="true")
+ if (debug) call ESMF_LogWrite('MOM_cap:MOM6 output debug ON', ESMF_LOGMSG_INFO)
+
+ call ESMF_ClockGet(mclock, currTime=mcurrTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_TimeIntervalSet(tincrement, m=1, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! get start hour time offset (ie, fhrot)
+ call ESMF_TimeGet(mcurrTime, yy=year, mm=month, dd=day, h=hour, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (mod(hour,6) /= 0) then
+ toffset = hour - 6
+ else
+ toffset = 0
+ endif
+ if (debug .and. is_root_pe()) then
+ print '(A,i8)',trim(subname)//' toffset = ',toffset
+ endif
+ ! initialize
+ lastrestart = mcurrTime
+
+ do n = 1,n_freq
+ write(chour,'(I2.2,A)')freq(n),'h'
+ olog(n)%alarm_name = 'output_alarm'//trim(chour)
+ olog(n)%opt_n = freq(n)
+ olog(n)%chkfile_nextAdvance = .false.
+ olog(n)%use_filesize = .false.
+ olog(n)%filename = ''
+ olog(n)%createsize = 0
+ olog(n)%time_lastrestart = lastrestart
+ olog(n)%fhoffset = 60*freq(n)*tincrement
+ olog(n)%filename_fhoffset = 90*freq(n)*tincrement
+
+ ! the time offset in hours required to ensure the alarm rings at multiples of 6
+ if (freq(n) >= 6) then
+ alarmoffset = toffset*60*tincrement
+ else
+ alarmoffset = 0*tincrement
+ endif
+
+ call AlarmInit(mclock, &
+ alarm = olog(n)%alarm, &
+ option = 'nhours', &
+ opt_n = olog(n)%opt_n, &
+ opt_ymd = -999, &
+ RefTime = mcurrTime+alarmoffset, &
+ alarmname = olog(n)%alarm_name, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_AlarmSet(olog(n)%alarm, clock=mclock, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ write(msgString,'(A)')trim(subname)//' Output alarm '//trim(olog(n)%alarm_name)//' Created & Set'
+ call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO)
+ if (debug .and. is_root_pe()) then
+ call ESMF_TimeIntervalPrint(olog(n)%filename_fhoffset, options="string", rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+ enddo
+end subroutine outputlog_init
+
+!> Write a log file denoting that an output file is complete
+!!
+!! @param clock an ESMF_Clock object
+!! @param atStopTime when present, checks for final output file
+!! @param rc return code
+subroutine outputlog_run(mclock, atStopTime, rc)
+ type(ESMF_Clock) :: mclock
+ logical, intent(in), optional :: atStopTime
+ integer, intent(out) :: rc
+
+ ! local variables
+ type(ESMF_Time) :: nextTime, currTime, startTime, prevRing
+ logical :: lstop
+ logical :: filecomplete
+ integer :: n, nlen(1), fsize(1)
+ character(len=3) :: chour
+ character(len=40) :: importexport
+ character(len=16) :: timestr
+ character(len=256) :: fname
+ character(len=256) :: subname='MOM_cap:(outputlog_run)'
+ !----------------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ call ESMF_ClockGet(mclock, startTime=startTime, currTime=currTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_ClockGetNextTime(mclock, nextTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ importexport = get_importexport(currTime, nextTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ lstop = .false.
+ if (present(atStopTime)) then
+ lstop = atStopTime
+ endif
+
+ filecomplete = .false.
+ fsize(1) = nf90_fill_int
+ nlen(1) = nf90_fill_int
+
+ do n = 1,n_freq
+ write(chour,'(I2.2,A)')freq(n),'h'
+ if (chour(1:2) == output_fh(1:2)) then
+ call ESMF_ClockGetAlarm(mclock, alarmname=trim(olog(n)%alarm_name), alarm=olog(n)%alarm, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ! when the alarm rings, set file check on next advance and construct the filename
+ if (ESMF_AlarmIsRinging(olog(n)%alarm, rc=rc)) then
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_AlarmRingerOff(olog(n)%alarm, rc=rc )
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ olog(n)%chkfile_nextAdvance = .true.
+
+ timestr = get_timestr(nextTime-olog(n)%filename_fhoffset, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ write(olog(n)%filename,'(A)')trim(outputdir)//'ocn_'//trim(timestr)//'.nc'
+
+ fname = trim(olog(n)%filename)
+ inquire(file=fname, exist=existflag)
+ if (existflag) then
+ if (is_root_pe()) then
+ nlen(1) = get_unlimited_len(trim(fname))
+ inquire(file=fname, size=fsize(1))
+ endif
+ call ESMF_VMBroadCast(vm, nlen, 1, 0, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_VMBroadCast(vm, fsize, 1, 0, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ olog(n)%createsize = fsize(1)
+
+ if (nlen(1) == 0) then
+ olog(n)%use_filesize = .false.
+ else
+ olog(n)%use_filesize = .true.
+ endif
+ endif
+ if (debug .and. is_root_pe()) then
+ print '(A,2(A,L),A,2i16)',trim(subname)//' fname '//trim(olog(n)%filename)//' '//trim(importexport), &
+ ' checkflag ',olog(n)%chkfile_nextAdvance,' use_filesize ',olog(n)%use_filesize, &
+ ' ',olog(n)%createsize,nlen(1)
+ endif
+ endif
+
+ if (olog(n)%chkfile_nextAdvance) then
+ fname = trim(olog(n)%filename)
+ filecomplete = file_is_complete(fname, olog(n)%use_filesize, olog(n)%createsize, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ if (filecomplete) then
+ olog(n)%chkfile_nextAdvance = .false.
+ olog(n)%time_lastrestart = lastrestart
+ if (is_root_pe()) then
+ call log_restart_fh(currTime-olog(n)%fhoffset, startTime, 'mom6.'//chour, prefixtime=.true., &
+ lastrestart=olog(n)%time_lastrestart, lastoutput=olog(n)%filename, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+ endif
+ endif
+ if (debug .and. is_root_pe()) call debug_info(trim(subname)//' ',trim(olog(n)%filename), &
+ olog(n)%chkfile_nextAdvance, olog(n)%createsize, importexport)
+
+ if (lstop) then
+ ! use prevRing in place of currTime to allow for stopping between averaging intervals
+ ! prevring == currTime if stopping on intervals
+ call ESMF_AlarmGet(olog(n)%alarm, prevRingTime=prevring, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ timestr = get_timestr(prevring-30*freq(n)*tincrement, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ write(olog(n)%filename,'(A)')trim(outputdir)//'ocn_'//trim(timestr)//'.nc'
+
+ fname = trim(olog(n)%filename)
+ filecomplete = file_is_complete(fname, olog(n)%use_filesize, olog(n)%createsize, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ if (filecomplete) then
+ olog(n)%chkfile_nextAdvance = .false.
+ olog(n)%time_lastrestart = lastrestart
+ if (is_root_pe()) then
+ call log_restart_fh(prevring, startTime, 'mom6.lstop.'//chour, prefixtime=.true., &
+ lastrestart=olog(n)%time_lastrestart, lastoutput=olog(n)%filename, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+ endif
+ if (debug .and. is_root_pe()) call debug_info(trim(subname)//' lstop ',trim(olog(n)%filename), &
+ olog(n)%chkfile_nextAdvance, olog(n)%createsize, importexport)
+
+ endif ! lstop
+ endif ! chour = output_fh
+ enddo
+end subroutine outputlog_run
+
+!> Check all restart files to determine if output has been completed
+!!
+!! @param[in] clock an ESMF_Clock object
+!! @param[in] num_rest_files the number of restart files
+!! @param[out] rc return code
+subroutine outputlog_restart(mclock, num_rest_files, rc)
+ type(ESMF_Clock) :: mclock
+ integer, intent(in) :: num_rest_files
+ integer, intent(out) :: rc
+
+ ! local variables
+ type(ESMF_Time) :: startTime, currTime, nextTime
+ integer :: n, nlen(1)
+ integer :: year, month, day, hour, minute, seconds
+ character(len=256) :: fname
+ character(len=15) :: timestr
+ character(len=40) :: importexport
+ logical, allocatable :: allDone(:)
+ character(len=8) :: suffix
+ character(len=256) :: subname='MOM_cap:(outputlog_restart)'
+ !----------------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ call ESMF_ClockGet(mclock, startTime=startTime, currTime=currTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_ClockGetNextTime(mclock, nextTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ importexport = get_importexport(currTime, nextTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_TimeGet(nextTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc )
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ write(timestr,'(I4.4,2(I2.2),A,3(I2.2))') year, month, day,".", hour, minute, seconds
+
+ allocate(allDone(1:num_rest_files))
+ allDone = .false.
+
+ do n = 1,num_rest_files
+ if (n == 1) then
+ suffix = ''
+ else if (n-1 < 10) then
+ write(suffix,'("_",I1)') n-1
+ else
+ write(suffix,'("_",I2)') n-1
+ endif
+ if (len_trim(suffix) == 0) then
+ fname = trim(restartdir)//trim(timestr)//'.MOM.res.nc'
+ else
+ fname = trim(restartdir)//trim(timestr)//'.MOM.res'//trim(suffix)//'.nc'
+ endif
+
+ ! check if file is written
+ inquire(file=trim(fname), exist=existflag)
+ if (existflag) then
+ if (is_root_pe())then
+ nlen(1) = get_unlimited_len(trim(fname))
+ endif
+ call ESMF_VMBroadCast(vm, nlen, 1, 0, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ if (nlen(1) > 0) allDone(n) = .true.
+ if (debug .and. is_root_pe()) then
+ if (nlen(1) > 0) then
+ print '(A)',trim(subname)//' restart '//trim(fname)//' '//trim(importexport)//' complete'
+ else
+ print '(A)',trim(subname)//' restart '//trim(fname)//' '//trim(importexport)//' still 0'
+ endif
+ endif
+ endif
+ enddo ! num_rest_files
+
+ if (all(allDone) .eqv. .true.) then
+ lastrestart = nextTime
+ if (is_root_pe()) then
+ call log_restart_fh(nextTime, startTime, 'mom6.res', prefixtime=.true., rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+ endif
+end subroutine outputlog_restart
+
+!> Determine if the netcdf output file is complete
+!!
+!! @param[in] fname the file name
+!! @param[in] chk4size logical flag for check method in use
+!! @param[in] createsize the filesize at creation
+!! @param[out] rc return code
+!! @return logical flag, true if the file is complete
+logical function file_is_complete(fname, chk4size, createsize, rc) result(filecomplete)
+ character(len=*), intent(in) :: fname
+ logical, intent(in) :: chk4size
+ integer, intent(in) :: createsize
+ integer, intent(out) :: rc
+
+ integer :: nlen(1), fsize(1)
+ !----------------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ filecomplete = .false.
+ nlen(1) = nf90_fill_int
+ fsize(1) = nf90_fill_int
+
+ inquire(file=fname, exist=existflag)
+ if (existflag) then
+ if (is_root_pe()) then
+ nlen(1) = get_unlimited_len(fname)
+ inquire(file=fname, size=fsize(1))
+ endif
+ call ESMF_VMBroadCast(vm, nlen, 1, 0, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_VMBroadCast(vm, fsize, 1, 0, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+
+ if (chk4size) then
+ filecomplete = (nlen(1) > 0 .and. fsize(1) > createsize)
+ else
+ filecomplete = (nlen(1) > 0)
+ endif
+end function file_is_complete
+
+!> Return the length of the unlimited dimension
+!!
+!! @param[in] fname the file name
+!! @return unlimited dimension length
+integer function get_unlimited_len(fname) result(unlen)
+ character(len=*), intent(in) :: fname
+
+ integer :: ncid, dimid
+ !----------------------------------------------------------------------------
+
+ unlen = 0
+ call nf90_err(nf90_open(trim(fname), nf90_nowrite, ncid), 'nf90_open: '//trim(fname))
+ call nf90_err(nf90_inquire(ncid, unlimiteddimid=dimid), 'inquire unlimiteddimid')
+ call nf90_err(nf90_inquire_dimension(ncid, dimid, len=unlen), 'inquire unlimited dimension')
+ call nf90_err(nf90_close(ncid), 'close: '//trim(fname))
+end function get_unlimited_len
+
+!> Convenience function to return a 16-character time string
+!!
+!! @param[in] MyTime an ESMF_Time object
+!! @param[out] rc return code
+!! @return 16-character formatted time string (YYYY_MM_DD_HH_MM)
+character(len=16) function get_timestr(MyTime, rc) result(timestr)
+ type(ESMF_Time), intent(in) :: MyTime
+ integer, intent(out) :: rc
+
+ integer :: year, month, day, hour, minute
+ !----------------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ call ESMF_TimeGet(MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ write(timestr,'(I4.4,4(A,I2.2))')year,'_',month,'_',day,'_',hour,'_',minute
+end function get_timestr
+
+!> Convenience function to return import/export timestring
+!!
+!! @param[in] currTime an ESMF_Time object
+!! @param[in] nextTime an ESMF_Time object
+!! @param[out] rc return code
+!! @return 40-character string
+character(len=40) function get_importexport(currTime, nextTime, rc) result(importexport)
+
+ type(ESMF_Time), intent(in) :: currTime, nextTime
+ integer, intent(out) :: rc
+
+ character(len=19) :: import_timestr, export_timestr
+ !----------------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_TimeGet(nextTime, timestring=export_timestr, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ importexport = trim(import_timestr)//' '//trim(export_timestr)
+end function get_importexport
+
+!> Write debug info to stdout, only called on root pe
+!!
+!! @param[in] tag an information tag
+!! @param[in] fname the filename to check
+!! @param[in] filesize the filesize at creation time
+!! @param[in] chkflag logical flag for checking next Advance
+!! @param[in] timestring a timestring
+subroutine debug_info(tag,fname,chkflag,filesize,timestring)
+ character(len=*), intent(in) :: tag
+ character(len=*), intent(in) :: fname
+ integer, intent(in) :: filesize
+ logical, intent(in) :: chkflag
+ character(len=*), intent(in) :: timestring
+
+ integer :: fsize
+ character(len=256) :: msgString
+ !----------------------------------------------------------------------------
+
+ inquire(file=fname, exist=existflag)
+ if (existflag) then
+ inquire(file=fname, size=fsize)
+ write(msgString,'(A)')tag//' '//fname//' exists '//timestring
+ if (chkflag) then
+ print '(A,L,2i16)',trim(msgString)//' not complete, chkflag ',chkflag,filesize,fsize
+ else
+ print '(A,L,2i16)',trim(msgString)//' complete, chkflag ',chkflag,filesize,fsize
+ endif
+ else
+ write(msgString,'(A)')tag//' '//fname//' does not exist '//timestring
+ print '(A)',trim(msgString)
+ endif
+end subroutine debug_info
+
+!> Handle netcdf errors
+!!
+!! @param[in] ierr the error code
+!! @param[in] string the error message
+subroutine nf90_err(ierr, string)
+ integer, intent(in) :: ierr
+ character(len=*), intent(in) :: string
+ !----------------------------------------------------------------------------
+
+ if (ierr /= nf90_noerr) then
+ write(0, '(A)') 'FATAL ERROR: ' // trim(string)// ' : ' // trim(nf90_strerror(ierr))
+ ! This fails on WCOSS2 with Intel 19 compiler. See https://community.intel.com/
+ ! Search term "STOP and ERROR STOP with variable stop codes"
+ ! When WCOSS2 moves to Intel 2020+, uncomment the next line and remove stop 99
+ !stop ierr
+ stop 99
+ endif
+end subroutine nf90_err
+#endif
+end module MOM_cap_outputlog
diff --git a/config_src/drivers/nuopc_cap/mom_cap_profiling.F90 b/config_src/drivers/nuopc_cap/mom_cap_profiling.F90
new file mode 100644
index 0000000000..4e3e387e2d
--- /dev/null
+++ b/config_src/drivers/nuopc_cap/mom_cap_profiling.F90
@@ -0,0 +1,45 @@
+!> Contains wrapper routines that call the ufs tracing routines
+module mom_cap_profiling
+
+#ifdef UFS_TRACING
+ use ufs_trace_mod, only: ufs_trace_init, ufs_trace, ufs_trace_finalize
+#endif
+
+ implicit none
+
+ private
+
+ public cap_profiling_init
+ public cap_profiling
+ public cap_profiling_finalize
+
+contains
+
+!> Wrapper routine that calls ufs_trace_init
+ subroutine cap_profiling_init()
+#ifdef UFS_TRACING
+ call ufs_trace_init()
+#endif
+ return
+ end subroutine cap_profiling_init
+
+!> Wrapper routine that calls ufs_trace
+ subroutine cap_profiling(component, routine, ph)
+ character(len=*), intent(in) :: component !< Name of the component, 'mom'
+ character(len=*), intent(in) :: routine !< Name of the profiled subroutine
+ character(len=*), intent(in) :: ph !< Duration event phase type. 'B' or 'E' for begin/end
+#ifdef UFS_TRACING
+ call ufs_trace(component, routine, ph)
+#endif
+ return
+ end subroutine cap_profiling
+
+!> Wrapper routine that calls ufs_trace_finalize
+ subroutine cap_profiling_finalize()
+#ifdef UFS_TRACING
+ call ufs_trace_finalize()
+#endif
+ return
+ end subroutine cap_profiling_finalize
+
+end module mom_cap_profiling
diff --git a/config_src/drivers/nuopc_cap/mom_cap_time.F90 b/config_src/drivers/nuopc_cap/mom_cap_time.F90
index d8ae6892a9..3f5a303cc8 100644
--- a/config_src/drivers/nuopc_cap/mom_cap_time.F90
+++ b/config_src/drivers/nuopc_cap/mom_cap_time.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This was originally share code in CIME, but required CIME as a
!! dependency to build the MOM cap. The options here for setting
!! a restart alarm are useful for all caps, so a second step is to
@@ -18,7 +22,7 @@ module MOM_cap_time
use ESMF , only : operator(<=), operator(>), operator(==)
use MOM_cap_methods , only : ChkErr
-implicit none; private
+implicit none ; private
public :: AlarmInit ! initialize an alarm
diff --git a/config_src/drivers/nuopc_cap/mom_inline_mod.F90 b/config_src/drivers/nuopc_cap/mom_inline_mod.F90
new file mode 100644
index 0000000000..8b8b544f2f
--- /dev/null
+++ b/config_src/drivers/nuopc_cap/mom_inline_mod.F90
@@ -0,0 +1,218 @@
+!> This module contains a set of subroutines that enables inline CDEPS capability
+
+module mom_inline_mod
+
+use NUOPC , only: NUOPC_CompAttributeGet
+use ESMF , only: ESMF_GridComp, ESMF_Mesh
+use ESMF , only: ESMF_Clock, ESMF_Time, ESMF_TimeGet, ESMF_ClockGet
+use ESMF , only: ESMF_KIND_R8, ESMF_SUCCESS, ESMF_LogFoundError
+use ESMF , only: ESMF_LOGERR_PASSTHRU, ESMF_LOGMSG_INFO, ESMF_LOGWRITE
+use ESMF , only: ESMF_END_ABORT, ESMF_Finalize, ESMF_MAXSTR
+use dshr_mod , only: dshr_pio_init
+use dshr_strdata_mod , only: shr_strdata_type, shr_strdata_print
+use dshr_strdata_mod , only: shr_strdata_init_from_inline
+use dshr_strdata_mod , only: shr_strdata_advance
+use dshr_methods_mod , only: dshr_fldbun_getfldptr, dshr_fldbun_Field_diagnose
+use dshr_stream_mod , only: shr_stream_init_from_esmfconfig
+use MOM_cap_methods , only: ChkErr
+
+implicit none
+private
+
+public mom_inline_init
+public mom_inline_run
+
+type(shr_strdata_type), allocatable :: sdat(:)
+
+integer :: logunit ! the logunit on the root task
+character(len=ESMF_MAXSTR) :: stream_name ! generic identifier
+
+character(len=*), parameter :: u_FILE_u = __FILE__
+contains
+
+!===============================================================================
+subroutine mom_inline_init(gcomp, model_clock, model_mesh, mytask, rc)
+ type(ESMF_GridComp) , intent(in) :: gcomp !< ESMF_GridComp object
+ type(ESMF_Clock) , intent(in) :: model_clock !< ESMF_Clock object
+ type(ESMF_Mesh) , intent(in) :: model_mesh !< ESMF mesh
+ integer , intent(in) :: mytask !< the current task
+ integer , intent(out) :: rc !< Return code
+
+ ! local variables
+ logical :: isPresent, isSet
+ integer :: ns, l
+ integer :: nstreams, nvars
+ type(shr_strdata_type) :: sdatconfig !< stream data from config (xml or esmf), one or more streams
+
+ character(len=ESMF_MAXSTR) :: value, streamfilename
+ character(len=ESMF_MAXSTR), allocatable :: filelist(:)
+ character(len=ESMF_MAXSTR), allocatable :: filevars(:,:)
+
+ character(len=*), parameter :: subname='(mom_inline_init)'
+ !----------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ call NUOPC_CompAttributeGet(gcomp, name="streamfilename", value=value, isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) then
+ streamfilename = value
+ else
+ call ESMF_LogWrite(trim(subname)//': streamfilename must be provided', ESMF_LOGMSG_INFO)
+ call ESMF_Finalize(endflag=ESMF_END_ABORT)
+ return
+ endif
+
+#ifndef CESMCOUPLED
+ if (mytask == 0) then
+ open (newunit=logunit, file='log.mom6.cdeps')
+ else
+ logunit = 6
+ endif
+
+ ! CMEPS Init PIO
+ call dshr_pio_init(gcomp, sdatconfig, logunit, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ ! read the available stream definitions, each data stream is one or more data_files
+ ! which have the same spatial and temporal coordinates
+ call shr_stream_init_from_esmfconfig(trim(streamfilename), sdatconfig%stream, logunit, &
+ sdatconfig%pio_subsystem, sdatconfig%io_type, sdatconfig%io_format, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+#else
+ !TODO: CESM logunit, configuration via xml etc
+ !call shr_stream_init_from_xml(trim(streamfilename) ....
+#endif
+
+ nstreams = size(sdatconfig%stream)
+ ! allocate stream data type
+ if (.not. allocated(sdat)) allocate(sdat(nstreams))
+
+ ! set the model clock and mesh
+ sdat(:)%model_clock = model_clock
+ sdat(:)%model_mesh = model_mesh
+
+ ! loop over streams and initialize
+ do ns = 1, nstreams
+ sdat(ns)%pio_subsystem => sdatconfig%pio_subsystem
+ sdat(ns)%io_type = sdatconfig%io_type
+ sdat(ns)%io_format = sdatconfig%io_format
+
+ allocate(filelist(sdatconfig%stream(ns)%nfiles))
+ allocate(filevars(sdatconfig%stream(ns)%nvars,2))
+
+ ! fill stream info
+ do l = 1, sdatconfig%stream(ns)%nfiles
+ filelist(l) = trim(sdatconfig%stream(ns)%file(l)%name)
+ enddo
+ do l = 1, sdatconfig%stream(ns)%nvars
+ filevars(l,1) = trim(sdatconfig%stream(ns)%varlist(l)%nameinfile)
+ filevars(l,2) = trim(sdatconfig%stream(ns)%varlist(l)%nameinmodel)
+ enddo
+
+ write(stream_name,fmt='(a,i2.2)') 'stream_', ns
+ call shr_strdata_init_from_inline(sdat(ns), &
+ my_task = mytask, &
+ logunit = logunit, &
+ compname = 'OCN', &
+ model_clock = sdat(ns)%model_clock, &
+ model_mesh = sdat(ns)%model_mesh, &
+ stream_name = trim(stream_name), &
+ stream_meshfile = trim(sdatconfig%stream(ns)%meshfile), &
+ stream_filenames = filelist, &
+ stream_yearFirst = sdatconfig%stream(ns)%yearFirst, &
+ stream_yearLast = sdatconfig%stream(ns)%yearLast, &
+ stream_yearAlign = sdatconfig%stream(ns)%yearAlign, &
+ stream_fldlistFile = filevars(:,1), &
+ stream_fldListModel = filevars(:,2), &
+ stream_lev_dimname = trim(sdatconfig%stream(ns)%lev_dimname), &
+ stream_mapalgo = trim(sdatconfig%stream(ns)%mapalgo), &
+ stream_offset = sdatconfig%stream(ns)%offset, &
+ stream_taxmode = trim(sdatconfig%stream(ns)%taxmode), &
+ stream_dtlimit = sdatconfig%stream(ns)%dtlimit, &
+ stream_tintalgo = trim(sdatconfig%stream(ns)%tInterpAlgo), &
+ stream_src_mask = sdatconfig%stream(ns)%src_mask_val, &
+ stream_dst_mask = sdatconfig%stream(ns)%dst_mask_val, &
+ rc = rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ deallocate(filelist)
+ deallocate(filevars)
+ enddo
+
+end subroutine mom_inline_init
+!===============================================================================
+subroutine mom_inline_run(clock, ocean_public, ocean_grid, ice_ocean_boundary, dbug, rc)
+ use MOM_ocean_model_nuopc, only: ocean_public_type
+ use MOM_surface_forcing_nuopc, only: ice_ocean_boundary_type
+ use MOM_grid, only: ocean_grid_type
+ use mpp_domains_mod, only: mpp_get_compute_domain
+
+ type(ESMF_Clock) , intent(in) :: clock !< ESMF_Clock object
+ type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state
+ type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid
+ type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing
+ integer , intent(in) :: dbug !< Integer debug flag
+ integer , intent(out) :: rc !< Return code
+
+ ! local variables
+ type(ESMF_Time) :: date
+ integer :: nstreams, nflds
+ integer :: ns,nf,n,i,j
+ integer :: isc, iec, jsc, jec
+ integer :: year ! year (0, ...) for nstep+1
+ integer :: mon ! month (1, ..., 12) for nstep+1
+ integer :: day ! day of month (1, ..., 31) for nstep+1
+ integer :: sec ! seconds into current date for nstep+1
+ integer :: mcdate ! Current model date (yyyymmdd)
+ character(len=ESMF_MAXSTR) :: fldname
+ real(ESMF_KIND_R8), pointer :: dataPtr1d(:)
+ character(len=*), parameter :: subname='(mom_inline_run)'
+ !-----------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ ! The following are global indices without halos
+ call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec)
+
+ ! Current model date
+ call ESMF_ClockGet( clock, currTime=date, rc=rc )
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_TimeGet(date, yy=year, mm=mon, dd=day, s=sec, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ mcdate = year*10000 + mon*100 + day
+
+ nstreams = size(sdat)
+ ! Advance the streams
+ do ns = 1,nstreams
+ write(stream_name,fmt='(a,i2.2)') 'stream_', ns
+ call shr_strdata_advance(sdat(ns), ymd=mcdate, tod=sec, logunit=logunit, istr=trim(stream_name),rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ nflds = size(sdat(ns)%pstrm(1)%fldlist_model)
+ do nf = 1,nflds
+ fldname = trim(sdat(ns)%pstrm(1)%fldlist_model(nf))
+
+ if (fldname == 'lrunoff') then
+ ! Get pointer for stream data that is time and spatially interpolated to model time and grid
+ call dshr_fldbun_getFldPtr(sdat(ns)%pstrm(1)%fldbun_model, trim(fldname), dataPtr1d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ n = 0
+ do j = jsc,jec
+ do i = isc,iec
+ n = n + 1
+ ice_ocean_boundary%lrunoff(i,j) = dataPtr1d(n)
+ enddo
+ enddo
+ endif
+
+ if (dbug > 1) then
+ call dshr_fldbun_Field_diagnose(sdat(ns)%pstrm(1)%fldbun_model, trim(fldname), 'inline_run ', rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ endif
+ enddo !nf
+ enddo !ns
+
+end subroutine mom_inline_run
+end module mom_inline_mod
diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90
index a83576028a..b0a849dd62 100644
--- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90
+++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Top-level module for the MOM6 ocean model in coupled mode.
module MOM_ocean_model_nuopc
-! This file is part of MOM6. See LICENSE.md for the license.
-
! This is the top level module for the MOM6 ocean model. It contains routines
! for initialization, termination and update of ocean model state. This
! particular version wraps all of the calls for MOM6 in the calls that had
@@ -47,6 +49,7 @@ module MOM_ocean_model_nuopc
use MOM_verticalGrid, only : verticalGrid_type
use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS
use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart
+use MOM_ice_shelf, only : adjust_ice_sheet_frazil
use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type
use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums
use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data
@@ -351,7 +354,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i
call get_param(param_file, mdl, "RHO_0", Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0)
call get_param(param_file, mdl, "G_EARTH", G_Earth, &
@@ -387,7 +390,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i
! vertical integrals, since the related 3-d sums are not negligible in cost.
call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, &
do_integrals=.true., gas_fields_ocn=gas_fields_ocn, &
- use_meltpot=use_melt_pot, use_marbl_tracers=OS%use_MARBL)
+ use_meltpot=use_melt_pot, use_iceshelves=OS%use_ice_shelf, &
+ use_marbl_tracers=OS%use_MARBL)
call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, &
OS%forcing_CSp, OS%restore_salinity, OS%restore_temp, OS%use_waves)
@@ -428,11 +432,18 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i
call extract_surface_state(OS%MOM_CSp, OS%sfc_state)
+ if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US)
endif
call extract_surface_state(OS%MOM_CSp, OS%sfc_state)
+
+ if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
! get number of processors and PE list for stocasthci physics initialization
call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, &
"If true, then stochastically perturb the thermodynamic "//&
@@ -709,6 +720,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, &
endif
endif
+ !only make ice-shelf frazil adjustments if sfc_state%frazil was updated (do_thermo=True)
+ if (do_thermo .and. OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
! Translate state into Ocean.
! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, &
! Ice_ocean_boundary%p, OS%press_to_z)
@@ -1028,6 +1043,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc)
call extract_surface_state(OS%MOM_CSp, OS%sfc_state)
+ if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp)
+
call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US)
end subroutine ocean_model_init_sfc
@@ -1164,7 +1182,7 @@ end subroutine get_ocean_grid
!> Returns eps_omesh read from param file
real function get_eps_omesh(OS)
type(ocean_state_type) :: OS
- get_eps_omesh = OS%eps_omesh; return
+ get_eps_omesh = OS%eps_omesh ; return
end function
end module MOM_ocean_model_nuopc
diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90
index 11f12a0038..55fe016c22 100644
--- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90
+++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Converts the input ESMF data (import data) to a MOM-specific data type (surface_forcing_CS).
module MOM_surface_forcing_nuopc
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : reproducing_sum, field_chksum
use MOM_constants, only : hlv, hlf
use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_write_chksums
@@ -624,7 +626,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G,
! wave to ocean coupling
if ( associated(IOB%lamult)) then
- do j=js,je; do i=is,ie
+ do j=js,je ; do i=is,ie
if (IOB%ice_fraction(i-i0,j-j0) <= 0.05 ) then
fluxes%lamult(i,j) = IOB%lamult(i-i0,j-j0)
else
@@ -961,10 +963,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS)
forces%stk_wavenumbers(:) = IOB%stk_wavenumbers * US%Z_to_m
do istk = 1,IOB%num_stk_bands
- do j=js,je; do i=is,ie
+ do j=js,je ; do i=is,ie
forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) * US%m_s_to_L_T
forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) * US%m_s_to_L_T
- enddo; enddo
+ enddo ; enddo
call pass_var(forces%ustkb(:,:,istk), G%domain )
call pass_var(forces%vstkb(:,:,istk), G%domain )
enddo
@@ -1035,7 +1037,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes)
integer :: isc, iec, jsc, jec, i, j
logical :: overrode_h
- isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec
+ isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec
overrode_h = .false.
call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h)
@@ -1084,7 +1086,7 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces)
real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1]
logical :: overrode_x, overrode_y
- isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec
+ isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec
Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z
tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0
@@ -1205,7 +1207,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt,
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, &
@@ -1373,13 +1375,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt,
if (CS%read_TIDEAMP) then
TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file)
call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s)
- do j=jsd, jed; do i=isd, ied
+ do j=jsd,jed ; do i=isd,ied
utide = CS%TKE_tidal(i,j)
CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide)
CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide
enddo ; enddo
else
- do j=jsd,jed; do i=isd,ied
+ do j=jsd,jed ; do i=isd,ied
utide = CS%utide
CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide)
CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide
@@ -1489,7 +1491,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt,
if (present(restore_salt)) then ; if (restore_salt) then
salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file)
CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain)
- call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0
+ call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed) ; CS%srestore_mask(:,:) = 1.0
if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes
flnam = trim(CS%inputdir) // 'salt_restore_mask.nc'
call MOM_read_data(flnam,'mask', CS%srestore_mask, G%domain, timelevel=1)
@@ -1499,7 +1501,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt,
if (present(restore_temp)) then ; if (restore_temp) then
temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file)
CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain)
- call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0
+ call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed) ; CS%trestore_mask(:,:) = 1.0
if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes
flnam = trim(CS%inputdir) // 'temp_restore_mask.nc'
call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1)
@@ -1565,7 +1567,7 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt)
chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks
chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks
chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks
- chks = field_chksum( iobt%seaice_melt_heat); if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks
+ chks = field_chksum( iobt%seaice_melt_heat) ; if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks
chks = field_chksum( iobt%seaice_melt) ; if (root) write(outunit,100) 'iobt%seaice_melt ', chks
chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks
chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks
diff --git a/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 b/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90
index 6d25b9a1ae..bb41084b65 100644
--- a/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90
+++ b/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
module ocn_comp_NUOPC
use MOM_cap_mod
end module ocn_comp_NUOPC
diff --git a/config_src/drivers/nuopc_cap/time_utils.F90 b/config_src/drivers/nuopc_cap/time_utils.F90
index 46f922d5bf..b7fcce8393 100644
--- a/config_src/drivers/nuopc_cap/time_utils.F90
+++ b/config_src/drivers/nuopc_cap/time_utils.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Set of time utilities for converting between FMS and ESMF time type.
module time_utils_mod
@@ -16,7 +20,7 @@ module time_utils_mod
use ESMF, only: ESMF_TimeIntervalGet, ESMF_TimeSet, ESMF_SUCCESS
use MOM_cap_methods, only: ChkErr
-implicit none; private
+implicit none ; private
!> Converts calendar from FMS to ESMF format
interface fms2esmf_cal
diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90
index f1f3daa52e..b93a3fdb72 100644
--- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90
+++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Sets forcing for the MESO configuration
module MESO_surface_forcing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data, query_averaging_enabled
use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr
use MOM_domains, only : pass_var, pass_vector, AGRID
@@ -239,7 +241,7 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS)
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, &
diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90
index 9b85fafb8d..bf6734c008 100644
--- a/config_src/drivers/solo_driver/MOM_driver.F90
+++ b/config_src/drivers/solo_driver/MOM_driver.F90
@@ -1,6 +1,8 @@
-program MOM6
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
-! This file is part of MOM6. See LICENSE.md for the license.
+program MOM6
!********+*********+*********+*********+*********+*********+*********+**
!* *
@@ -49,7 +51,7 @@ program MOM6
use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS
use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart
use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces
- use MOM_ice_shelf, only : ice_shelf_query
+ use MOM_ice_shelf, only : ice_shelf_query, adjust_ice_sheet_frazil
use MOM_ice_shelf_initialize, only : initialize_ice_SMB
use MOM_interpolate, only : time_interp_external_init
use MOM_io, only : file_exists, open_ASCII_file, close_file
@@ -58,7 +60,7 @@ program MOM6
use MOM_string_functions,only : uppercase
use MOM_surface_forcing, only : set_forcing, forcing_save_restart
use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS
- use MOM_time_manager, only : time_type, set_date, get_date, real_to_time, time_type_to_real
+ use MOM_time_manager, only : time_type, set_date, get_date, real_to_time, time_to_real
use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/)
use MOM_time_manager, only : operator(>), operator(<), operator(>=)
use MOM_time_manager, only : increment_date, set_calendar_type, month_name
@@ -252,11 +254,11 @@ program MOM6
endif
else
calendar = uppercase(calendar)
- if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN
- elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN
- elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP
- elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS
- elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR
+ if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN
+ elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN
+ elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP
+ elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS
+ elseif (calendar(1:11)=='NO_CALENDAR') then ; calendar_type = NO_CALENDAR
elseif (calendar(1:1) /= ' ') then
call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar')
else
@@ -277,6 +279,7 @@ program MOM6
! Call initialize MOM with an optional Ice Shelf CS which, if present triggers
! initialization of ice shelf parameters and arrays.
+ !$omp target enter data map(alloc: MOM_CSp)
if (segment_start_time_set) then
! In this case, the segment starts at a time fixed by ocean_solo.res
Time = segment_start_time
@@ -314,6 +317,9 @@ program MOM6
call extract_surface_state(MOM_CSp, sfc_state)
+ if (use_ice_shelf .and. allocated(sfc_state%frazil)) &
+ call adjust_ice_sheet_frazil(sfc_state, fluxes, Ice_shelf_CSp)
+
call surface_forcing_init(Time, grid, US, param_file, diag, &
surface_forcing_CSp, tracer_flow_CSp)
call callTree_waypoint("done surface_forcing_init")
@@ -345,8 +351,8 @@ program MOM6
endif
ntstep = MAX(1,ceiling(dt_forcing/dt - 0.001))
- Time_step_ocean = real_to_time(US%T_to_s*dt_forcing)
- elapsed_time_master = (abs(dt_forcing - US%s_to_T*time_type_to_real(Time_step_ocean)) > 1.0e-12*dt_forcing)
+ Time_step_ocean = real_to_time(dt_forcing, unscale=US%T_to_s)
+ elapsed_time_master = (abs(dt_forcing - time_to_real(Time_step_ocean, scale=US%s_to_T)) > 1.0e-12*dt_forcing)
if (elapsed_time_master) &
call MOM_mesg("Using real elapsed time for the master clock.", 2)
@@ -515,7 +521,7 @@ program MOM6
dtdia = dt_dyn*(n - n_last_thermo)
! Back up Time2 to the start of the thermodynamic segment.
if (n > n_last_thermo+1) &
- Time2 = Time2 - real_to_time(US%T_to_s*(dtdia - dt_dyn))
+ Time2 = Time2 - real_to_time((dtdia - dt_dyn), unscale=US%T_to_s)
call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, &
do_dynamics=.false., do_thermodynamics=.true., &
start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing)
@@ -524,7 +530,7 @@ program MOM6
endif
t_elapsed_seg = t_elapsed_seg + dt_dyn
- Time2 = Time1 + real_to_time(US%T_to_s*t_elapsed_seg)
+ Time2 = Time1 + real_to_time(t_elapsed_seg, unscale=US%T_to_s)
enddo
endif
@@ -537,12 +543,12 @@ program MOM6
! does not lose resolution of order the timetype's resolution, provided that the timestep and
! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller
! value would be required.
- time_chg = real_to_time(US%T_to_s*elapsed_time)
+ time_chg = real_to_time(elapsed_time, unscale=US%T_to_s)
segment_start_time = segment_start_time + time_chg
- elapsed_time = elapsed_time - US%s_to_T*time_type_to_real(time_chg)
+ elapsed_time = elapsed_time - time_to_real(time_chg, scale=US%s_to_T)
endif
if (elapsed_time_master) then
- Master_Time = segment_start_time + real_to_time(US%T_to_s*elapsed_time)
+ Master_Time = segment_start_time + real_to_time(elapsed_time, unscale=US%T_to_s)
else
Master_Time = Master_Time + Time_step_ocean
endif
@@ -626,9 +632,11 @@ program MOM6
if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.)
call cpu_clock_end(termClock)
- call io_infra_end ; call MOM_infra_end
-
call MOM_end(MOM_CSp)
+ !$omp target exit data map(delete: MOM_CSp)
+
+ ! This closes out the infrastructure, including clocks, I/O and message passing communicators.
+ call io_infra_end() ; call MOM_infra_end()
contains
diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90
index faa94c3bdd..84ee7a7472 100644
--- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90
+++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Functions that calculate the surface wind stresses and fluxes of buoyancy
!! or temperature/salinity and fresh water, in ocean-only (solo) mode.
!!
@@ -7,8 +11,6 @@
!! fields is controlled by surface_forcing_init, located in this file.
module MOM_surface_forcing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_constants, only : hlv, hlf
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE
@@ -34,7 +36,7 @@ module MOM_surface_forcing
use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS
use MOM_restart, only : restart_init_end, save_restart, restore_state
use MOM_time_manager, only : time_type, operator(+), operator(/), operator(*)
-use MOM_time_manager, only : set_time, get_time, get_date, time_type_to_real
+use MOM_time_manager, only : set_time, get_time, get_date, time_to_real
use MOM_tracer_flow_control, only : call_tracer_set_forcing, tracer_flow_control_CS
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : surface
@@ -281,7 +283,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US
call callTree_enter("set_forcing, MOM_surface_forcing.F90")
day_center = day_start + day_interval/2
- dt = US%s_to_T * time_type_to_real(day_interval)
+ dt = time_to_real(day_interval, scale=US%s_to_T)
if (CS%first_call_set_forcing) then
! Allocate memory for the mechanical and thermodynamic forcing fields.
@@ -1789,9 +1791,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C
! These variable names are hard-coded, per the archaic OMIP conventions.
CS%latentheat_file = CS%evaporation_file ; CS%latent_var = "evap"
- CS%LW_var = "lwdn_sfc"; CS%SW_var = "swdn_sfc"; CS%sens_var = "shflx"
- CS%evap_var = "evap"; CS%rain_var = "precip"; CS%snow_var = "snow"
- CS%lrunoff_var = "disch_w"; CS%frunoff_var = "disch_s"
+ CS%LW_var = "lwdn_sfc" ; CS%SW_var = "swdn_sfc" ; CS%sens_var = "shflx"
+ CS%evap_var = "evap" ; CS%rain_var = "precip" ; CS%snow_var = "snow"
+ CS%lrunoff_var = "disch_w" ; CS%frunoff_var = "disch_s"
else
call get_param(param_file, mdl, "LONGWAVE_FILE", CS%longwave_file, &
@@ -2044,7 +2046,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous)
call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, &
diff --git a/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90
index fb9fbe3e22..a8e11fbe34 100644
--- a/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90
+++ b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A dummy version of atmos_ocean_fluxes_mod module for
!! use when the vastly larger FMS package is not needed.
module atmos_ocean_fluxes_mod
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public :: aof_set_coupler_flux
diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90
index 55b1be1172..5caee49d57 100644
--- a/config_src/drivers/solo_driver/user_surface_forcing.F90
+++ b/config_src/drivers/solo_driver/user_surface_forcing.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Template for user to code up surface forcing.
module user_surface_forcing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data, query_averaging_enabled
use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr
use MOM_domains, only : pass_var, pass_vector, AGRID
@@ -270,7 +272,7 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS)
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, &
diff --git a/config_src/drivers/timing_tests/time_MOM_ANN.F90 b/config_src/drivers/timing_tests/time_MOM_ANN.F90
new file mode 100644
index 0000000000..dc7839a78f
--- /dev/null
+++ b/config_src/drivers/timing_tests/time_MOM_ANN.F90
@@ -0,0 +1,191 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+program time_MOM_ANN
+
+use MOM_ANN, only : ANN_CS
+use MOM_ANN, only : ANN_allocate, ANN_apply, ANN_end
+use MOM_ANN, only : ANN_apply_vector_orig, ANN_apply_vector_oi
+use MOM_ANN, only : ANN_apply_array_sio
+use MOM_ANN, only : ANN_random
+
+implicit none
+
+! Command line options
+integer :: nargs ! Number of command line arguments
+character(len=12) :: cmd_ln_arg !< Command line argument (if any)
+
+! ANN parameters
+integer :: nlayers ! Number of layers
+integer :: nin ! Number of inputs
+integer :: layer_width ! Width of hidden layers
+integer :: nout ! Number of outputs
+! Timing parameters
+integer :: nsamp ! Number of measurements
+integer :: nits ! Number of calls to time
+integer :: nxy ! Spatial dimension
+
+nlayers = 7 ; nin = 4 ; layer_width = 16 ; nout = 1 ! Deep network
+!nlayers = 4 ; nin = 4 ; layer_width = 48 ; nout = 1 ! Shallow-wide network
+!nlayers = 3 ; nin = 4 ; layer_width = 20 ; nout = 1 ! Small network
+
+nsamp = 100
+nits = 20000
+!nits = 300000 ! Needed for robust measurements on small networks
+nxy = 100 ! larger array
+!nxy = 10 ! small array
+
+! Optionally grab ANN and timing parameters from the command line
+nargs = command_argument_count()
+if (nargs==7) then
+ call get_command_argument(1, cmd_ln_arg)
+ read(cmd_ln_arg,*) nlayers
+ call get_command_argument(2, cmd_ln_arg)
+ read(cmd_ln_arg,*) nin
+ call get_command_argument(3, cmd_ln_arg)
+ read(cmd_ln_arg,*) layer_width
+ call get_command_argument(4, cmd_ln_arg)
+ read(cmd_ln_arg,*) nout
+ call get_command_argument(5, cmd_ln_arg)
+ read(cmd_ln_arg,*) nsamp
+ call get_command_argument(6, cmd_ln_arg)
+ read(cmd_ln_arg,*) nits
+ call get_command_argument(7, cmd_ln_arg)
+ read(cmd_ln_arg,*) nxy
+endif
+
+! Fastest variants on Intel Xeon W-2223 CPU @ 3.60GHz (gfortran-13.2 -O3)
+! | vector(nxy=1) | nxy = 10 | nxy = 100
+! ----------------------------------------------------------------------------
+! Small ANN | vector_oi | array_soi | array_sio
+! Shallow-wide ANN | vector_oi | array_ois | array_sio
+! Deep ANN | vector_oi | array_ois | array_sio
+
+write(*,'(a)') "{"
+
+call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, &
+ 0, "MOM_ANN:ANN_apply(vector)")
+write(*,"(',')")
+call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, &
+ 1, "MOM_ANN:ANN_apply_vector_orig(array)")
+write(*,"(',')")
+call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, &
+ 2, "MOM_ANN:ANN_apply_vector_oi(array)")
+write(*,"(',')")
+call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, &
+ 12, "MOM_ANN:ANN_apply_array_sio(array)")
+write(*,"()")
+
+write(*,'(a)') "}"
+
+contains
+
+!> Time ANN inference.
+!!
+!! Times are measured over the "nits effective calls" and appropriately scaled to the
+!! time per call per single vector of input features. For array inputs, the number of
+!! actual calls is reduced by the size of the array. The timing measurement is repeated
+!! "nsamp" times, to check the statistics of the timing measurement.
+subroutine time_ANN(nlayers, nin, width, nout, nsamp, nits, nxy, impl, label)
+ integer, intent(in) :: nlayers !< Number of layers
+ integer, intent(in) :: nin !< Number of inputs
+ integer, intent(in) :: width !< Width of hidden layers
+ integer, intent(in) :: nout !< Number of outputs
+ integer, intent(in) :: nsamp !< Number of measurements
+ integer, intent(in) :: nits !< Number of calls to time
+ integer, intent(in) :: nxy !< Spatial dimension
+ integer, intent(in) :: impl !< Implementation to time
+ character(len=*), intent(in) :: label !< Label for YAML output
+ ! Local variables
+ type(ANN_CS) :: ANN ! ANN
+ integer :: widths(nlayers) ! Width of each layer
+ real :: x_s(nin) ! Inputs (just features) [nondim]
+ real :: y_s(nin) ! Outputs (just features) [nondim]
+ real :: x_fs(nin,nxy) ! Inputs (feature, space) [nondim]
+ real :: y_fs(nin,nxy) ! Outputs (feature, space) [nondim]
+ real :: x_sf(nin,nxy) ! Inputs (space, feature) [nondim]
+ real :: y_sf(nin,nxy) ! Outputs (space, feature) [nondim]
+ integer :: iter, samp ! Loop counters
+ integer :: ij ! Horizontal loop index
+ real :: start, finish, timing ! CPU times [s]
+ real :: tmin, tmax, tmean, tstd ! Min, max, mean, and standard deviation, of CPU times [s]
+ integer :: asamp ! Actual samples of timings
+ integer :: aits ! Actual iterations
+ real :: words_per_sec ! Operations per sec estimated from parameters [# s-1]
+
+ widths(:) = width
+ widths(1) = nin
+ widths(nlayers) = nout
+
+ call ANN_random(ANN, nlayers, widths)
+ call random_number(x_fs)
+ call random_number(x_sf)
+
+
+ tmin = 1e9
+ tmax = 0.
+ tmean = 0.
+ tstd = 0.
+ asamp = nits ! Most cases below use this
+ aits = nits / nxy ! Most cases below use this
+
+ do samp = 1, nsamp
+ select case (impl)
+ case (0)
+ aits = nits
+ call cpu_time(start)
+ do iter = 1, nits ! Make many passes to reduce sampling error
+ call ANN_apply(x_s, y_s, ANN)
+ enddo
+ call cpu_time(finish)
+ case (1)
+ call cpu_time(start)
+ do iter = 1, aits ! Make many passes to reduce sampling error
+ do ij = 1, nxy
+ call ANN_apply_vector_orig(x_fs(:,ij), y_fs(:,ij), ANN)
+ enddo
+ enddo
+ call cpu_time(finish)
+ case (2)
+ call cpu_time(start)
+ do iter = 1, aits ! Make many passes to reduce sampling error
+ do ij = 1, nxy
+ call ANN_apply_vector_oi(x_fs(:,ij), y_fs(:,ij), ANN)
+ enddo
+ enddo
+ call cpu_time(finish)
+ case (12)
+ call cpu_time(start)
+ do iter = 1, aits ! Make many passes to reduce sampling error
+ call ANN_apply_array_sio(nxy, x_sf(:,:), y_sf(:,:), ANN)
+ enddo
+ call cpu_time(finish)
+ asamp = nsamp * aits ! Account for working on whole arrays
+ end select
+
+ timing = ( finish - start ) / real(nits) ! Average time per call
+
+ tmin = min( tmin, timing )
+ tmax = max( tmax, timing )
+ tmean = tmean + timing
+ tstd = tstd + timing**2
+ enddo
+
+ tmean = tmean / real(nsamp)
+ tstd = tstd / real(nsamp) ! convert to mean of squares
+ tstd = tstd - tmean**2 ! convert to variance
+ tstd = sqrt( tstd * real(nsamp) / real(nsamp-1) ) ! convert to standard deviation
+ words_per_sec = ANN%parameters / ( tmean * 1024 * 1024 )
+
+ write(*,"(2x,3a)") '"', trim(label), '": {'
+ write(*,"(4x,a,1pe11.4,',')") '"min": ', tmin
+ write(*,"(4x,a,1pe11.4,',')") '"mean":', tmean
+ write(*,"(4x,a,1pe11.4,',')") '"std": ', tstd
+ write(*,"(4x,a,i0,',')") '"n_samples": ', asamp
+ write(*,"(4x,a,1pe11.4,',')") '"max": ', tmax
+ write(*,"(4x,a,1pe11.4,'}')", advance="no") '"MBps": ', words_per_sec
+
+end subroutine time_ANN
+
+end program time_MOM_ANN
diff --git a/config_src/drivers/timing_tests/time_MOM_EOS.F90 b/config_src/drivers/timing_tests/time_MOM_EOS.F90
index 94e3282511..b8a3f5d27d 100644
--- a/config_src/drivers/timing_tests/time_MOM_EOS.F90
+++ b/config_src/drivers/timing_tests/time_MOM_EOS.F90
@@ -1,6 +1,8 @@
-program time_MOM_EOS
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
-! This file is part of MOM6. See LICENSE.md for the license.
+program time_MOM_EOS
use MOM_EOS, only : EOS_type
use MOM_EOS, only : EOS_manual_init
diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90
index e752686040..684abe2e2c 100644
--- a/config_src/drivers/timing_tests/time_MOM_remapping.F90
+++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90
@@ -1,6 +1,8 @@
-program time_MOM_remapping
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
-! This file is part of MOM6. See LICENSE.md for the license.
+program time_MOM_remapping
use MOM_remapping, only : remapping_CS
use MOM_remapping, only : initialize_remapping
diff --git a/config_src/drivers/timing_tests/time_reproducing_sum.F90 b/config_src/drivers/timing_tests/time_reproducing_sum.F90
new file mode 100644
index 0000000000..2851550d21
--- /dev/null
+++ b/config_src/drivers/timing_tests/time_reproducing_sum.F90
@@ -0,0 +1,137 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+program time_reproducing_sum
+
+use MOM_coms, only : PE_here, root_PE, num_PEs, reproducing_sum
+use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
+use MOM_domains, only : MOM_domain_type, create_MOM_domain, MOM_infra_init, MOM_infra_end
+use MOM_domains, only : MOM_define_layout
+use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, MOM_set_verbosity
+use MOM_hor_index, only : hor_index_type, hor_index_init
+
+ implicit none
+
+ type(MOM_domain_type), pointer :: Domain => NULL() ! Ocean model domain
+ type(hor_index_type) :: HI ! A hor_index_type for array extents
+ real, allocatable, dimension(:) :: depth_tot_R, depth_tot_std, depth_tot_fastR ! Various sums of depths [m]
+ real, allocatable :: array(:,:) ! An array with values to sum over [m]
+ character(len=200) :: mesg ! String for messages
+ integer :: num_sums ! Number of times to repeat the sum call
+ integer :: n ! Loop counter
+ integer :: io_unit ! i/o unit for creating input.nml (sigh)
+ integer :: reproClock, fastreproClock, stdClock, initClock ! Clocks for each sum
+ integer :: n_global(2) ! Global i-, j- dimensions of domain (h-points)
+ integer :: layout(2) ! PE count in i-, j- directions
+ integer :: PEs_used ! Number of PEs available to executable
+
+ ! FMS requires the file "input.nml" to exist ...
+ open(newunit=io_unit, file="input.nml", status="replace", action="write")
+ close(io_unit) ! ... but an empty input.nml is sufficient
+
+ call MOM_infra_init()
+
+ ! These clocks are on the global pelist.
+ initClock = cpu_clock_id( 'Initialization' )
+ stdClock = cpu_clock_id( 'Standard Sums' )
+ reproClock = cpu_clock_id( 'Reproducing Sums' )
+ fastreproClock = cpu_clock_id( 'Fast Reproducing Sums' )
+ num_sums = 100
+
+ call cpu_clock_begin(initClock)
+ ! Optionally use command-line to change size of the problem
+ ! Usage: ./executable [tile-size] [number-of-calls]
+ n = command_argument_count()
+ if (n==2) then
+ call get_command_argument(1, mesg)
+ read(mesg,*) n_global(1)
+ n_global(2) = n_global(1)
+ call get_command_argument(2, mesg)
+ read(mesg,*) num_sums
+ elseif (n==1) then
+ call get_command_argument(1, mesg)
+ read(mesg,*) n_global(1)
+ n_global(2) = n_global(1)
+ else
+ n_global = (/500, 300/) ! Fallback value if no argument provided
+ endif
+
+ call MOM_mesg('======== Unit test being driven by MOM_sum_driver ========', 2)
+ call MOM_set_verbosity(2)
+
+ ! Setup distributed domain
+ PEs_used = num_PEs()
+ call MOM_define_layout(n_global, PEs_used, layout)
+ call create_MOM_domain(Domain, n_global, (/2,2/), (/.false.,.false./), .false., layout)
+ call hor_index_init(Domain, HI)
+
+ allocate( array(HI%isd:HI%ied,HI%jsd:HI%jed), source=0. )
+ allocate( depth_tot_std(num_sums), source=0. )
+ allocate( depth_tot_R(num_sums), source=0. )
+ allocate( depth_tot_fastR(num_sums), source=0. )
+
+ ! Set up an array of values to sum
+ call generate_array_of_values(array, HI, n_global)
+
+ call cpu_clock_end(initClock) !end initialization
+ call MOM_mesg("Done with initialization.", 5)
+
+ call MOM_mesg('==== Standard Non-reproducing Sum ===', 2)
+ do n=1,num_sums
+ call cpu_clock_begin(stdClock)
+ depth_tot_std(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, reproducing=.false.)
+ call cpu_clock_end(stdClock)
+ enddo
+
+ call MOM_mesg('==== Reproducing Fixed Point Sum ===', 2)
+ do n=1,num_sums
+ call cpu_clock_begin(reproClock)
+ depth_tot_R(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec)
+ call cpu_clock_end(reproClock)
+ enddo
+
+ call MOM_mesg('==== No Error Handling Reproducing Fixed Point Sum ===', 2)
+ do n=1,num_sums
+ call cpu_clock_begin(fastreproClock)
+ depth_tot_fastR(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, overflow_check=.false.)
+ call cpu_clock_end(fastreproClock)
+ enddo
+
+ ! Cleanup the "input.nml" file created to boot FMS
+ if (PE_here() == root_PE()) then ! Can only delete the file once (i.e. on root PE)
+ open(newunit=io_unit, file="input.nml", status="replace", action="write")
+ close(io_unit, status="delete") ! we could leave this in place but that would be untidy
+ endif
+
+ call MOM_infra_end
+
+contains
+
+!> Generate some "spatial" data, reminiscent of benchmark topography
+subroutine generate_array_of_values(D, HI, n_global)
+ type(hor_index_type), intent(in) :: HI !< The horizontal index type
+ real, intent(out) :: D(HI%isd:HI%ied,HI%jsd:HI%jed) !< Ocean bottom depth in [m]
+ integer, intent(in) :: n_global(2) !< Global i-, j- dimensions of domain (h-points)
+ ! Local variables
+ real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim]
+ real :: x ! A fractional position in the x-direction [nondim]
+ real :: y ! A fractional position in the y-direction [nondim]
+ integer :: i, j ! Loop indices
+
+ PI = 4.0*atan(1.0)
+
+ ! Calculate the depth of the bottom.
+ do concurrent( j=HI%jsc:HI%jec, i=HI%isc:HI%iec )
+ x = real( i + HI%idg_offset ) / real( n_global(1) )
+ y = real( j + HI%idg_offset ) / real( n_global(2) )
+ D(i,j) = -3000.0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) &
+ + 0.75*exp(-6.0*y) &
+ + 0.05*cos(10.0*PI*x) - 0.7 )
+ if (D(i,j) > 3000.0) D(i,j) = 3000.0
+ if (D(i,j) < 1.) D(i,j) = 0.
+ enddo
+
+end subroutine generate_array_of_values
+
+end program time_reproducing_sum
diff --git a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 b/config_src/drivers/unit_drivers/MOM_sum_driver.F90
deleted file mode 100644
index 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_MOM_ANN.F90 b/config_src/drivers/unit_tests/test_MOM_ANN.F90
new file mode 100644
index 0000000000..345b6ee6e9
--- /dev/null
+++ b/config_src/drivers/unit_tests/test_MOM_ANN.F90
@@ -0,0 +1,14 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+program test_MOM_ANN
+
+use MOM_ANN, only : ANN_unit_tests
+use MOM_error_handler, only : set_skip_mpi
+
+call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used
+
+if ( ANN_unit_tests(.true.) ) stop 1
+
+end program test_MOM_ANN
diff --git a/config_src/drivers/unit_tests/test_MOM_EOS.F90 b/config_src/drivers/unit_tests/test_MOM_EOS.F90
index 070bec04f6..90fe5b95e0 100644
--- a/config_src/drivers/unit_tests/test_MOM_EOS.F90
+++ b/config_src/drivers/unit_tests/test_MOM_EOS.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
program test_MOM_EOS
use MOM_EOS, only : EOS_unit_tests
diff --git a/config_src/drivers/unit_tests/test_MOM_array_transform.F90 b/config_src/drivers/unit_tests/test_MOM_array_transform.F90
new file mode 100644
index 0000000000..e0926f8f3a
--- /dev/null
+++ b/config_src/drivers/unit_tests/test_MOM_array_transform.F90
@@ -0,0 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+program test_MOM_array_transform
+
+use MOM_array_transform, only : symmetric_sum_unit_tests
+
+if ( symmetric_sum_unit_tests(.true.) ) stop 1
+
+end program test_MOM_array_transform
diff --git a/config_src/drivers/unit_tests/test_MOM_file_parser.F90 b/config_src/drivers/unit_tests/test_MOM_file_parser.F90
index 55f57d5fc2..1b3e52259c 100644
--- a/config_src/drivers/unit_tests/test_MOM_file_parser.F90
+++ b/config_src/drivers/unit_tests/test_MOM_file_parser.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
program test_MOM_file_parser
use MPI
diff --git a/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90
index 3e5eec64fc..60c6e72de4 100644
--- a/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90
+++ b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
program test_MOM_mixedlayer_restrat
use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests
diff --git a/config_src/drivers/unit_tests/test_MOM_remapping.F90 b/config_src/drivers/unit_tests/test_MOM_remapping.F90
index 4c6fe4f750..4869e57965 100644
--- a/config_src/drivers/unit_tests/test_MOM_remapping.F90
+++ b/config_src/drivers/unit_tests/test_MOM_remapping.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
program test_MOM_remapping
use MOM_remapping, only : remapping_unit_tests
diff --git a/config_src/drivers/unit_tests/test_MOM_string_functions.F90 b/config_src/drivers/unit_tests/test_MOM_string_functions.F90
index 2376afbbae..47da9d0411 100644
--- a/config_src/drivers/unit_tests/test_MOM_string_functions.F90
+++ b/config_src/drivers/unit_tests/test_MOM_string_functions.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
program test_MOM_string_functions
use MOM_string_functions, only : string_functions_unit_tests
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..532d7ca960 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,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
program test_numerical_testing_type
-use numerical_testing_type, only : 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..2a9af42538
--- /dev/null
+++ b/config_src/drivers/unit_tests/test_reproducing_sum.F90
@@ -0,0 +1,211 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+program test_reproducing_sum
+
+use MOM_coms, only : PE_here, root_PE, num_PEs, reproducing_sum
+use MOM_coms, only : sum_across_PEs, max_across_PEs, max_count_prec
+use MOM_domains, only : MOM_domain_type, create_MOM_domain, MOM_infra_init, MOM_infra_end
+use MOM_domains, only : MOM_define_layout
+use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, MOM_set_verbosity
+use MOM_hor_index, only : hor_index_type, hor_index_init
+
+ implicit none
+
+ type(MOM_domain_type), pointer :: Domain => NULL() ! Ocean model domain
+ type(hor_index_type) :: HI ! A hor_index_type for array extents
+ real, allocatable :: array(:,:) ! An array with values to sum over [A]
+ real :: tot_R, tot_std, tot_fastR ! Sums via different methods [A]
+ real :: error_bound, likely_error ! Errors via different methods [A]
+ character(len=200) :: mesg ! String for messages
+ integer :: n_repeat ! Number of times to repeat the sum call
+ integer :: n ! Loop counter
+ integer :: io_unit ! i/o unit for creating input.nml (sigh)
+ integer :: n_global(2) ! Global i-, j- dimensions of domain (h-points)
+ integer :: layout(2) ! PE count in i-, j- directions
+ integer :: PEs_used ! Number of PEs available to executable
+ logical :: tests_failed ! True if a fail is encountered
+ integer :: i, j, ig, jg ! Spatial indices
+
+ ! FMS requires the file "input.nml" to exist ...
+ open(newunit=io_unit, file="input.nml", status="replace", action="write")
+ close(io_unit) ! ... but an empty input.nml is sufficient
+
+ call MOM_infra_init()
+
+ n_repeat = 100
+
+ ! Optionally use command-line to change size of the problem
+ ! Usage: ./executable [tile-size] [number-of-calls]
+ n = command_argument_count()
+ if (n==2) then
+ call get_command_argument(1, mesg)
+ read(mesg,*) n_global(1)
+ n_global(2) = n_global(1)
+ call get_command_argument(2, mesg)
+ read(mesg,*) n_repeat
+ elseif (n==1) then
+ call get_command_argument(1, mesg)
+ read(mesg,*) n_global(1)
+ n_global(2) = n_global(1)
+ else
+ n_global = (/200, 300/) ! Fallback value if no argument provided
+ endif
+
+ tests_failed = .false.
+ call MOM_set_verbosity(2)
+
+ ! Setup distributed domain
+ PEs_used = num_PEs()
+ call MOM_define_layout(n_global, PEs_used, layout)
+ call create_MOM_domain(Domain, n_global, (/2,2/), (/.false.,.false./), .false., layout)
+ call hor_index_init(Domain, HI)
+
+ allocate( array(HI%isd:HI%ied,HI%jsd:HI%jed), source=0. )
+
+ ! Set up an array of values to sum
+ call generate_array_of_values(array, HI, n_global)
+
+ ! This estimates the maximum possible accumulated round off error, and likely error
+ ! from a random walk of round off errors
+ error_bound = 0.
+ tot_std = 0.
+ do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec
+ ! Actual round off error for adding tot_std + array(i,j)
+ error_bound = error_bound + max( abs(tot_std), abs(array(i,j)) ) * epsilon(error_bound)
+ tot_std = tot_std + array(i,j)
+ enddo ; enddo
+ call sum_across_PEs( error_bound )
+ call sum_across_PEs( tot_std )
+ N = n_global(1) * n_global(2)
+ likely_error = tot_std * epsilon(tot_std) * sqrt( real( N ) )
+ if (likely_error > error_bound) call MOM_error(FATAL, 'Something went wrong in error estimate!')
+
+ tot_std = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, reproducing=.false.)
+ tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec)
+ tot_fastR = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, overflow_check=.false.)
+
+ ! tot_std and tot_R should differ only by round off, if at all
+ if (abs(tot_std - tot_R) > likely_error) then
+ write(mesg,'("Mismatch between standard and reproducing sum.",4ES13.5)') &
+ tot_std, tot_R, tot_std - tot_R, ( tot_std - tot_R ) / tot_R
+ call MOM_mesg(mesg)
+ tests_failed = tests_failed .or. .true.
+ endif
+ ! tot_fastR and tot_R should be identical unless too many values are summed
+ if (abs(tot_fastR - tot_R) > 0.) then
+ if (n < max_count_prec) then
+ write(mesg,'("Mismatch between reproducing and fast reproducing sums.",4ES13.5)') &
+ tot_fastR, tot_R, tot_fastR - tot_R, ( tot_fastR - tot_R ) / tot_R
+ tests_failed = tests_failed .or. .true.
+ else
+ write(mesg,'("Too many values were summed for the fast reproducing sum to work.")')
+ endif
+ call MOM_mesg(mesg)
+ endif
+
+ ! Now check the reproducing sums give the exact answer for known sets of values
+
+ ! Fill array with values 1, 2, ..., Ni*Nj whose sum is N ( N + 1 ) / 2 where N + Ni*Nj
+ do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec
+ jg = j + HI%jdg_offset - 1 ! 0 .. Nj-1
+ ig = i + HI%idg_offset - 1 ! 0 .. Ni-1
+ array(i,j) = 1 + ig + n_global(1) * jg
+ enddo ; enddo
+ tot_std = 0.5 * real(N) * real(N + 1) ! tot_std will contain analytic solution
+ tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec)
+ if (abs(tot_R - tot_std) > 0.) then
+ write(mesg,'("Sum_k=1^N k != N(N+1)/2",2ES13.5)') tot_R, tot_std
+ call MOM_mesg(mesg)
+ tests_failed = tests_failed .or. .true.
+ endif
+
+ ! Change the order of values in the arrya to check the sum is truly order invariant
+ do i = 1, n_repeat
+ call randomly_swap_elements(HI, array)
+ tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec)
+ if (abs(tot_R - tot_std) > 0.) then
+ write(mesg,'("Reordered list changed sum",2ES13.5)') tot_R, tot_std
+ call MOM_mesg(mesg)
+ tests_failed = tests_failed .or. .true.
+ endif
+ enddo
+
+ call random_number( array ) ! This will also fill the halos but they will be ignored
+ tot_std = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) ! Use this as the true value
+ ! Change the order of values in the arrya to check the sum is truly order invariant
+ do i = 1, n_repeat
+ call randomly_swap_elements(HI, array)
+ tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec)
+ if (abs(tot_R - tot_std) > 0.) then
+ write(mesg,'("Reordered list of random numbers changed sum",2ES13.5)') tot_R, tot_std
+ call MOM_mesg(mesg)
+ tests_failed = tests_failed .or. .true.
+ endif
+ enddo
+
+ ! Cleanup the "input.nml" file created to boot FMS
+ if (PE_here() == root_PE()) then ! Can only delete the file once (i.e. on root PE)
+ open(newunit=io_unit, file="input.nml", status="replace", action="write")
+ close(io_unit, status="delete") ! we could leave this in place but that would be untidy
+ endif
+
+ call MOM_infra_end
+ if (tests_failed) stop 1
+
+contains
+
+!> Randomly swap elements within the computational domain of an array
+subroutine randomly_swap_elements(HI, array)
+ type(hor_index_type), intent(in) :: HI !< The horizontal index type
+ real, intent(inout) :: array(HI%isd:HI%ied,HI%jsd:HI%jed) !< Array of values to play with [A]
+ ! Local variables
+ integer :: n_swaps !< Number of swaps to perform
+ integer :: i0, j0, i1, j1, iter ! Indices and counter
+ real :: r(4) ! Random numbers [nondim]
+ real :: v ! Value being swapped
+
+ n_swaps = ( HI%iec - HI%isc ) * ( HI%jec - HI%jsc )
+ do iter = 1, n_swaps
+ do
+ call random_number( r ) ! Random numbers 0..1
+ i0 = HI%isc + int( r(1) * real( HI%iec - HI%isc ) )
+ j0 = HI%jsc + int( r(2) * real( HI%jec - HI%jsc ) )
+ i1 = HI%isc + int( r(3) * real( HI%iec - HI%isc ) )
+ j1 = HI%jsc + int( r(4) * real( HI%jec - HI%jsc ) )
+ if (i0 /= i1 .and. j0 /= j1) exit ! Repeat dice roll if points are the same
+ enddo
+ v = array(i0,j0)
+ array(i0,j0) = array(i1,j1)
+ array(i1,j1) = v
+ enddo
+end subroutine randomly_swap_elements
+
+!> Generate some "spatial" data, reminiscent of benchmark topography
+subroutine generate_array_of_values(D, HI, n_global)
+ type(hor_index_type), intent(in) :: HI !< The horizontal index type
+ real, intent(out) :: D(HI%isd:HI%ied,HI%jsd:HI%jed) !< Ocean bottom depth in [m]
+ integer, intent(in) :: n_global(2) !< Global i-, j- dimensions of domain (h-points)
+ ! Local variables
+ real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim]
+ real :: x ! A fractional position in the x-direction [nondim]
+ real :: y ! A fractional position in the y-direction [nondim]
+ integer :: i, j ! Loop indices
+
+ PI = 4.0*atan(1.0)
+
+ ! Calculate the depth of the bottom.
+ do concurrent( j=HI%jsc:HI%jec, i=HI%isc:HI%iec )
+ x = real( i + HI%idg_offset ) / real( n_global(1) )
+ y = real( j + HI%idg_offset ) / real( n_global(2) )
+ D(i,j) = -3000.0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) &
+ + 0.75*exp(-6.0*y) &
+ + 0.05*cos(10.0*PI*x) - 0.7 )
+ if (D(i,j) > 3000.0) D(i,j) = 3000.0
+ if (D(i,j) < 1.) D(i,j) = 0.
+ enddo
+
+end subroutine generate_array_of_values
+
+end program test_reproducing_sum
diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90
deleted file mode 100644
index 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..4111bf020f 100644
--- a/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90
+++ b/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Drives the generic version of tracers TOPAZ and CFC and other GFDL BGC components
module MOM_generic_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
#include
! The following macro is usually defined in but since MOM6 should not directly
@@ -13,918 +15,295 @@ 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, real_to_EFP
+use MOM_diag_mediator, only : diag_ctrl
+use MOM_error_handler, only : MOM_error, FATAL
+use MOM_file_parser, only : param_file_type
+use MOM_forcing_type, only : forcing, optics_type
+use MOM_grid, only : ocean_grid_type
+use MOM_hor_index, only : hor_index_type
+use MOM_open_boundary, only : ocean_OBC_type
+use MOM_restart, only : MOM_restart_CS
+use MOM_sponge, only : sponge_CS
+use MOM_time_manager, only : time_type
+use MOM_tracer_registry, only : tracer_registry_type
+use MOM_unit_scaling, only : unit_scale_type
+use MOM_variables, only : surface, thermo_var_ptrs
+use MOM_verticalGrid, only : verticalGrid_type
+
+implicit none ; private
+
+!> A state hidden in module data that is very much not allowed in MOM6
+! ### This needs to be fixed
+logical :: g_registered = .false.
+
+public register_MOM_generic_tracer, initialize_MOM_generic_tracer
+public MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state
+public end_MOM_generic_tracer, MOM_generic_tracer_get
+public MOM_generic_tracer_stock
+public MOM_generic_flux_init
+public MOM_generic_tracer_min_max
+public MOM_generic_tracer_fluxes_accumulate
+public register_MOM_generic_tracer_segments
+
+!> Control structure for generic tracers
+type, public :: MOM_generic_tracer_CS ; private
+ character(len = 200) :: IC_file !< The file in which the generic tracer initial values can
+ !! be found, or an empty string for internal initialization.
+ logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false.
+ real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers, in
+ !! concentration units [conc]
+ real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out, in
+ !! concentration units [conc]
+ logical :: tracers_may_reinit !< If true, tracers may go through the
+ !! initialization code if they are not found in the restart files.
+
+ type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to
+ !! regulate the timing of diagnostic output.
+ type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure
+ type(ocean_OBC_type), pointer :: OBC => NULL() ! Pointer to the first element of the linked list of generic tracers.
+ !type(g_tracer_type), pointer :: g_tracer_list => NULL()
+
+end type MOM_generic_tracer_CS
contains
- !> Initializes the generic tracer packages and adds their tracers to the list
- !! Adds the tracers in the list of generic tracers to the set of MOM tracers (i.e., MOM-register them)
- !! Register these tracers for restart
- function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS)
- 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.
+
+ integer :: m
+ MOM_generic_tracer_stock = 0
+
+ ! These should never be used, but they are set to avoid compile-time warnings
+ do m=1,size(names) ; names(m) = "" ; enddo
+ do m=1,size(units) ; units(m) = "" ; enddo
+ do m=1,size(stocks) ; stocks(m) = real_to_EFP(0.0) ; enddo
+
+end function MOM_generic_tracer_stock
+
+!> This subroutine finds the global min and max of either of all available
+!! tracer concentrations, or of a tracer that is being requested specifically,
+!! returning the number of tracers it has evaluated.
+!! It also optionally returns the locations of the extrema.
+function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, G, CS, names, units, &
+ xgmin, ygmin, zgmin, xgmax, ygmax, zgmax)
+ integer, intent(in) :: ind_start !< The index of the tracer to start with
+ logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and
+ !! max are found for each tracer
+ real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer [conc]
+ real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer [conc]
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
+ type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module.
+ character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated.
+ character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated.
+ real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the
+ !! units of G%geoLonT, often [degrees_E] or [km] or [m]
+ real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the
+ !! units of G%geoLatT, often [degrees_N] or [km] or [m]
+ real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer]
+ real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the
+ !! units of G%geoLonT, often [degrees_E] or [km] or [m]
+ real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the
+ !! units of G%geoLatT, often [degrees_N] or [km] or [m]
+ real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer]
+ integer :: MOM_generic_tracer_min_max !< Return value, the
+ !! number of tracers done here.
+
+ integer :: m
+
+ MOM_generic_tracer_min_max = 0
+
+ ! These should never be used, but they are set to avoid compile-time warnings. Note that the minimum values
+ ! are delibarately set to be larger than the maximum values.
+ got_minmax(:) = .false.
+ gmax(:) = -huge(gmax)
+ gmin(:) = huge(gmin)
+ do m=1,size(names) ; names(m) = "" ; enddo
+ do m=1,size(units) ; units(m) = "" ; enddo
+ if (present(xgmin)) xgmin(:) = 0.0
+ if (present(ygmin)) ygmin(:) = 0.0
+ if (present(zgmin)) zgmin(:) = 0.0
+ if (present(xgmax)) xgmax(:) = 0.0
+ if (present(ygmax)) ygmax(:) = 0.0
+ if (present(zgmax)) zgmax(:) = 0.0
+
+end function MOM_generic_tracer_min_max
+
+!> This subroutine calculates the surface state and sets coupler values for
+!! those generic tracers that have flux exchange with atmosphere.
+!!
+!! This subroutine sets up the fields that the coupler needs to calculate the
+!! CFC fluxes between the ocean and atmosphere.
+subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS)
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
+ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
+ type(surface), intent(inout) :: sfc_state !< A structure containing fields that
+ !! describe the surface state of the ocean.
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]
+ type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module.
+
+end subroutine MOM_generic_tracer_surface_state
!ALL PE subroutine on Ocean! Due to otpm design the fluxes should be initialized like this on ALL PE's!
- subroutine MOM_generic_flux_init(verbosity)
- integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity.
-
- 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]
+subroutine MOM_generic_flux_init(verbosity)
+ integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity.
- call generic_tracer_coupler_accumulate(flux_tmp%tr_fluxes, weight)
+end subroutine MOM_generic_flux_init
- end subroutine MOM_generic_tracer_fluxes_accumulate
+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]
- !> 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_fluxes_accumulate
- ! 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'
+!> 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.
- call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr)
- array(:,:,:) = array_ptr(:,:,:)
+ ! 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_get
+ array(:,:,:) = huge(array)
- !> 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/external/MARBL/marbl_constants_mod.F90 b/config_src/external/MARBL/marbl_constants_mod.F90
index 7a1d44ba97..1181a50e31 100644
--- a/config_src/external/MARBL/marbl_constants_mod.F90
+++ b/config_src/external/MARBL/marbl_constants_mod.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A non-functioning template of the MARBL constants module
module marbl_constants_mod
diff --git a/config_src/external/MARBL/marbl_interface.F90 b/config_src/external/MARBL/marbl_interface.F90
index 40ddf17c73..4b57472798 100644
--- a/config_src/external/MARBL/marbl_interface.F90
+++ b/config_src/external/MARBL/marbl_interface.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A non-functioning template of the MARBL interface
module marbl_interface
diff --git a/config_src/external/MARBL/marbl_interface_public_types.F90 b/config_src/external/MARBL/marbl_interface_public_types.F90
index 3955faf73a..98f83b529b 100644
--- a/config_src/external/MARBL/marbl_interface_public_types.F90
+++ b/config_src/external/MARBL/marbl_interface_public_types.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A non-functioning template of the public structures provided through MARBL interface
module marbl_interface_public_types
@@ -87,4 +91,4 @@ module marbl_interface_public_types
type(marbl_single_output_type), dimension(:), pointer :: outputs_for_GCM => NULL() !< dummy outputs_for_GCM
end type marbl_output_for_GCM_type
-end module marbl_interface_public_types
\ No newline at end of file
+end module marbl_interface_public_types
diff --git a/config_src/external/MARBL/marbl_logging.F90 b/config_src/external/MARBL/marbl_logging.F90
index 906d881f0e..8310d3746b 100644
--- a/config_src/external/MARBL/marbl_logging.F90
+++ b/config_src/external/MARBL/marbl_logging.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A non-functioning template of the MARBL logging module
module marbl_logging
@@ -35,4 +39,4 @@ subroutine erase(self)
class(marbl_log_type), intent(inout) :: self
end subroutine erase
-end module marbl_logging
\ No newline at end of file
+end module marbl_logging
diff --git a/config_src/external/ODA_hooks/kdtree.f90 b/config_src/external/ODA_hooks/kdtree.f90
index a27716dde1..75558c94fa 100644
--- a/config_src/external/ODA_hooks/kdtree.f90
+++ b/config_src/external/ODA_hooks/kdtree.f90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A null version of K-d tree from geoKdTree
module kdtree
implicit none
diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90
index 769e44b2aa..a2fba2b7b0 100644
--- a/config_src/external/ODA_hooks/ocean_da_core.F90
+++ b/config_src/external/ODA_hooks/ocean_da_core.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A set of dummy interfaces for compiling the MOM6 DA driver code.
module ocean_da_core_mod
! MOM modules
diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90
index a99f1ae669..82e1a28e6e 100644
--- a/config_src/external/ODA_hooks/ocean_da_types.F90
+++ b/config_src/external/ODA_hooks/ocean_da_types.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Dummy aata structures and methods for ocean data assimilation.
module ocean_da_types_mod
diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90
index 51b5d2a1d7..6766a391ca 100644
--- a/config_src/external/ODA_hooks/write_ocean_obs.F90
+++ b/config_src/external/ODA_hooks/write_ocean_obs.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Dummy interfaces for writing ODA data
module write_ocean_obs_mod
diff --git a/config_src/external/database_comms/MOM_database_comms.F90 b/config_src/external/database_comms/MOM_database_comms.F90
index 4c3eb38b5c..4832b95e52 100644
--- a/config_src/external/database_comms/MOM_database_comms.F90
+++ b/config_src/external/database_comms/MOM_database_comms.F90
@@ -1,11 +1,14 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Contains routines necessary to initialize communication with a database
module MOM_database_comms
-! This file is part of MOM6. See LICENSE.md for the license.
use MOM_file_parser, only : param_file_type
use MOM_error_handler, only : MOM_error, WARNING
use database_client_interface, only : dbclient_type
-implicit none; private
+implicit none ; private
!> Control structure to store Database communication related parameters and objects
type, public :: dbcomms_CS_type
diff --git a/config_src/external/database_comms/database_client_interface.F90 b/config_src/external/database_comms/database_client_interface.F90
index 8b05b83daf..a20db2b2cb 100644
--- a/config_src/external/database_comms/database_client_interface.F90
+++ b/config_src/external/database_comms/database_client_interface.F90
@@ -1,9 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
module database_client_interface
-! This file is part of MOM6. See LICENSE.md for the license.
use iso_fortran_env, only : int8, int16, int32, int64, real32, real64
- implicit none; private
+ implicit none ; private
!> Dummy type for dataset
type, public :: dataset_type
diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90
index 1c41170582..543efeaf1d 100644
--- a/config_src/external/drifters/MOM_particles.F90
+++ b/config_src/external/drifters/MOM_particles.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A set of dummy interfaces for compiling the MOM6 drifters code
module MOM_particles_mod
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_grid, only : ocean_grid_type
use MOM_time_manager, only : time_type, get_date, operator(-)
use MOM_variables, only : thermo_var_ptrs
diff --git a/config_src/external/drifters/MOM_particles_types.F90 b/config_src/external/drifters/MOM_particles_types.F90
index 30fecad7a2..ffa9158e69 100644
--- a/config_src/external/drifters/MOM_particles_types.F90
+++ b/config_src/external/drifters/MOM_particles_types.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Dummy data structures and methods for drifters package
module particles_types_mod
-! This file is part of MOM6. See LICENSE.md for the license.
-
use, intrinsic :: iso_fortran_env, only : int64
use MOM_grid, only : ocean_grid_type
use MOM_domains, only: domain2D
diff --git a/config_src/external/stochastic_physics/get_stochy_pattern.F90 b/config_src/external/stochastic_physics/get_stochy_pattern.F90
index c3e23cd1a4..4d4c5c9bec 100644
--- a/config_src/external/stochastic_physics/get_stochy_pattern.F90
+++ b/config_src/external/stochastic_physics/get_stochy_pattern.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
! The are stubs for ocean stochastic physics
! the fully functional code is available at
! http://github.com/noaa-psd/stochastic_physics
module get_stochy_pattern_mod
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public :: write_stoch_restart_ocn
diff --git a/config_src/external/stochastic_physics/stochastic_physics.F90 b/config_src/external/stochastic_physics/stochastic_physics.F90
index 97bcff70d4..40f9cf9fa8 100644
--- a/config_src/external/stochastic_physics/stochastic_physics.F90
+++ b/config_src/external/stochastic_physics/stochastic_physics.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
! The are stubs for ocean stochastic physics
! the fully functional code is available at
! http://github.com/noaa-psd/stochastic_physics
module stochastic_physics
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, WARNING
implicit none ; private
diff --git a/config_src/infra/FMS1/MOM_coms_infra.F90 b/config_src/infra/FMS1/MOM_coms_infra.F90
index 13f8006184..a9395440bd 100644
--- a/config_src/infra/FMS1/MOM_coms_infra.F90
+++ b/config_src/infra/FMS1/MOM_coms_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Thin interfaces to non-domain-oriented mpp communication subroutines
module MOM_coms_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use iso_fortran_env, only : int32, int64
use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe
diff --git a/config_src/infra/FMS1/MOM_constants.F90 b/config_src/infra/FMS1/MOM_constants.F90
index a632267a7f..ad44ba4f85 100644
--- a/config_src/infra/FMS1/MOM_constants.F90
+++ b/config_src/infra/FMS1/MOM_constants.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides a few physical constants
module MOM_constants
-! This file is part of MOM6. See LICENSE.md for the license.
-
use constants_mod, only : FMS_HLV => HLV
use constants_mod, only : FMS_HLF => HLF
diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90
index 637f2b5ebf..e196b7e147 100644
--- a/config_src/infra/FMS1/MOM_couplertype_infra.F90
+++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module wraps the FMS coupler types module
module MOM_couplertype_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor
use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data
use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data
diff --git a/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS1/MOM_cpu_clock_infra.F90
index 0c42c577b4..aeca65b863 100644
--- a/config_src/infra/FMS1/MOM_cpu_clock_infra.F90
+++ b/config_src/infra/FMS1/MOM_cpu_clock_infra.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Wraps the MPP cpu clock functions
!!
!! The functions and constants should be accessed via mom_cpu_clock
module MOM_cpu_clock_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module
use fms_mod, only : clock_flag_default
use mpp_mod, only : mpp_clock_begin
diff --git a/config_src/infra/FMS1/MOM_data_override_infra.F90 b/config_src/infra/FMS1/MOM_data_override_infra.F90
index 1484f0c128..57311710c8 100644
--- a/config_src/infra/FMS1/MOM_data_override_infra.F90
+++ b/config_src/infra/FMS1/MOM_data_override_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> These interfaces allow for ocean or sea-ice variables to be replaced with data.
module MOM_data_override_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domain_infra, only : MOM_domain_type, domain2d
use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind
use MOM_time_manager, only : time_type
diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90
index d9be18d33f..2031487389 100644
--- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90
+++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A wrapper for the FMS diag_manager routines. This module should be the
!! only MOM6 module which imports the FMS shared infrastructure for
!! diagnostics. Pass through interfaces are being documented
@@ -6,8 +10,6 @@
!! those APIs would be applied here).
module MOM_diag_manager_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use, intrinsic :: iso_fortran_env, only : real64
use diag_axis_mod, only : fms_axis_init=>diag_axis_init
use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name
diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90
index 13c05de9c4..5a8c4d7894 100644
--- a/config_src/infra/FMS1/MOM_domain_infra.F90
+++ b/config_src/infra/FMS1/MOM_domain_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Describes the decomposed MOM domain and has routines for communications across PEs
module MOM_domain_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms_infra, only : PE_here, root_PE, num_PEs
use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end
use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL
@@ -1213,7 +1215,7 @@ subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete)
! Local variables
logical :: do_complete
- do_complete=.true.;if (PRESENT(complete)) do_complete = complete
+ do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
@@ -1232,7 +1234,7 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete)
! Local variables
logical :: do_complete
- do_complete=.true.;if (PRESENT(complete)) do_complete = complete
+ do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
@@ -1251,7 +1253,7 @@ subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete)
! Local variables
logical :: do_complete
- do_complete=.true.;if (PRESENT(complete)) do_complete = complete
+ do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
@@ -1389,8 +1391,10 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l
"TRIPOLAR_N and REENTRANT_Y may not be used together.")
endif
- MOM_dom%nonblocking_updates = nonblocking
- MOM_dom%thin_halo_updates = thin_halos
+ MOM_dom%nonblocking_updates = .false.
+ if (present(nonblocking)) MOM_dom%nonblocking_updates = nonblocking
+ MOM_dom%thin_halo_updates = .false.
+ if (present(thin_halos)) MOM_dom%thin_halo_updates = thin_halos
MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric
MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2)
MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2)
diff --git a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90
index 3ab9d591da..436cf28654 100644
--- a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90
+++ b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A simple (very thin) wrapper for managing ensemble member layout information
module MOM_ensemble_manager_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init
use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup
use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id
diff --git a/config_src/infra/FMS1/MOM_error_infra.F90 b/config_src/infra/FMS1/MOM_error_infra.F90
index e5a8b8dc68..7db14bc127 100644
--- a/config_src/infra/FMS1/MOM_error_infra.F90
+++ b/config_src/infra/FMS1/MOM_error_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Routines for error handling and I/O management
module MOM_error_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout
use mpp_mod, only : NOTE, WARNING, FATAL
diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90
index 4fa3f7374b..3ce0834534 100644
--- a/config_src/infra/FMS1/MOM_interp_infra.F90
+++ b/config_src/infra/FMS1/MOM_interp_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module wraps the FMS temporal and spatial interpolation routines
module MOM_interp_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domain_infra, only : MOM_domain_type, domain2d
use MOM_time_manager, only : time_type
use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type
diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90
index 55a304e13e..7a80111320 100644
--- a/config_src/infra/FMS1/MOM_io_infra.F90
+++ b/config_src/infra/FMS1/MOM_io_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains a thin inteface to mpp and fms I/O code
module MOM_io_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE
use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE
use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING
@@ -14,6 +16,7 @@ module MOM_io_infra
use mpp_io_mod, only : mpp_write_meta, mpp_write, mpp_read
use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist
use mpp_io_mod, only : mpp_get_axes, axistype, mpp_get_axis_data
+use mpp_io_mod, only : mpp_get_axis_length
use mpp_io_mod, only : mpp_get_fields, fieldtype
use mpp_io_mod, only : mpp_get_info, mpp_get_times
use mpp_io_mod, only : mpp_io_init
diff --git a/config_src/infra/FMS1/MOM_time_manager.F90 b/config_src/infra/FMS1/MOM_time_manager.F90
index 5f3279b713..c03390a4bf 100644
--- a/config_src/infra/FMS1/MOM_time_manager.F90
+++ b/config_src/infra/FMS1/MOM_time_manager.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Wraps the FMS time manager functions
module MOM_time_manager
-! This file is part of MOM6. See LICENSE.md for the license.
-
use time_manager_mod, only : time_type, get_time, set_time
use time_manager_mod, only : time_type_to_real, real_to_time_type
use time_manager_mod, only : operator(+), operator(-), operator(*), operator(/)
@@ -17,8 +19,9 @@ module MOM_time_manager
implicit none ; private
+! FMS re-exports
public :: time_type, get_time, set_time
-public :: time_type_to_real, real_to_time_type, real_to_time
+public :: time_type_to_real, real_to_time_type
public :: set_ticks_per_second, get_ticks_per_second
public :: operator(+), operator(-), operator(*), operator(/)
public :: operator(>), operator(<), operator(>=), operator(<=)
@@ -26,6 +29,8 @@ module MOM_time_manager
public :: get_date, set_date, increment_date, month_name, days_in_month
public :: JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN, NO_CALENDAR
public :: set_calendar_type, get_calendar_type
+! Module functions
+public :: real_to_time, time_minus_signed, time_to_real
contains
@@ -34,14 +39,19 @@ module MOM_time_manager
!! signed integers, this version should work over the entire valid range (2^31 days or ~5.8835
!! million years) of time_types, whereas the standard version in the FMS time_manager stops working
!! for conversions of times greater than 2^31 seconds, or ~68.1 years.
-type(time_type) function real_to_time(x, err_msg)
+type(time_type) function real_to_time(time_in, err_msg, unscale)
! type(time_type) :: real_to_time !< The output time as a time_type
- real, intent(in) :: x !< The input time in real seconds.
+ real, intent(in) :: time_in !< The input time in [s] or [T ~> s]
character(len=*), optional, intent(out) :: err_msg !< An optional returned error message.
+ real, optional, intent(in) :: unscale !< A scaling factor that the input time is
+ !! multiplied by, often in [s T-1 ~> nondim]
! Local variables
+ real :: x ! The time in real seconds [s]
+ real :: real_subsecond_remainder ! The fractional seconds from time_in [s]
integer :: seconds, days, ticks
- real :: real_subsecond_remainder
+
+ x = time_in ; if (present(unscale)) x = unscale*time_in
days = floor(x/86400.)
seconds = floor(x - 86400.*days)
@@ -49,6 +59,41 @@ type(time_type) function real_to_time(x, err_msg)
ticks = nint(real_subsecond_remainder * get_ticks_per_second())
real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg)
+
end function real_to_time
+!> Returns the real number of seconds encoded in the time type [s] or the rescaled
+!! amount of time in other units, often [T ~> s]
+real function time_to_real(time, scale)
+ type(time_type), intent(in) :: time !< The time to be converted.
+ real, optional, intent(in) :: scale !< A scaling factor that returned the time is
+ !! multiplied by, often in [T s-1 ~> nondim]
+
+ time_to_real = time_type_to_real(time)
+ if (present(scale)) time_to_real = scale * time_to_real
+
+end function time_to_real
+
+!> Returns a real number representing time_a - time_b in [s] or [T ~> s] if scale is present.
+!! The FMS - operator for time types returns a new time type representing
+!! a difference that is always >= 0.
+!! In contrast, this function returns a negative real number if time_b > time_a,
+!! and a positive real otherwise, as would be expected for subtraction.
+real function time_minus_signed(time_a, time_b, scale)
+ type(time_type), intent(in) :: time_a, time_b !< Two times for calculating time_a - time_b
+ real, optional, intent(in) :: scale !< A scaling factor that returned the time is
+ !! multiplied by, often in [T s-1 ~> nondim]
+
+ ! Local variables
+ real :: abs_diff ! The absolute value of the difference in times [s] or [T ~> s]
+
+ ! Do FMS time subtraction, which will always be >= 0,
+ ! and convert to a real number.
+ abs_diff = time_to_real(time_a - time_b, scale)
+
+ ! Add the sign back by comparing time_a and time_b
+ time_minus_signed = merge(abs_diff, -abs_diff, time_a >= time_b)
+
+end function time_minus_signed
+
end module MOM_time_manager
diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90
index 1b1092ad9c..b376bee5b3 100644
--- a/config_src/infra/FMS2/MOM_coms_infra.F90
+++ b/config_src/infra/FMS2/MOM_coms_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Thin interfaces to non-domain-oriented mpp communication subroutines
module MOM_coms_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use iso_fortran_env, only : int32, int64
use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe
diff --git a/config_src/infra/FMS2/MOM_constants.F90 b/config_src/infra/FMS2/MOM_constants.F90
index a632267a7f..ad44ba4f85 100644
--- a/config_src/infra/FMS2/MOM_constants.F90
+++ b/config_src/infra/FMS2/MOM_constants.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides a few physical constants
module MOM_constants
-! This file is part of MOM6. See LICENSE.md for the license.
-
use constants_mod, only : FMS_HLV => HLV
use constants_mod, only : FMS_HLF => HLF
diff --git a/config_src/infra/FMS2/MOM_couplertype_infra.F90 b/config_src/infra/FMS2/MOM_couplertype_infra.F90
index 3bcccc1dc7..b8dbc1be82 100644
--- a/config_src/infra/FMS2/MOM_couplertype_infra.F90
+++ b/config_src/infra/FMS2/MOM_couplertype_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module wraps the FMS coupler types module
module MOM_couplertype_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor
use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data
use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data
diff --git a/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90
index 0c42c577b4..aeca65b863 100644
--- a/config_src/infra/FMS2/MOM_cpu_clock_infra.F90
+++ b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Wraps the MPP cpu clock functions
!!
!! The functions and constants should be accessed via mom_cpu_clock
module MOM_cpu_clock_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module
use fms_mod, only : clock_flag_default
use mpp_mod, only : mpp_clock_begin
diff --git a/config_src/infra/FMS2/MOM_data_override_infra.F90 b/config_src/infra/FMS2/MOM_data_override_infra.F90
index 1484f0c128..57311710c8 100644
--- a/config_src/infra/FMS2/MOM_data_override_infra.F90
+++ b/config_src/infra/FMS2/MOM_data_override_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> These interfaces allow for ocean or sea-ice variables to be replaced with data.
module MOM_data_override_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domain_infra, only : MOM_domain_type, domain2d
use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind
use MOM_time_manager, only : time_type
diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90
index 57f92c2046..2648900493 100644
--- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90
+++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A wrapper for the FMS diag_manager routines. This module should be the
!! only MOM6 module which imports the FMS shared infrastructure for
!! diagnostics. Pass through interfaces are being documented
@@ -6,8 +10,6 @@
!! those APIs would be applied here).
module MOM_diag_manager_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use, intrinsic :: iso_fortran_env, only : real64
use diag_axis_mod, only : fms_axis_init=>diag_axis_init
use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name
diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90
index 258b164e51..7675089c2c 100644
--- a/config_src/infra/FMS2/MOM_domain_infra.F90
+++ b/config_src/infra/FMS2/MOM_domain_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Describes the decomposed MOM domain and has routines for communications across PEs
module MOM_domain_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms_infra, only : PE_here, root_PE, num_PEs
use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end
use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL
@@ -1138,7 +1140,7 @@ subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction
end subroutine create_vector_group_pass_3d
!> do_group_pass carries out a group halo update.
-subroutine do_group_pass(group, MOM_dom, clock)
+subroutine do_group_pass(group, MOM_dom, clock, omp_offload)
type(group_pass_type), intent(inout) :: group !< The data type that store information for
!! group update. This data will be used in
!! do_group_pass.
@@ -1147,11 +1149,13 @@ subroutine do_group_pass(group, MOM_dom, clock)
!! sent.
integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
!! started then stopped to time this routine.
+ logical, optional, intent(in) :: omp_offload !< Whether the data to be transferred is
+ !! offloaded to the GPU with OpenMP.
real :: d_type
if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
- call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type)
+ call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type, omp_offload)
if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
@@ -1212,7 +1216,7 @@ subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete)
! Local variables
logical :: do_complete
- do_complete=.true.;if (PRESENT(complete)) do_complete = complete
+ do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
@@ -1231,7 +1235,7 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete)
! Local variables
logical :: do_complete
- do_complete=.true.;if (PRESENT(complete)) do_complete = complete
+ do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
@@ -1250,7 +1254,7 @@ subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete)
! Local variables
logical :: do_complete
- do_complete=.true.;if (PRESENT(complete)) do_complete = complete
+ do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
@@ -1390,8 +1394,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_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90
index f4028f7af7..8285eefd57 100644
--- a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90
+++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A simple (very thin) wrapper for managing ensemble member layout information
module MOM_ensemble_manager_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init
use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup
use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id
diff --git a/config_src/infra/FMS2/MOM_error_infra.F90 b/config_src/infra/FMS2/MOM_error_infra.F90
index e5a8b8dc68..7db14bc127 100644
--- a/config_src/infra/FMS2/MOM_error_infra.F90
+++ b/config_src/infra/FMS2/MOM_error_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Routines for error handling and I/O management
module MOM_error_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout
use mpp_mod, only : NOTE, WARNING, FATAL
diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90
index ad15f58a56..d71dbb5342 100644
--- a/config_src/infra/FMS2/MOM_interp_infra.F90
+++ b/config_src/infra/FMS2/MOM_interp_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module wraps the FMS temporal and spatial interpolation routines
module MOM_interp_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domain_infra, only : MOM_domain_type, domain2d
use MOM_io_infra, only : axistype
use MOM_io_infra, only : set_axis_data
diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90
index 8e03acb1de..975dced2ca 100644
--- a/config_src/infra/FMS2/MOM_io_infra.F90
+++ b/config_src/infra/FMS2/MOM_io_infra.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains a thin inteface to mpp and fms I/O code
module MOM_io_infra
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE
use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE
use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE
diff --git a/config_src/infra/FMS2/MOM_time_manager.F90 b/config_src/infra/FMS2/MOM_time_manager.F90
index 5f3279b713..c03390a4bf 100644
--- a/config_src/infra/FMS2/MOM_time_manager.F90
+++ b/config_src/infra/FMS2/MOM_time_manager.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Wraps the FMS time manager functions
module MOM_time_manager
-! This file is part of MOM6. See LICENSE.md for the license.
-
use time_manager_mod, only : time_type, get_time, set_time
use time_manager_mod, only : time_type_to_real, real_to_time_type
use time_manager_mod, only : operator(+), operator(-), operator(*), operator(/)
@@ -17,8 +19,9 @@ module MOM_time_manager
implicit none ; private
+! FMS re-exports
public :: time_type, get_time, set_time
-public :: time_type_to_real, real_to_time_type, real_to_time
+public :: time_type_to_real, real_to_time_type
public :: set_ticks_per_second, get_ticks_per_second
public :: operator(+), operator(-), operator(*), operator(/)
public :: operator(>), operator(<), operator(>=), operator(<=)
@@ -26,6 +29,8 @@ module MOM_time_manager
public :: get_date, set_date, increment_date, month_name, days_in_month
public :: JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN, NO_CALENDAR
public :: set_calendar_type, get_calendar_type
+! Module functions
+public :: real_to_time, time_minus_signed, time_to_real
contains
@@ -34,14 +39,19 @@ module MOM_time_manager
!! signed integers, this version should work over the entire valid range (2^31 days or ~5.8835
!! million years) of time_types, whereas the standard version in the FMS time_manager stops working
!! for conversions of times greater than 2^31 seconds, or ~68.1 years.
-type(time_type) function real_to_time(x, err_msg)
+type(time_type) function real_to_time(time_in, err_msg, unscale)
! type(time_type) :: real_to_time !< The output time as a time_type
- real, intent(in) :: x !< The input time in real seconds.
+ real, intent(in) :: time_in !< The input time in [s] or [T ~> s]
character(len=*), optional, intent(out) :: err_msg !< An optional returned error message.
+ real, optional, intent(in) :: unscale !< A scaling factor that the input time is
+ !! multiplied by, often in [s T-1 ~> nondim]
! Local variables
+ real :: x ! The time in real seconds [s]
+ real :: real_subsecond_remainder ! The fractional seconds from time_in [s]
integer :: seconds, days, ticks
- real :: real_subsecond_remainder
+
+ x = time_in ; if (present(unscale)) x = unscale*time_in
days = floor(x/86400.)
seconds = floor(x - 86400.*days)
@@ -49,6 +59,41 @@ type(time_type) function real_to_time(x, err_msg)
ticks = nint(real_subsecond_remainder * get_ticks_per_second())
real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg)
+
end function real_to_time
+!> Returns the real number of seconds encoded in the time type [s] or the rescaled
+!! amount of time in other units, often [T ~> s]
+real function time_to_real(time, scale)
+ type(time_type), intent(in) :: time !< The time to be converted.
+ real, optional, intent(in) :: scale !< A scaling factor that returned the time is
+ !! multiplied by, often in [T s-1 ~> nondim]
+
+ time_to_real = time_type_to_real(time)
+ if (present(scale)) time_to_real = scale * time_to_real
+
+end function time_to_real
+
+!> Returns a real number representing time_a - time_b in [s] or [T ~> s] if scale is present.
+!! The FMS - operator for time types returns a new time type representing
+!! a difference that is always >= 0.
+!! In contrast, this function returns a negative real number if time_b > time_a,
+!! and a positive real otherwise, as would be expected for subtraction.
+real function time_minus_signed(time_a, time_b, scale)
+ type(time_type), intent(in) :: time_a, time_b !< Two times for calculating time_a - time_b
+ real, optional, intent(in) :: scale !< A scaling factor that returned the time is
+ !! multiplied by, often in [T s-1 ~> nondim]
+
+ ! Local variables
+ real :: abs_diff ! The absolute value of the difference in times [s] or [T ~> s]
+
+ ! Do FMS time subtraction, which will always be >= 0,
+ ! and convert to a real number.
+ abs_diff = time_to_real(time_a - time_b, scale)
+
+ ! Add the sign back by comparing time_a and time_b
+ time_minus_signed = merge(abs_diff, -abs_diff, time_a >= time_b)
+
+end function time_minus_signed
+
end module MOM_time_manager
diff --git a/config_src/infra/TIM/MOM_domain_infra.F90 b/config_src/infra/TIM/MOM_domain_infra.F90
index 1ea5a371b1..4a66bfcdcb 100644
--- a/config_src/infra/TIM/MOM_domain_infra.F90
+++ b/config_src/infra/TIM/MOM_domain_infra.F90
@@ -1138,7 +1138,7 @@ subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction
end subroutine create_vector_group_pass_3d
!> do_group_pass carries out a group halo update.
-subroutine do_group_pass(group, MOM_dom, clock)
+subroutine do_group_pass(group, MOM_dom, clock, omp_offload)
type(group_pass_type), intent(inout) :: group !< The data type that store information for
!! group update. This data will be used in
!! do_group_pass.
@@ -1147,11 +1147,13 @@ subroutine do_group_pass(group, MOM_dom, clock)
!! sent.
integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
!! started then stopped to time this routine.
+ logical, optional, intent(in) :: omp_offload !< Whether the data to be transferred is
+ !! offloaded to the GPU with OpenMP.
real :: d_type
if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
- call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type)
+ call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type, omp_offload)
if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
diff --git a/config_src/infra/TIM/MOM_time_manager.F90 b/config_src/infra/TIM/MOM_time_manager.F90
index 5f3279b713..c023557eab 100644
--- a/config_src/infra/TIM/MOM_time_manager.F90
+++ b/config_src/infra/TIM/MOM_time_manager.F90
@@ -18,7 +18,7 @@ module MOM_time_manager
implicit none ; private
public :: time_type, get_time, set_time
-public :: time_type_to_real, real_to_time_type, real_to_time
+public :: time_type_to_real, real_to_time_type
public :: set_ticks_per_second, get_ticks_per_second
public :: operator(+), operator(-), operator(*), operator(/)
public :: operator(>), operator(<), operator(>=), operator(<=)
@@ -26,6 +26,8 @@ module MOM_time_manager
public :: get_date, set_date, increment_date, month_name, days_in_month
public :: JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN, NO_CALENDAR
public :: set_calendar_type, get_calendar_type
+! Module functions
+public :: real_to_time, time_minus_signed, time_to_real
contains
@@ -34,14 +36,19 @@ module MOM_time_manager
!! signed integers, this version should work over the entire valid range (2^31 days or ~5.8835
!! million years) of time_types, whereas the standard version in the FMS time_manager stops working
!! for conversions of times greater than 2^31 seconds, or ~68.1 years.
-type(time_type) function real_to_time(x, err_msg)
+type(time_type) function real_to_time(time_in, err_msg, unscale)
! type(time_type) :: real_to_time !< The output time as a time_type
- real, intent(in) :: x !< The input time in real seconds.
+ real, intent(in) :: time_in !< The input time in [s] or [T ~> s]
character(len=*), optional, intent(out) :: err_msg !< An optional returned error message.
+ real, optional, intent(in) :: unscale !< A scaling factor that the input time is
+ !! multiplied by, often in [s T-1 ~> nondim]
! Local variables
+ real :: x ! The time in real seconds [s]
+ real :: real_subsecond_remainder ! The fractional seconds from time_in [s]
integer :: seconds, days, ticks
- real :: real_subsecond_remainder
+
+ x = time_in ; if (present(unscale)) x = unscale*time_in
days = floor(x/86400.)
seconds = floor(x - 86400.*days)
@@ -49,6 +56,41 @@ type(time_type) function real_to_time(x, err_msg)
ticks = nint(real_subsecond_remainder * get_ticks_per_second())
real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg)
+
end function real_to_time
+!> Returns the real number of seconds encoded in the time type [s] or the rescaled
+!! amount of time in other units, often [T ~> s]
+real function time_to_real(time, scale)
+ type(time_type), intent(in) :: time !< The time to be converted.
+ real, optional, intent(in) :: scale !< A scaling factor that returned the time is
+ !! multiplied by, often in [T s-1 ~> nondim]
+
+ time_to_real = time_type_to_real(time)
+ if (present(scale)) time_to_real = scale * time_to_real
+
+end function time_to_real
+
+!> Returns a real number representing time_a - time_b in [s] or [T ~> s] if scale is present.
+!! The FMS - operator for time types returns a new time type representing
+!! a difference that is always >= 0.
+!! In contrast, this function returns a negative real number if time_b > time_a,
+!! and a positive real otherwise, as would be expected for subtraction.
+real function time_minus_signed(time_a, time_b, scale)
+ type(time_type), intent(in) :: time_a, time_b !< Two times for calculating time_a - time_b
+ real, optional, intent(in) :: scale !< A scaling factor that returned the time is
+ !! multiplied by, often in [T s-1 ~> nondim]
+
+ ! Local variables
+ real :: abs_diff ! The absolute value of the difference in times [s] or [T ~> s]
+
+ ! Do FMS time subtraction, which will always be >= 0,
+ ! and convert to a real number.
+ abs_diff = time_to_real(time_a - time_b, scale)
+
+ ! Add the sign back by comparing time_a and time_b
+ time_minus_signed = merge(abs_diff, -abs_diff, time_a >= time_b)
+
+end function time_minus_signed
+
end module MOM_time_manager
diff --git a/config_src/memory/dynamic_nonsymmetric/MOM_memory.h b/config_src/memory/dynamic_nonsymmetric/MOM_memory.h
index c3385b8b9a..0d5f44d6be 100644
--- a/config_src/memory/dynamic_nonsymmetric/MOM_memory.h
+++ b/config_src/memory/dynamic_nonsymmetric/MOM_memory.h
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!/// \brief Compile-time memory settings
!/// \details This include file determines the compile-time memory settings.
!/// There are several variants of this file and only one should be in the search path for compilation.
diff --git a/config_src/memory/dynamic_symmetric/MOM_memory.h b/config_src/memory/dynamic_symmetric/MOM_memory.h
index 4188663a2c..e1557b6ac7 100644
--- a/config_src/memory/dynamic_symmetric/MOM_memory.h
+++ b/config_src/memory/dynamic_symmetric/MOM_memory.h
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!/// \brief Compile-time memory settings
!/// \details This include file determines the compile-time memory settings.
!/// There are several variants of this file and only one should be in the search path for compilation.
diff --git a/docs/postProcessEquations.py b/docs/postProcessEquations.py
index 396c41b507..59bceb15d0 100644
--- a/docs/postProcessEquations.py
+++ b/docs/postProcessEquations.py
@@ -1,3 +1,7 @@
+# This file is part of MOM6, the Modular Ocean Model version 6.
+# See the LICENSE file for licensing information.
+# SPDX-License-Identifier: Apache-2.0
+
import os, sys, pathlib, re
import itertools
from lxml import html
diff --git a/docs/requirements.txt b/docs/requirements.txt
index b38dbc34b7..539de3fc0e 100644
--- a/docs/requirements.txt
+++ b/docs/requirements.txt
@@ -16,3 +16,5 @@ sphinxcontrib_htmlhelp<2.0.5
sphinxcontrib_qthelp<1.0.7
sphinxcontrib_serializinghtml<1.0.7
alabaster<0.7.14
+# setuptools 82.0.0 removed pkg_resources
+setuptools<82.0.0
\ No newline at end of file
diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90
index 252a8e9a60..c347fb28d5 100644
--- a/src/ALE/MOM_ALE.F90
+++ b/src/ALE/MOM_ALE.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the main regridding routines.
!!
!! Regridding comprises two steps:
@@ -8,8 +12,6 @@
!! Original module written by Laurent White, 2008.06.09
module MOM_ALE
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : check_column_integrals
use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl
use MOM_diag_mediator, only : time_type, diag_update_remap_grids, query_averaging_enabled
@@ -53,6 +55,7 @@ module MOM_ALE
use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation
use PLM_functions, only : PLM_extrapolate_slope, PLM_monotonized_slope, PLM_slope_wa
use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation
+use Recon1d_PLM_WLS, only : PLM_WLS
implicit none ; private
#include
@@ -140,6 +143,7 @@ module MOM_ALE
public ALE_PLM_edge_values
public TS_PLM_edge_values
public TS_PPM_edge_values
+public TS_PLM_WLS_edge_values
public adjustGridForIntegrity
public ALE_initRegridding
public ALE_getCoordinate
@@ -165,8 +169,9 @@ module MOM_ALE
!! before the main time integration loop to initialize the regridding stuff.
!! We read the MOM_input file to register the values of different
!! regridding/remapping parameters.
-subroutine ALE_init( param_file, GV, US, max_depth, CS)
+subroutine ALE_init( param_file, G, GV, US, max_depth, CS)
type(param_file_type), intent(in) :: param_file !< Parameter file
+ type(ocean_grid_type), intent(in) :: G !< Grid structure
type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m].
@@ -205,8 +210,9 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS)
default=.false.)
! Initialize and configure regridding
- call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS)
- call regridding_preadjust_reqs(CS%regridCS, CS%do_conv_adj, CS%use_hybgen_unmix, hybgen_CS=hybgen_regridCS)
+ call ALE_initRegridding(G, GV, US, max_depth, param_file, mdl, CS%regridCS)
+ call regridding_preadjust_reqs(CS%regridCS, CS%do_conv_adj, CS%use_hybgen_unmix, &
+ hybgen_CS=hybgen_regridCS)
! Initialize and configure remapping that is orchestrated by ALE.
call get_param(param_file, mdl, "REMAPPING_SCHEME", string, &
@@ -236,7 +242,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS)
"extrapolated instead of piecewise constant", default=.false.)
call get_param(param_file, mdl, "INIT_BOUNDARY_EXTRAP", init_boundary_extrap, &
"If true, values at the interfaces of boundary cells are "//&
- "extrapolated instead of piecewise constant during initialization."//&
+ "extrapolated instead of piecewise constant during initialization. "//&
"Defaults to REMAP_BOUNDARY_EXTRAP.", default=remap_boundary_extrap)
call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
"This sets the default value for the various _ANSWER_DATE parameters.", &
@@ -290,6 +296,13 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS)
"legacy step and should not be needed if the initialization is "//&
"consistent with the coordinate mode.", default=.true.)
+ call get_param(param_file, mdl, "REGRID_USE_DEPTH_BASED_TIME_FILTER", local_logical, &
+ "If true, always uses depth-based time filtering code that updates the "//&
+ "generated grid using REGRID_TIME_SCALE, REGRID_FILTER_SHALLOW_DEPTH, "//&
+ "REGRID_FILTER_DEEP_DEPTH parameters. Setting to True always uses "//&
+ "filtering but setting to False bypasses calculations when filter times = 0.", &
+ default=.true.)
+ call set_regrid_params(CS%regridCS, use_depth_based_time_filter=local_logical)
call get_param(param_file, mdl, "REGRID_TIME_SCALE", CS%regrid_time_scale, &
"The time-scale used in blending between the current (old) grid "//&
"and the target (new) grid. A short time-scale favors the target "//&
@@ -303,7 +316,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS)
call get_param(param_file, mdl, "REGRID_FILTER_DEEP_DEPTH", filter_deep_depth, &
"The depth below which full time-filtering is applied with time-scale "//&
"REGRID_TIME_SCALE. Between depths REGRID_FILTER_SHALLOW_DEPTH and "//&
- "REGRID_FILTER_SHALLOW_DEPTH the filter weights adopt a cubic profile.", &
+ "REGRID_FILTER_DEEP_DEPTH the filter weights adopt a cubic profile.", &
units="m", default=0., scale=GV%m_to_H)
call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth, &
depth_of_time_filter_deep=filter_deep_depth)
@@ -321,12 +334,12 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS)
default=-0.001, units="m", scale=GV%m_to_H)
call get_param(param_file, mdl, "REMAP_VEL_MASK_H_THIN", CS%h_vel_mask, &
"A thickness at velocity points below which near-bottom layers are zeroed out "//&
- "after remapping, following practice with Hybgen remapping, or a negative value "//&
- "to avoid such filtering altogether.", &
+ "after remapping, following practice with Hybgen remapping, "//&
+ "or a negative value to avoid such filtering altogether.", &
default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=(CS%BBL_h_vel_mask<=0.0))
if (CS%use_hybgen_unmix) &
- call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS)
+ call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS)
call get_param(param_file, mdl, "REMAP_VEL_CONSERVE_KE", CS%conserve_ke, &
"If true, a correction is applied to the baroclinic component of velocity "//&
@@ -411,15 +424,15 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS)
'Layer thicknesses tendency due to ALE regridding and remapping', &
trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.)
CS%id_remap_delta_integ_u2 = register_diag_field('ocean_model', 'ale_u2', diag%axesCu1, Time, &
- 'Rate of change in half rho0 times depth integral of squared zonal'//&
- ' velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//&
- ' this measures the change before the KE-conserving correction is applied.', &
- 'W m-2', conversion=GV%H_to_kg_m2 * US%L_T_to_m_s**2 * US%s_to_T)
+ 'Rate of change in half rho0 times depth integral of squared zonal '//&
+ 'velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//&
+ 'this measures the change before the KE-conserving correction is applied.', &
+ 'W m-2', conversion=US%RZ3_T3_to_W_m2*GV%H_to_RZ*US%L_to_Z**2)
CS%id_remap_delta_integ_v2 = register_diag_field('ocean_model', 'ale_v2', diag%axesCv1, Time, &
- 'Rate of change in half rho0 times depth integral of squared meridional'//&
- ' velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//&
- ' this measures the change before the KE-conserving correction is applied.', &
- 'W m-2', conversion=GV%H_to_kg_m2 * US%L_T_to_m_s**2 * US%s_to_T)
+ 'Rate of change in half rho0 times depth integral of squared meridional '//&
+ 'velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//&
+ 'this measures the change before the KE-conserving correction is applied.', &
+ 'W m-2', conversion=US%RZ3_T3_to_W_m2*GV%H_to_RZ*US%L_to_Z**2)
end subroutine ALE_register_diags
@@ -477,7 +490,10 @@ subroutine pre_ALE_diagnostics(G, GV, US, h, u, v, tv, CS)
if (CS%id_T_preale > 0) call post_data(CS%id_T_preale, tv%T, CS%diag)
if (CS%id_S_preale > 0) call post_data(CS%id_S_preale, tv%S, CS%diag)
if (CS%id_e_preale > 0) then
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: eta_preale)
call find_eta(h, tv, G, GV, US, eta_preale, dZref=G%Z_ref)
+ !$omp target exit data map(from: eta_preale)
call post_data(CS%id_e_preale, eta_preale, CS%diag)
endif
@@ -640,7 +656,8 @@ end subroutine ALE_offline_inputs
!> For a state-based coordinate, accelerate the process of regridding by
!! repeatedly applying the grid calculation algorithm
-subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial)
+subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, dt, &
+ dzRegrid, initial)
type(ALE_CS), pointer :: CS !< ALE control structure
type(ocean_grid_type), intent(inout) :: G !< Ocean grid
type(verticalGrid_type), intent(in) :: GV !< Vertical grid
@@ -689,7 +706,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d
! initial total interface displacement due to successive regridding
if (CS%remap_uv_using_old_alg) &
- dzIntTotal(:,:,:) = 0.
+ dzIntTotal(:,:,:) = 0.
call create_group_pass(pass_T_S_h, T, G%domain)
call create_group_pass(pass_T_S_h, S, G%domain)
@@ -708,7 +725,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d
! Apply timescale to regridding (for e.g. filtered_grid_motion)
if (present(dt)) &
- call ALE_update_regrid_weights(dt, CS)
+ call ALE_update_regrid_weights(dt, CS)
do itt = 1, n_itt
@@ -722,12 +739,14 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d
call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface)
if (CS%remap_uv_using_old_alg) &
- dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:)
+ dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:)
! remap from original grid onto new grid
do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1
- call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:))
- call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:))
+ call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), &
+ tv_local%S(i,j,:))
+ call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), &
+ tv_local%T(i,j,:))
enddo ; enddo
! starting grid for next iteration
@@ -1038,30 +1057,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
@@ -1130,7 +1165,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u
if (CS%id_remap_delta_integ_v2>0) dv2h_tot(:,:) = 0.
if (((CS%id_remap_delta_integ_u2>0) .or. (CS%id_remap_delta_integ_v2>0)) .and. .not.present(dt))&
- call MOM_error(FATAL, "ALE KE diagnostics requires passing dt into ALE_remap_velocities")
+ call MOM_error(FATAL, "ALE KE diagnostics requires passing dt into ALE_remap_velocities")
nz = GV%ke
@@ -1163,9 +1198,9 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u
! First get barotropic component
u_bt = 0.0
do k=1,nz
- u_bt = u_bt + h2(k) * u_tgt(k) ! Dimensions [H L T-1]
+ u_bt = u_bt + h2(k) * u_tgt(k) ! Dimensions [H L T-1 ~> m2 s-1 or kg m-1 s-1]
enddo
- u_bt = u_bt / (sum(h2(1:nz)) + GV%H_subroundoff) ! Dimensions return to [L T-1]
+ u_bt = u_bt / (sum(h2(1:nz)) + GV%H_subroundoff) ! Dimensions return to [L T-1 ~> m s-1]
! Next get baroclinic ke = \int (u-u_bt)^2 from source and target
ke_c_src = 0.0
ke_c_tgt = 0.0
@@ -1196,7 +1231,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u
endif
if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) &
- call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz)
+ call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz)
! Copy the column of new velocities back to the 3-d array
do k=1,nz
@@ -1238,9 +1273,9 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u
! First get barotropic component
v_bt = 0.0
do k=1,nz
- v_bt = v_bt + h2(k) * v_tgt(k) ! Dimensions [H L T-1]
+ v_bt = v_bt + h2(k) * v_tgt(k) ! Dimensions [H L T-1 ~> m2 s-1 or kg m-1 s-1]
enddo
- v_bt = v_bt / (sum(h2(1:nz)) + GV%H_subroundoff) ! Dimensions return to [L T-1]
+ v_bt = v_bt / (sum(h2(1:nz)) + GV%H_subroundoff) ! Dimensions return to [L T-1 ~> m s-1]
! Next get baroclinic ke = \int (u-u_bt)^2 from source and target
ke_c_src = 0.0
ke_c_tgt = 0.0
@@ -1345,13 +1380,14 @@ subroutine ALE_remap_vertex_vals(CS, G, GV, h_old, h_new, vert_val)
do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB
if ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) > 0.0 ) then
- I_mask_sum = 1.0 / ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)))
+ I_mask_sum = 1.0 / ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + &
+ (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)))
do k=1,nz
h_src(k) = ((G%mask2dT(i,j) * h_old(i,j,k) + G%mask2dT(i+1,j+1) * h_old(i+1,j+1,k)) + &
- (G%mask2dT(i+1,j) * h_old(i+1,j,k) + G%mask2dT(i,j+1) * h_old(i,j+1,k)) ) * I_mask_sum
+ (G%mask2dT(i+1,j) * h_old(i+1,j,k) + G%mask2dT(i,j+1) * h_old(i,j+1,k)) ) * I_mask_sum
h_tgt(k) = ((G%mask2dT(i,j) * h_new(i,j,k) + G%mask2dT(i+1,j+1) * h_new(i+1,j+1,k)) + &
- (G%mask2dT(i+1,j) * h_new(i+1,j,k) + G%mask2dT(i,j+1) * h_new(i,j+1,k)) ) * I_mask_sum
+ (G%mask2dT(i+1,j) * h_new(i+1,j,k) + G%mask2dT(i,j+1) * h_new(i,j+1,k)) ) * I_mask_sum
enddo
do K=1,nz+1
@@ -1533,7 +1569,8 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b )
do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1
slp(1) = 0.
do k = 2, GV%ke-1
- slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1))
+ slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, &
+ Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1))
enddo
slp(GV%ke) = 0.
@@ -1546,7 +1583,8 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b )
mslp = - PLM_extrapolate_slope(h(i,j,2), h(i,j,1), h_neglect, Q(i,j,2), Q(i,j,1))
Q_t(i,j,1) = Q(i,j,1) - 0.5 * mslp
Q_b(i,j,1) = Q(i,j,1) + 0.5 * mslp
- mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, Q(i,j,GV%ke-1), Q(i,j,GV%ke))
+ mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, &
+ Q(i,j,GV%ke-1), Q(i,j,GV%ke))
Q_t(i,j,GV%ke) = Q(i,j,GV%ke) - 0.5 * mslp
Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + 0.5 * mslp
else
@@ -1583,11 +1621,11 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap
! Local variables
integer :: i, j, k
real :: hTmp(GV%ke) ! A 1-d copy of h [H ~> m or kg m-2]
- real :: tmp(GV%ke) ! A 1-d copy of a column of temperature [degC] or salinity [ppt]
+ real :: tmp(GV%ke) ! A 1-d copy of a column of temperature [C ~> degC] or salinity [S ~> ppt]
real, dimension(CS%nk,2) :: &
- ppol_E ! Edge value of polynomial in [degC] or [ppt]
+ ppol_E ! Edge value of polynomial in [C ~> degC] or [S ~> ppt]
real, dimension(CS%nk,3) :: &
- ppol_coefs ! Coefficients of polynomial, all in [degC] or [ppt]
+ ppol_coefs ! Coefficients of polynomial, all in [C ~> degC] or [S ~> ppt]
real :: h_neglect, h_neglect_edge ! Tiny thicknesses [H ~> m or kg m-2]
if (CS%answer_date >= 20190101) then
@@ -1614,7 +1652,7 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap
call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, &
answer_date=CS%answer_date )
if (bdry_extrap) &
- call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect )
+ call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect )
do k = 1,GV%ke
S_t(i,j,k) = ppol_E(k,1)
@@ -1635,7 +1673,7 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap
call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, &
answer_date=CS%answer_date )
if (bdry_extrap) &
- call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect )
+ call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect )
do k = 1,GV%ke
T_t(i,j,k) = ppol_E(k,1)
@@ -1646,9 +1684,49 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap
end subroutine TS_PPM_edge_values
+!> Calculate edge values (top and bottom of layer) for T and S consistent with a PLM reconstruction
+!! in the vertical direction that uses weighted least squares for the slope.
+subroutine TS_PLM_WLS_edge_values(CS, S_t, S_b, T_t, T_b, G, GV, tv, h)
+ type(ocean_grid_type), intent(in) :: G !< ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
+ type(ALE_CS), intent(inout) :: CS !< module control structure
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(inout) :: S_t !< Salinity at the top edge of each layer [S ~> ppt]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(inout) :: S_b !< Salinity at the bottom edge of each layer [S ~> ppt]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(inout) :: T_t !< Temperature at the top edge of each layer [C ~> degC]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(inout) :: T_b !< Temperature at the bottom edge of each layer [C ~> degC]
+ type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h !< layer thickness [H ~> m or kg m-2]
+ ! Local variables
+ integer :: i, j, k
+ type(PLM_WLS) :: recon !< A PLM-WLS reconstruction
+
+ call recon%init(GV%ke, h_neglect=GV%H_subroundoff)
+
+ !$OMP parallel do default(shared) firstprivate(recon)
+ do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1
+
+ call recon%reconstruct(h(i,j,:), tv%T(i,j,:))
+ T_t(i,j,:) = recon%ul(:)
+ T_b(i,j,:) = recon%ur(:)
+
+ call recon%reconstruct(h(i,j,:), tv%S(i,j,:))
+ S_t(i,j,:) = recon%ul(:)
+ S_b(i,j,:) = recon%ur(:)
+
+ enddo ; enddo
+
+ call recon%destroy()
+
+end subroutine TS_PLM_WLS_edge_values
!> Initializes regridding for the main ALE algorithm
-subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS)
+subroutine ALE_initRegridding(G, GV, US, max_depth, param_file, mdl, regridCS)
+ type(ocean_grid_type), intent(in) :: G !< Grid structure
type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m].
@@ -1664,7 +1742,7 @@ subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS)
trim(regriddingCoordinateModeDoc), &
default=DEFAULT_COORDINATE_MODE, fail_if_missing=.true.)
- call initialize_regridding(regridCS, GV, US, max_depth, param_file, mdl, coord_mode, '', '')
+ call initialize_regridding(regridCS, G, GV, US, max_depth, param_file, mdl, coord_mode, '', '')
end subroutine ALE_initRegridding
@@ -1769,7 +1847,7 @@ subroutine ALE_initThicknessToCoord( CS, G, GV, h, height_units )
scale = GV%Z_to_H
if (present(height_units)) then ; if (height_units) scale = 1.0 ; endif
do j = G%jsd,G%jed ; do i = G%isd,G%ied
- h(i,j,:) = scale * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j)+G%Z_ref )
+ h(i,j,:) = scale * getStaticThickness( CS%regridCS, 0., max(G%meanSL(i,j)+G%bathyT(i,j), 0.0) )
enddo ; enddo
end subroutine ALE_initThicknessToCoord
diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90
index 8c0733be78..0ac424b2d0 100644
--- a/src/ALE/MOM_hybgen_regrid.F90
+++ b/src/ALE/MOM_hybgen_regrid.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the hybgen regridding routines from HYCOM, with minor
!! modifications to follow the MOM6 coding conventions
module MOM_hybgen_regrid
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS, only : EOS_type, calculate_density
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, assert
use MOM_file_parser, only : get_param, param_file_type, log_param
@@ -427,7 +429,7 @@ subroutine hybgen_regrid(G, GV, US, dp, nom_depth_H, tv, CS, dzInterface, PCM_ce
real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim]
integer :: fixlay ! Deepest fixed coordinate layer
integer, dimension(0:CS%nk) :: k_end ! The index of the deepest source layer that contributes to
- ! each target layer, in the unusual case where the the input grid is
+ ! each target layer, in the unusual case where the input grid is
! larger than the new grid. This situation only occurs during certain
! types of initialization or when generating output diagnostics.
integer :: i, j, k, nk, k2, nk_in
@@ -988,12 +990,12 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, Rcv_tgt, &
! Verify that everything is consistent.
do k=1,nk
if (abs((h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))) > 1.0e-13*max(p_int(nk+1), CS%onem)) then
- write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') &
+ write(mesg, '("k ",I0," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') &
k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), (h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))
call MOM_error(FATAL, "Mismatched thickness changes in hybgen_regrid: "//trim(mesg))
endif
if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), CS%onem)) then
- write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",i4)') &
+ write(mesg, '("k ",I0," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",I0)') &
k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), fixlay
call MOM_error(FATAL, "Significantly negative final thickness in hybgen_regrid: "//trim(mesg))
endif
diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90
index f97b0e9c62..921ccecccc 100644
--- a/src/ALE/MOM_hybgen_remap.F90
+++ b/src/ALE/MOM_hybgen_remap.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the hybgen remapping routines from HYCOM, with minor
!! modifications to follow the MOM6 coding conventions
module MOM_hybgen_remap
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs
@@ -273,7 +275,7 @@ subroutine hybgen_weno_coefs(s, h_src, edges, nk, ns, thin, PCM_lay)
real :: qdpkm(nk) ! Inverse of the sum of two adjacent thicknesses [H-1 ~> m-1 or m2 kg-1]
real :: qdpkmkp(nk) ! Inverse of the sum of three adjacent thicknesses [H-1 ~> m-1 or m2 kg-1]
real :: dpkm2kp(nk) ! Twice the distance between the centers of the layers two apart [H ~> m or kg m-2]
- real :: zw(nk,2) ! Squared combinations of the differences between the the cell average tracer
+ real :: zw(nk,2) ! Squared combinations of the differences between the cell average tracer
! concentrations and the left and right edges [A2]
real :: min_ratio ! The minimum ratio of the values of zw used to interpolate the edge values [nondim]
real :: wt1 ! The weight of the upper layer in the interpolated shared edge value [nondim]
diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90
index 6ddb828abe..dee62ef47c 100644
--- a/src/ALE/MOM_hybgen_unmix.F90
+++ b/src/ALE/MOM_hybgen_unmix.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the hybgen unmixing routines from HYCOM, with
!! modifications to follow the MOM6 coding conventions and several bugs fixed
module MOM_hybgen_unmix
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING
use MOM_file_parser, only : get_param, param_file_type, log_param
@@ -214,23 +216,23 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h)
endif
! The following block of code is used to trigger z* stretching of the targets heights.
- if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussiesq version
+ if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussinesq version
dz_tot = 0.0
do k=1,nk
dz_tot = dz_tot + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h_col(k)
enddo
- if (dz_tot <= CS%min_dilate*(G%bathyT(i,j)+G%Z_ref)) then
+ if (dz_tot <= CS%min_dilate * (G%meanSL(i,j) + G%bathyT(i,j))) then
dilate = CS%min_dilate
- elseif (dz_tot >= CS%max_dilate*(G%bathyT(i,j)+G%Z_ref)) then
+ elseif (dz_tot >= CS%max_dilate * (G%meanSL(i,j) + G%bathyT(i,j))) then
dilate = CS%max_dilate
else
- dilate = dz_tot / (G%bathyT(i,j)+G%Z_ref)
+ dilate = dz_tot / (G%meanSL(i,j) + G%bathyT(i,j))
endif
else
- nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H
- if (h_tot <= CS%min_dilate*nominalDepth) then
+ nominalDepth = (G%meanSL(i,j) + G%bathyT(i,j)) * GV%Z_to_H
+ if (h_tot <= CS%min_dilate * nominalDepth) then
dilate = CS%min_dilate
- elseif (h_tot >= CS%max_dilate*nominalDepth) then
+ elseif (h_tot >= CS%max_dilate * nominalDepth) then
dilate = CS%max_dilate
else
dilate = h_tot / nominalDepth
@@ -274,18 +276,18 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h)
Trh_tot_out(m) = Trh_tot_out(m) + h_col(k)*tracer(k,m)
enddo ; enddo
if (abs(Sh_tot_in - Sh_tot_out) > 1.e-15*(abs(Sh_tot_in) + abs(Sh_tot_out))) then
- write(mesg, '("i,j=",2i8,"Sh_tot = ",2es17.8," err = ",es13.4)') &
+ write(mesg, '("i,j=",I0,",",I0," Sh_tot = ",2es17.8," err = ",es13.4)') &
i, j, Sh_tot_in, Sh_tot_out, (Sh_tot_in - Sh_tot_out)
call MOM_error(FATAL, "Mismatched column salinity in hybgen_unmix: "//trim(mesg))
endif
if (abs(Th_tot_in - Th_tot_out) > 1.e-10*(abs(Th_tot_in) + abs(Th_tot_out))) then
- write(mesg, '("i,j=",2i8,"Th_tot = ",2es17.8," err = ",es13.4)') &
+ write(mesg, '("i,j=",I0,",",I0," Th_tot = ",2es17.8," err = ",es13.4)') &
i, j, Th_tot_in, Th_tot_out, (Th_tot_in - Th_tot_out)
call MOM_error(FATAL, "Mismatched column temperature in hybgen_unmix: "//trim(mesg))
endif
do m=1,ntr
if (abs(Trh_tot_in(m) - Trh_tot_out(m)) > 1.e-10*(abs(Trh_tot_in(m)) + abs(Trh_tot_out(m)))) then
- write(mesg, '("i,j=",2i8,"Trh_tot(",i2,") = ",2es17.8," err = ",es13.4)') &
+ write(mesg, '("i,j=",I0,",",I0," Trh_tot(",i0,") = ",2es17.8," err = ",es13.4)') &
i, j, m, Trh_tot_in(m), Trh_tot_out(m), (Trh_tot_in(m) - Trh_tot_out(m))
call MOM_error(FATAL, "Mismatched column tracer in hybgen_unmix: "//trim(mesg))
endif
diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90
index c29b88286e..59ec8d4d7d 100644
--- a/src/ALE/MOM_regridding.F90
+++ b/src/ALE/MOM_regridding.F90
@@ -1,11 +1,14 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Generates vertical grids as part of the ALE algorithm
module MOM_regridding
-! This file is part of MOM6. See LICENSE.md for the license.
-
-use MOM_error_handler, only : MOM_error, FATAL, WARNING, assert
+use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, assert
use MOM_file_parser, only : param_file_type, get_param, log_param
use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data
+use MOM_io, only : read_variable
use MOM_io, only : vardesc, var_desc, SINGLE_FILE
use MOM_io, only : MOM_netCDF_file, MOM_field
use MOM_io, only : create_MOM_file, MOM_write_field
@@ -14,6 +17,7 @@ module MOM_regridding
use MOM_variables, only : ocean_grid_type, thermo_var_ptrs
use MOM_verticalGrid, only : verticalGrid_type
use MOM_EOS, only : EOS_type, calculate_density
+use MOM_domains, only : max_across_PEs, pass_var
use MOM_string_functions, only : uppercase, extractWord, extract_integer, extract_real
use MOM_remapping, only : remapping_CS
@@ -23,14 +27,20 @@ module MOM_regridding
use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA
use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR
use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE
-use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap, set_interp_answer_date
+use regrid_interp, only : interp_CS_type
+use regrid_interp, only : set_interp_scheme, set_interp_extrap, set_interp_answer_date
-use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike
-use coord_sigma, only : init_coord_sigma, sigma_CS, set_sigma_params, build_sigma_column, end_coord_sigma
+use coord_zlike, only : zlike_CS
+use coord_zlike, only : init_coord_zlike, set_zlike_params, build_zstar_column, end_coord_zlike
+use coord_sigma, only : sigma_CS
+use coord_sigma, only : init_coord_sigma, set_sigma_params, build_sigma_column, end_coord_sigma
use coord_rho, only : init_coord_rho, rho_CS, set_rho_params, build_rho_column, end_coord_rho
use coord_rho, only : old_inflate_layers_1d
-use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom
-use coord_adapt, only : init_coord_adapt, adapt_CS, set_adapt_params, build_adapt_column, end_coord_adapt
+use coord_hycom, only : hycom_CS
+use coord_hycom, only : init_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom
+use coord_hycom, only : init_3d_coord_hycom
+use coord_adapt, only : adapt_CS
+use coord_adapt, only : init_coord_adapt, set_adapt_params, build_adapt_column, end_coord_adapt
use MOM_hybgen_regrid, only : hybgen_regrid, hybgen_regrid_CS, init_hybgen_regrid, end_hybgen_regrid
use MOM_hybgen_regrid, only : write_Hybgen_coord_file
@@ -66,6 +76,12 @@ module MOM_regridding
!> A flag to indicate that the target_density arrays has been filled with data.
logical :: target_density_set = .false.
+ !> Nominal HYCOM1 3D near-surface resolution [Z ~> m]
+ real, allocatable, dimension(:,:,:) :: coordinateResolution_3d
+
+ !> Nominal HYCOM1 3D density of interfaces [R ~> kg m-3]
+ real, allocatable, dimension(:,:,:) :: target_density_3d
+
!> This array is set by function set_regrid_max_depths()
!! It specifies the maximum depth that every interface is allowed to take [H ~> m or kg m-2].
real, dimension(:), allocatable :: max_interface_depths
@@ -86,9 +102,16 @@ module MOM_regridding
!> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2].
real :: min_thickness
+ !> If true, call adjust_interface_motion() after initial grid generation
+ logical :: use_adjust_interface_motion
+
!> Reference pressure for potential density calculations [R L2 T-2 ~> Pa]
real :: ref_pressure = 2.e7
+ !> If true, always pass through the depth-based time filtering that uses CS%old_grid_weight
+ !! If false, allows bypassing of the call if CS%old_grid_weight==0
+ logical :: use_depth_based_time_filter
+
!> Weight given to old coordinate when blending between new and old grids [nondim]
!! Used only below depth_of_time_filter_shallow, with a cubic variation
!! from zero to full effect between depth_of_time_filter_shallow and
@@ -183,8 +206,10 @@ module MOM_regridding
contains
!> Initialization and configures a regridding control structure based on customizable run-time parameters
-subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_mode, param_prefix, param_suffix)
+subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, &
+ coord_mode, param_prefix, param_suffix)
type(regridding_CS), intent(inout) :: CS !< Regridding control structure
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m].
@@ -197,6 +222,11 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
! Local variables
integer :: ke ! Number of levels
+ integer :: n_sigma ! Number of shallow dz's, for HYBRID_MAP or HYBRID_3D
+ integer :: np ! Number of profiles, for HYBRID_MAP
+ integer :: nceiling ! ceiling of map index, for HYBRID_MAP
+ integer :: nfloor ! floor of map index, for HYBRID_MAP
+ real :: nfrac ! fraction of map index, for HYBRID_MAP [nondim]
character(len=80) :: string, string2, varName ! Temporary strings
character(len=40) :: coord_units, coord_res_param ! Temporary strings
character(len=MAX_PARAM_LENGTH) :: param_name
@@ -213,13 +243,25 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z).
real :: dz_extra ! The thickness of an added layer to append to the woa09_dz profile when
! maximum_depth is large [m] (not in Z).
+ real :: nominalDepth ! Depth of ocean bottom in thickness units (positive downward) [H ~> m or kg m-2]
+ real :: depth_q ! A depth scale factor [nondim]
+ real :: depth_s ! The end of the shallow Z regime [m]
+ real :: depth_d ! The start of the deep Z regime [m]
real :: adaptTimeRatio, adaptZoomCoeff ! Temporary variables for input parameters [nondim]
real :: adaptBuoyCoeff, adaptAlpha ! Temporary variables for input parameters [nondim]
real :: adaptZoom ! The thickness of the near-surface zooming region with the adaptive coordinate [H ~> m or kg m-2]
real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3]
- integer :: k, nzf(4)
+ integer :: i, j, k, nzf(4)
real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m]
! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units.
+ real, dimension(:,:), allocatable :: dz_2d ! 2D resolution (thickness) in units of coordinate, which may be [m]
+ ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units.
+ real, dimension(:,:,:), allocatable :: dz_3d ! 3D resolution (thickness) in units of coordinate, which may be [m]
+ ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units.
+ real, dimension(:), allocatable :: dz_shallow ! Shallow resolution (thickness), for HYBRID_MAP or HYBRID_3D [m]
+ real, dimension(:,:), allocatable :: rho_target_2d ! 2D target density used in HYBRID mode [kg m-3]
+ real, dimension(:,:,:), allocatable :: rho_target_3d ! 3D target density used in HYBRID mode [kg m-3]
+ real, dimension(:,:), allocatable :: index_map ! Region array of indexes for HYBRID_MAP [nondim]
real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses [H ~> m or kg m-2]
real, dimension(:), allocatable :: z_max ! Maximum interface depths [H ~> m or kg m-2] or other
! units depending on the coordinate
@@ -264,8 +306,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
main_parameters=.false.
if (len_trim(param_prefix)==0) main_parameters=.true.
- if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// &
- 'Suffix provided without prefix for parameter names!')
+ if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mdl)//&
+ ' initialize_regridding: Suffix provided without prefix for parameter names!')
CS%nk = 0
CS%regridding_scheme = coordinateMode(coord_mode)
@@ -309,11 +351,11 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701)
call set_regrid_params(CS, remap_answer_date=remap_answer_date)
call get_param(param_file, mdl, "REGRIDDING_ANSWER_DATE", regrid_answer_date, &
- "The vintage of the expressions and order of arithmetic to use for regridding. "//&
- "Values below 20190101 result in the use of older, less accurate expressions "//&
- "that were in use at the end of 2018. Higher values result in the use of more "//&
- "robust and accurate forms of mathematically equivalent expressions.", &
- default=20181231, do_not_log=.not.GV%Boussinesq) ! ### change to default=default_answer_date)
+ "The vintage of the expressions and order of arithmetic to use for regridding. "//&
+ "Values below 20190101 result in the use of older, less accurate expressions "//&
+ "that were in use at the end of 2018. Higher values result in the use of more "//&
+ "robust and accurate forms of mathematically equivalent expressions.", &
+ default=default_answer_date, do_not_log=.not.GV%Boussinesq)
if (.not.GV%Boussinesq) regrid_answer_date = max(regrid_answer_date, 20230701)
call set_regrid_params(CS, regrid_answer_date=regrid_answer_date)
endif
@@ -356,8 +398,23 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
" FNC1:string - FNC1:dz_min,H_total,power,precision\n"//&
" HYBRID:string - read from a file. The string specifies\n"//&
" the filename and two variable names, separated\n"//&
- " by a comma or space, for sigma-2 and dz. e.g.\n"//&
- " HYBRID:vgrid.nc,sigma2,dz",&
+ " by a comma or space, for sigma-2 and dz.\n"//&
+ " e.g. HYBRID:vgrid.nc,sigma2,dz\n"//&
+ " HYBRID_3D:string - read from a file. The string specifies\n"//&
+ " the filename and two 3D variable names, separated\n"//&
+ " by a comma or space, for sigma-2 and dz. The\n"//&
+ " latter can be FNC1:string which is used everywhere.\n"//&
+ " e.g. HYBRID_3D:vgrid.nc,sigma2,dz\n"//&
+ " HYBRID_MAP:string - read from a file. The string specifies\n"//&
+ " the filename and three variable names, separated\n"//&
+ " by a comma or space, for map, sigma-2 and dz.\n"//&
+ " Map is a spatial index array with, maxval(map)=N,\n"//&
+ " and the others are 2D arrays containing N profiles.\n"//&
+ " Map typically contains integer values, but it can\n"//&
+ " contain real values, I+w, which imply using\n"//&
+ " the weighted sum of profiles I and I+1.\n"//&
+ " Dz can be FNC1:string which is used everywhere.\n"//&
+ " e.g. HYBRID_MAP:vgrid.nc,map,sigma2,dz",&
default=trim(string2))
message = "The distribution of vertical resolution for the target\n"//&
"grid used for Eulerian-like coordinates. For example,\n"//&
@@ -378,14 +435,22 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
endif
allocate(dz(ke))
dz(:) = uniformResolution(ke, coord_mode, tmpReal, &
- US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), &
- US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) )
+ US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), &
+ US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) )
if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, &
trim(message), units=trim(coord_units))
elseif (trim(string)=='PARAM') then
! Read coordinate resolution (main model = ALE_RESOLUTION)
- ke = GV%ke ! Use model nk by default
- allocate(dz(ke))
+ allocate(dz(1001))
+ dz(:) = -1. ! Setting to <0 allows detection of unset elements
+ call get_param(param_file, mdl, coord_res_param, dz, "Scan", units="", do_not_log=.true.)
+ if (dz(1001)>=0.) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
+ "PARAM specification is limited to 1000 values. Hack the code to use more!")
+ do ke=1,1000 ! Find number of defined levels
+ if (dz(ke+1)<0.) exit
+ enddo
+ deallocate(dz)
+ allocate(dz(ke)) ! Allocate with the correct number of levels, and re-read thicknesses
call get_param(param_file, mdl, coord_res_param, dz, &
trim(message), units=trim(coord_units), fail_if_missing=.true.)
elseif (index(trim(string),'FILE:')==1) then
@@ -403,9 +468,9 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
varName = trim( extractWord(trim(string(6:)), 2) )
if (len_trim(varName)==0) then
- if (field_exists(fileName,'dz')) then; varName = 'dz'
- elseif (field_exists(fileName,'dsigma')) then; varName = 'dsigma'
- elseif (field_exists(fileName,'ztest')) then; varName = 'ztest'
+ if (field_exists(fileName,'dz')) then ; varName = 'dz'
+ elseif (field_exists(fileName,'dsigma')) then ; varName = 'dsigma'
+ elseif (field_exists(fileName,'ztest')) then ; varName = 'ztest'
else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
"Coordinate variable not specified and none could be guessed.")
endif
@@ -424,11 +489,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
varName=trim(varName(12:))
call verify_variable_units(filename, varName, expected_units, message, ierr, alt_units)
if (ierr) call MOM_error(FATAL, trim(mdl)//", initialize_regridding: "//&
- "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message))
+ "Unsupported format in grid definition '"//trim(filename)//&
+ "'. Error message "//trim(message))
call field_size(trim(fileName), trim(varName), nzf)
ke = nzf(1)-1
- if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//trim(varName)//&
- "in FILE "//trim(filename)//" requires at least 2 target interface values.")
+ if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//&
+ trim(varName)//"in FILE "//trim(filename)//&
+ " requires at least 2 target interface values.")
if (CS%regridding_scheme == REGRIDDING_RHO) then
allocate(rho_target(ke+1))
call MOM_read_data(trim(fileName), trim(varName), rho_target)
@@ -453,7 +520,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, &
trim(message), units=coordinateUnits(coord_mode))
elseif (index(trim(string),'FNC1:')==1) then
- ke = GV%ke; allocate(dz(ke))
+ ke = GV%ke ; allocate(dz(ke))
call dz_function1( trim(string(6:)), dz )
if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, &
trim(message), units=coordinateUnits(coord_mode))
@@ -461,31 +528,220 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
! Function used for set target interface densities
ke = rho_function1( trim(string(7:)), rho_target )
elseif (index(trim(string),'HYBRID:')==1) then
- ke = GV%ke; allocate(dz(ke))
- ! The following assumes the FILE: syntax of above but without "FILE:" in the string
+ ke = GV%ke
+ allocate(dz(ke))
allocate(rho_target(ke+1))
+ ! The following assumes the FILE: syntax of above but without "FILE:" in the string
+ varName = trim( extractWord(trim(string(8:)), 3) )
+ if (varname == " ") call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID "// &
+ "Too few arguments in ("//trim(string)//")")
fileName = trim( extractWord(trim(string(8:)), 1) )
if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName )
- if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// &
- "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")")
+ if (.not. file_exists(fileName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID "// &
+ "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")")
varName = trim( extractWord(trim(string(8:)), 2) )
- if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// &
- "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
call MOM_read_data(trim(fileName), trim(varName), rho_target)
varName = trim( extractWord(trim(string(8:)), 3) )
if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz
call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz )
else ! Read dz from file
- if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// &
- "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
call MOM_read_data(trim(fileName), trim(varName), dz)
endif
if (main_parameters) then
call log_param(param_file, mdl, "!"//coord_res_param, dz, &
trim(message), units=coordinateUnits(coord_mode))
call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, &
- 'HYBRID target densities for interfaces', units=coordinateUnits(coord_mode))
+ 'HYBRID target densities for interfaces', units="kg m-3")
+ endif
+ elseif (index(trim(string),'HYBRID_3D:')==1) then
+ ke = GV%ke
+ allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0)
+ allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0)
+ ! The following assumes the FILE: syntax of above but without "FILE:" in the string
+ varName = trim( extractWord(trim(string(11:)), 3) )
+ if (varname == " ") call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_3D "// &
+ "Too few arguments in ("//trim(string)//")")
+ fileName = trim( extractWord(trim(string(11:)), 1) )
+ if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName )
+ if (.not. file_exists(fileName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_3D "// &
+ "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")")
+ varName = trim( extractWord(trim(string(11:)), 2) )
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_3D "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
+ call MOM_read_data(trim(fileName), trim(varName), rho_target_3d, G%Domain)
+ call pass_var(rho_target_3d, G%Domain, halo=1)
+ varName = trim( extractWord(trim(string(11:)), 3) )
+ if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz_3d
+ allocate(dz(ke))
+ call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz )
+ ! Adjust target grid to be consistent with maximum_depth
+ tmpReal = sum( dz(:) )
+ if (tmpReal < maximum_depth) then
+ dz(ke) = dz(ke) + ( maximum_depth - tmpReal )
+ endif
+ do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1
+ if (G%mask2dT(i,j)>0.) then
+ do k=1,ke
+ dz_3d(i,j,k) = dz(k)
+ enddo
+ endif !mask2dT
+ enddo ; enddo
+ if (main_parameters) then
+ call log_param(param_file, mdl, "!"//coord_res_param, dz, &
+ trim(message), units=coordinateUnits(coord_mode))
+ endif
+ else ! Read dz from file
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_3D "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
+ call MOM_read_data(trim(fileName), trim(varName), dz_3d, G%Domain)
+ call pass_var(dz_3d, G%Domain, halo=1)
+ ! set nominal 1-d dz to UNIFORM
+ allocate(dz(ke))
+ dz(:) = uniformResolution(ke, coord_mode, maximum_depth, &
+ US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), &
+ US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) )
+ endif !dz
+ elseif (index(trim(string),'HYBRID_MAP:')==1) then
+ ke = GV%ke
+ allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0)
+ allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0)
+ allocate(index_map(SZI_(G),SZJ_(G)), source=1.0)
+ ! The following assumes the FILE: syntax of above but without "FILE:" in the string
+ varName = trim( extractWord(trim(string(12:)), 4) )
+ if (varname == " ") call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_3D "// &
+ "Too few arguments in ("//trim(string)//")")
+ fileName = trim( extractWord(trim(string(12:)), 1) )
+ if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName )
+ if (.not. file_exists(fileName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_MAP "// &
+ "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")")
+ varName = trim( extractWord(trim(string(12:)), 2) )
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_MAP "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
+ call MOM_read_data(trim(fileName), trim(varName), index_map, G%Domain)
+ call pass_var(index_map, G%Domain, halo=1)
+ !find maximum index
+ np = 1
+ do j=G%jsc, G%jec ; do i=G%isc, G%iec
+ np = max(np,ceiling(index_map(i,j)))
+ enddo ; enddo
+ call max_across_PEs(np)
+ write(string2,"(i3)") np
+ call MOM_error(NOTE, &
+ trim(mdl)//", initialize_regridding: HYBRID_MAP NP="//trim(string2))
+ if (np<1) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_MAP to small NP from "//trim(varName))
+ allocate(dz_2d(ke,np))
+ allocate(rho_target_2d(ke+1,np))
+ varName = trim( extractWord(trim(string(12:)), 3) )
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_MAP "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
+ ! MOM_read_data can't handle this array
+ call read_variable(trim(fileName), trim(varName), rho_target_2d)
+ if (main_parameters) then
+ call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target_2d(:,1), &
+ 'HYBRID target densities for interfaces', units="kg m-3")
endif
+ do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1
+ if (G%mask2dT(i,j)>0.) then
+ nfloor = floor(index_map(i,j))
+ nceiling = ceiling(index_map(i,j))
+ if (nfloor<1 .or. nceiling>np) then
+ write(0,'(a,2i5,a,g20.6)') 'HYBRID_MAP: i,j=',i,j,'index_map(i,j)=', index_map(i,j)
+ call MOM_error(FATAL, trim(mdl)//", initialize_regridding: HYBRID_MAP "// &
+ "index_map out of range")
+ endif
+ if (nfloor == nceiling) then
+ do k=1,ke+1
+ rho_target_3d(i,j,k) = rho_target_2d(k,nfloor)
+ enddo
+ else
+ nfrac = index_map(i,j) - nfloor !between 0.0 and 1.0
+ do k=1,ke+1
+ rho_target_3d(i,j,k) = (1.0-nfrac)*rho_target_2d(k,nfloor) + &
+ nfrac *rho_target_2d(k,nceiling)
+ enddo
+ endif !integer:else
+ endif !mask2dT
+ enddo ; enddo
+ varName = trim( extractWord(trim(string(12:)), 4) )
+ if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz_3d
+ allocate(dz(ke))
+ call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz )
+ ! Adjust target grid to be consistent with maximum_depth
+ tmpReal = sum( dz(:) )
+ if (tmpReal < maximum_depth) then
+ dz(ke) = dz(ke) + ( maximum_depth - tmpReal )
+ endif
+ do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1
+ if (G%mask2dT(i,j)>0.) then
+ do k=1,ke
+ dz_3d(i,j,k) = dz(k)
+ enddo
+ endif !mask2dT
+ enddo ; enddo
+ if (main_parameters) then
+ call log_param(param_file, mdl, "!"//coord_res_param, dz, &
+ trim(message), units=coordinateUnits(coord_mode))
+ endif
+ else ! Read dz from file
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, &
+ trim(mdl)//", initialize_regridding: HYBRID_MAP "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
+ ! MOM_read_data can't handle this array
+ call read_variable(trim(fileName), trim(varName), dz_2d)
+ if (main_parameters) then
+ call log_param(param_file, mdl, "!"//coord_res_param, dz_2d(:,1), &
+ trim(message), units=coordinateUnits(coord_mode))
+ endif
+ do i=1,np
+ tmpReal = sum( dz_2d(:,i) )
+ if (tmpReal < maximum_depth) then
+ dz_2d(ke,i) = dz_2d(ke,i) + ( maximum_depth - tmpReal )
+ endif
+ enddo
+ allocate(dz(ke))
+ dz(:) = dz_2d(:,1)
+ if (main_parameters) then
+ call log_param(param_file, mdl, "!"//coord_res_param, dz, &
+ trim(message), units=coordinateUnits(coord_mode))
+ endif
+ do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1
+ if (G%mask2dT(i,j)>0.) then
+ nfloor = floor(index_map(i,j))
+ nceiling = ceiling(index_map(i,j))
+ if (nfloor == nceiling) then
+ do k=1,ke
+ dz_3d(i,j,k) = dz_2d(k,nfloor)
+ enddo
+ else
+ nfrac = index_map(i,j) - nfloor !between 0.0 and 1.0
+ do k=1,ke
+ dz_3d(i,j,k) = (1.0-nfrac)*dz_2d(k,nfloor) + &
+ nfrac *dz_2d(k,nceiling)
+ enddo
+ endif !integer:else
+ endif !mask2dT
+ enddo ; enddo
+ endif !dz
+ deallocate(index_map)
+ deallocate(rho_target_2d)
+ deallocate(dz_2d)
elseif (index(trim(string),'WOA09INT')==1) then
if (len_trim(string)==8) then ! string=='WOA09INT'
tmpReal = 0. ; ke = 0 ; dz_extra = 0.
@@ -557,7 +813,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
if (ke > size(woa09_dz_approx)) dz(ke) = dz_extra
else
call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "Unrecognized coordinate configuration"//trim(string))
+ "Unrecognized coordinate configuration"//trim(string))
endif
if (main_parameters) then
@@ -566,31 +822,116 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
coordinateMode(coord_mode) == REGRIDDING_HYCOM1 .or. &
coordinateMode(coord_mode) == REGRIDDING_HYBGEN .or. &
coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then
- ! Adjust target grid to be consistent with maximum_depth
- tmpReal = sum( dz(:) )
- if (tmpReal < maximum_depth) then
- dz(ke) = dz(ke) + ( maximum_depth - tmpReal )
- elseif (tmpReal > maximum_depth) then
- if ( dz(ke) + ( maximum_depth - tmpReal ) > 0. ) then
+ if (allocated(dz)) then
+ ! Adjust target grid to be consistent with maximum_depth
+ tmpReal = sum( dz(:) )
+ if (tmpReal < maximum_depth) then
dz(ke) = dz(ke) + ( maximum_depth - tmpReal )
- else
- call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "MAXIMUM_DEPTH was too shallow to adjust bottom layer of DZ!"//trim(string))
+ elseif (tmpReal > maximum_depth) then
+ if ( dz(ke) + ( maximum_depth - tmpReal ) > 0. ) then
+ dz(ke) = dz(ke) + ( maximum_depth - tmpReal )
+ else
+ call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
+ "MAXIMUM_DEPTH was too shallow to adjust bottom layer of DZ!"//trim(string))
+ endif
endif
- endif
+ endif !allocated(dz)
endif
endif
+ if (coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then
+ allocate(dz_shallow(ke))
+ call get_param(param_file, mdl, "SHALLOW_"//trim(coord_res_param), dz_shallow, &
+ "HYBGEN-style Z-sigma-Z near surface fixed coordinate. "//&
+ "The default of all zeros turns this option off. "//&
+ "Let N_SIGMA be the number of consecutive non-zero entries, typically < NK. "//&
+ "Use SHALLOW_"//trim(coord_res_param)//" when rest depth is shallower than "//&
+ "SUM(SHALLOW_"//trim(coord_res_param)//"(1:N_SIGMA)). "//&
+ "Use "//trim(coord_res_param)//" when rest depth is deeper than "//&
+ "SUM("//trim(coord_res_param)//"(1:N_SIGMA)). "//&
+ "Otherwise use a linear sum of the two weighted by rest depth.",&
+ units="m", default=0.0)
+ n_sigma = ke
+ depth_s = 0.0
+ do k= 1,ke
+ depth_s = depth_s + dz_shallow(k)
+ if (dz_shallow(k) == 0.0) then
+ n_sigma = k-1
+ exit
+ endif
+ enddo
+ if (n_sigma > 0) then
+ if (main_parameters) call log_param(param_file, mdl, "!N_SIGMA", n_sigma, &
+ "Number of consecutive non-zero entries in SHALLOW_"//&
+ trim(coord_res_param)//".")
+ if (.not.allocated(dz_3d)) then
+ allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0)
+ allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0)
+ do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1
+ if (G%mask2dT(i,j)>0.) then
+ do k=1,ke
+ dz_3d(i,j,k) = dz(k)
+ enddo
+ do k=1,ke+1
+ rho_target_3d(i,j,k) = rho_target(k)
+ enddo
+ endif !mask2dT
+ enddo ; enddo
+ endif
+ do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1
+ if (G%mask2dT(i,j)>0.) then
+ nominalDepth = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * US%Z_to_m
+ if (nominalDepth <= depth_s) then
+ do k= 1,n_sigma
+ dz_3d(i,j,k) = dz_shallow(k)
+ enddo
+ do k= n_sigma+1,ke
+ dz_3d(i,j,k) = dz_shallow(n_sigma)
+ enddo
+ else ! >depth_s
+ depth_d = 0.0
+ do k= 1,n_sigma
+ depth_d = depth_d + dz_3d(i,j,k)
+ enddo
+ ! do nothing if nominalDepth >= depth_d
+ if (nominalDepth < depth_d) then
+ depth_q = (nominalDepth - depth_s) / (depth_d - depth_s)
+ do k= 1,n_sigma
+ dz_3d(i,j,k) = (1.0-depth_q)*dz_shallow(k) + depth_q*dz_3d(i,j,k)
+ enddo
+ do k= n_sigma+1,ke
+ dz_3d(i,j,k) = (1.0-depth_q)*dz_shallow(n_sigma) + depth_q*dz_3d(i,j,k)
+ enddo
+ endif !depth_s
+ endif !nominalDepth
+ endif !mask2dT
+ enddo ; enddo
+ endif !n_sigma
+ deallocate(dz_shallow)
+ endif !REGRIDDING_HYCOM1
+
CS%nk=ke
! Target resolution (for fixed coordinates)
- allocate( CS%coordinateResolution(CS%nk), source=-1.E30 )
- if (state_dependent(CS%regridding_scheme)) then
- ! Target values
- allocate( CS%target_density(CS%nk+1), source=-1.E30*US%kg_m3_to_R )
+ if (allocated(dz_3d)) then
+ allocate( CS%coordinateResolution(CS%nk), source=-1.E30 )
+ allocate( CS%coordinateResolution_3d(SZI_(G),SZJ_(G),CS%nk), source=-1.E30 )
+ allocate( CS%target_density_3d(SZI_(G),SZJ_(G),CS%nk+1), source=-1.E30*US%kg_m3_to_R )
+ else
+ allocate( CS%coordinateResolution(CS%nk), source=-1.E30 )
+ if (state_dependent(CS%regridding_scheme)) then
+ ! Target values
+ allocate( CS%target_density(CS%nk+1), source=-1.E30*US%kg_m3_to_R )
+ endif
endif
- if (allocated(dz)) then
+ if (allocated(dz_3d)) then
+ ! set both 1d and 3d fields
+ call setCoordinateResolution(dz, CS, scale=US%m_to_Z)
+ call setCoordinateResolution_3d(dz_3d, CS, scale=US%m_to_Z)
+ CS%coord_scale = US%Z_to_m
+ deallocate(dz_3d)
+ elseif (allocated(dz)) then
if (coordinateMode(coord_mode) == REGRIDDING_SIGMA) then
call setCoordinateResolution(dz, CS, scale=1.0)
elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then
@@ -612,39 +953,42 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
! ensure CS%ref_pressure is rescaled properly
CS%ref_pressure = US%Pa_to_RL2_T2 * CS%ref_pressure
- if (allocated(rho_target)) then
+ if (allocated(rho_target_3d)) then
+ call set_target_densities_3d(CS, G, US%kg_m3_to_R, rho_target_3d)
+ deallocate(rho_target_3d)
+ elseif (allocated(rho_target)) then
call set_target_densities(CS, US%kg_m3_to_R*rho_target)
deallocate(rho_target)
-
- ! \todo This line looks like it would overwrite the target densities set just above?
elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then
call set_target_densities_from_GV(GV, US, CS)
call log_param(param_file, mdl, "!TARGET_DENSITIES", US%R_to_kg_m3*CS%target_density(:), &
- 'RHO target densities for interfaces', units=coordinateUnits(coord_mode))
+ 'RHO target densities for interfaces', "kg m-3")
endif
! initialise coordinate-specific control structure
- call initCoord(CS, GV, US, coord_mode, param_file)
+ call initCoord(CS, G, GV, US, coord_mode, param_file)
if (coord_is_state_dependent) then
if (main_parameters) then
- call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), P_Ref, &
+ call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), &
+ P_Ref, &
"The pressure that is used for calculating the coordinate "//&
"density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//&
"This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", &
units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2)
else
- call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), P_Ref, &
- "The pressure that is used for calculating the diagnostic coordinate "//&
- "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//&
- "This is only used for the RHO coordinate.", &
- units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2)
+ call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), &
+ P_Ref, &
+ "The pressure that is used for calculating the diagnostic coordinate "//&
+ "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//&
+ "This is only used for the RHO coordinate.", &
+ units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2)
endif
- call get_param(param_file, mdl, create_coord_param(param_prefix, "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), &
- tmpReal, &
- "When interpolating potential density profiles we can add "//&
- "some artificial compressibility solely to make homogeneous "//&
- "regions appear stratified.", units="nondim", default=0.)
+ call get_param(param_file, mdl, create_coord_param(param_prefix, &
+ "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), tmpReal, &
+ "When interpolating potential density profiles we can add "//&
+ "some artificial compressibility solely to make homogeneous "//&
+ "regions appear stratified.", units="nondim", default=0.)
call set_regrid_params(CS, compress_fraction=tmpReal, ref_pressure=P_Ref)
endif
@@ -654,14 +998,20 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
"thickness allowed.", units="m", scale=GV%m_to_H, &
default=regriddingDefaultMinThickness )
call set_regrid_params(CS, min_thickness=tmpReal)
+ call get_param(param_file, mdl, "USE_ADJUST_INTERFACE_MOTION", tmpLogical, &
+ "When regridding, after the primary grid generation, call a function that ensures "//&
+ "positive layer thicknesses. Historically, this was required.", default=.true.)
+ call set_regrid_params(CS, use_adjust_interface_motion=tmpLogical)
else
call set_regrid_params(CS, min_thickness=0.)
+ call set_regrid_params(CS, use_adjust_interface_motion=.true.)
+ call set_regrid_params(CS, use_depth_based_time_filter=.true.)
endif
if (main_parameters .and. coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then
call get_param(param_file, mdl, "HYCOM1_ONLY_IMPROVES", tmpLogical, &
- "When regridding, an interface is only moved if this improves the fit to the target density.", &
- default=.false.)
+ "When regridding, an interface is only moved if this improves "//&
+ "the fit to the target density.", default=.false.)
call set_hycom_params(CS%hycom_CS, only_improves=tmpLogical)
endif
@@ -724,19 +1074,21 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
! Otherwise assume we should look for the file in INPUTDIR
fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) )
endif
- if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")")
+ if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)// &
+ ", initialize_regridding: "// &
+ "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")")
do_sum = .false.
varName = trim( extractWord(trim(string(6:)), 2) )
- if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)// &
+ ", initialize_regridding: "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")")
if (len_trim(varName)==0) then
- if (field_exists(fileName,'z_max')) then; varName = 'z_max'
- elseif (field_exists(fileName,'dz')) then; varName = 'dz' ; do_sum = .true.
- elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' ; do_sum = .true.
+ if (field_exists(fileName,'z_max')) then ; varName = 'z_max'
+ elseif (field_exists(fileName,'dz')) then ; varName = 'dz' ; do_sum = .true.
+ elseif (field_exists(fileName,'dz_max')) then ; varName = 'dz_max' ; do_sum = .true.
else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.")
+ "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.")
endif
endif
if (do_sum) then
@@ -756,7 +1108,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
call set_regrid_max_depths(CS, z_max, GV%m_to_H)
else
call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "Unrecognized MAXIMUM_INT_DEPTH_CONFIG "//trim(string))
+ "Unrecognized MAXIMUM_INT_DEPTH_CONFIG "//trim(string))
endif
deallocate(z_max)
deallocate(dz_max)
@@ -789,17 +1141,19 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
! Otherwise assume we should look for the file in INPUTDIR
fileName = trim(inputdir) // trim( extractWord(trim(longString(6:200)), 1) )
endif
- if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(longString)//")")
+ if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)// &
+ ", initialize_regridding: "// &
+ "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(longString)//")")
varName = trim( extractWord(trim(longString(6:)), 2) )
- if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(longString)//")")
+ if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)// &
+ ", initialize_regridding: "// &
+ "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(longString)//")")
if (len_trim(varName)==0) then
- if (field_exists(fileName,'h_max')) then; varName = 'h_max'
- elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max'
+ if (field_exists(fileName,'h_max')) then ; varName = 'h_max'
+ elseif (field_exists(fileName,'dz_max')) then ; varName = 'dz_max'
else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.")
+ "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.")
endif
endif
call MOM_read_data(trim(fileName), trim(varName), h_max)
@@ -813,7 +1167,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m
call set_regrid_max_thickness(CS, h_max, GV%m_to_H)
else
call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// &
- "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(longString))
+ "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(longString))
endif
deallocate(h_max)
endif
@@ -835,6 +1189,8 @@ subroutine end_regridding(CS)
if (associated(CS%hybgen_CS)) call end_hybgen_regrid(CS%hybgen_CS)
deallocate( CS%coordinateResolution )
+ if (allocated(CS%coordinateResolution_3d)) deallocate( CS%coordinateResolution_3d )
+ if (allocated(CS%target_density_3d)) deallocate( CS%target_density_3d )
if (allocated(CS%target_density)) deallocate( CS%target_density )
if (allocated(CS%max_interface_depths) ) deallocate( CS%max_interface_depths )
if (allocated(CS%max_layer_thickness) ) deallocate( CS%max_layer_thickness )
@@ -875,7 +1231,7 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, &
!! coordinate [H ~> m or kg m-2]
real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each
!! interface [H ~> m or kg m-2]
- real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage [nomdim]
+ real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage [nondim]
logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true
@@ -910,15 +1266,15 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, &
tot_dz(i,j) = tot_dz(i,j) + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h(i,j,k)
enddo ; enddo ; enddo
do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1
- if ((tot_dz(i,j) > 0.0) .and. (G%bathyT(i,j)+G%Z_ref > 0.0)) then
- nom_depth_H(i,j) = (G%bathyT(i,j)+G%Z_ref) * (tot_h(i,j) / tot_dz(i,j))
+ if (tot_dz(i,j) > 0.0) then
+ nom_depth_H(i,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * (tot_h(i,j) / tot_dz(i,j))
else
nom_depth_H(i,j) = 0.0
endif
enddo ; enddo
else
do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1
- nom_depth_H(i,j) = max((G%bathyT(i,j)+G%Z_ref) * Z_to_H, 0.0)
+ nom_depth_H(i,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H
enddo ; enddo
endif
@@ -1071,7 +1427,7 @@ subroutine check_grid_column( nk, h, dzInterface, msg )
write(0,*) 'k,h,hnew=',k,h(k),h_new
write(0,*) 'dzI(k+1),dzI(k)=',dzInterface(k+1),dzInterface(k)
call MOM_error( FATAL, 'MOM_regridding, check_grid_column: '//&
- 'Negative layer thickness implied by re-gridding, '//trim(msg))
+ 'Negative layer thickness implied by re-gridding, '//trim(msg))
endif
total_h_new = total_h_new + h_new
@@ -1086,14 +1442,14 @@ subroutine check_grid_column( nk, h, dzInterface, msg )
write(0,*) 'Hold,Hnew,Hnew-Hold=',total_h_old,total_h_new,total_h_new-total_h_old
write(0,*) 'eps,(n)/2*eps*H=',eps,real(nk-1)*0.5*(total_h_old+total_h_new)*eps
call MOM_error( FATAL, 'MOM_regridding, check_grid_column: '//&
- 'Re-gridding did NOT conserve total thickness to within roundoff '//trim(msg))
+ 'Re-gridding did NOT conserve total thickness to within roundoff '//trim(msg))
endif
! Check that the top and bottom are intentionally moving
if (dzInterface(1) /= 0.) call MOM_error( FATAL, &
- 'MOM_regridding, check_grid_column: Non-zero dzInterface at surface! '//trim(msg))
+ 'MOM_regridding, check_grid_column: Non-zero dzInterface at surface! '//trim(msg))
if (dzInterface(nk+1) /= 0.) call MOM_error( FATAL, &
- 'MOM_regridding, check_grid_column: Non-zero dzInterface at bottom! '//trim(msg))
+ 'MOM_regridding, check_grid_column: Non-zero dzInterface at bottom! '//trim(msg))
end subroutine check_grid_column
@@ -1149,11 +1505,11 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g )
if (debug) then
do k=2,CS%nk+1
if (sgn*(z_new(k)-z_new(k-1)) < -5e-16*(abs(z_new(k))+abs(z_new(k-1))) ) &
- call MOM_error(FATAL, "filtered_grid_motion: z_new is tangled.")
+ call MOM_error(FATAL, "filtered_grid_motion: z_new is tangled.")
enddo
do k=2,nk+1
if (sgn*(z_old(k)-z_old(k-1)) < -5e-16*(abs(z_old(k))+abs(z_old(k-1))) ) &
- call MOM_error(FATAL, "filtered_grid_motion: z_old is tangled.")
+ call MOM_error(FATAL, "filtered_grid_motion: z_old is tangled.")
enddo
! ddz_g_s(:) = 0.0 ; ddz_g_d(:) = 0.0
endif
@@ -1227,9 +1583,9 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g )
! ddz_g_d(k) = sgn * (dz0 + 2.0*F0*dzwt / (Bq + sqrt(Bq**2 + 4.0*Aq*F0*dzwt) )) - dz_g(k)
!
! if (abs(ddz_g_s(k)) > 1e-12*(abs(dz_g(k)) + abs(dz_g(k)+ddz_g_s(k)))) &
-! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled (sc).")
+! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled (sc).")
! if (abs(ddz_g_d(k) - ddz_g_s(k)) > 1e-12*(abs(dz_g(k)+ddz_g_d(k)) + abs(dz_g(k)+ddz_g_s(k)))) &
-! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled.")
+! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled.")
! endif
endif
@@ -1245,7 +1601,7 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g )
enddo
do k=2,CS%nk+1
if (sgn*((z_act(k))-z_act(k-1)) < -1e-15*(abs(z_act(k))+abs(z_act(k-1))) ) &
- call MOM_error(FATAL, "filtered_grid_motion: z_output is tangled.")
+ call MOM_error(FATAL, "filtered_grid_motion: z_output is tangled.")
enddo
endif
@@ -1334,7 +1690,8 @@ subroutine build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_
endif
! Calculate the final change in grid position after blending new and old grids
- call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) )
+ if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) &
+ call filtered_grid_motion(CS, nz, zOld, zNew, dzInterface(i,j,:))
#ifdef __DO_SAFETY_CHECKS__
dh = max(nominalDepth,totalThickness)
@@ -1359,7 +1716,7 @@ subroutine build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_
endif
#endif
- call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) )
+ if (CS%use_adjust_interface_motion) call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) )
enddo
enddo
@@ -1433,7 +1790,8 @@ subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface )
zOld(k) = zOld(k+1) + h(i,j,k)
enddo
- call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) )
+ if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) &
+ call filtered_grid_motion(CS, nz, zOld, zNew, dzInterface(i,j,:))
#ifdef __DO_SAFETY_CHECKS__
dh = max(nominalDepth,totalThickness)
@@ -1448,10 +1806,12 @@ subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface )
write(0,*) k,zOld(nz+1),zNew(k)
enddo
do k=1,min(nz,CS%nk)
- write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k)
+ write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k), &
+ CS%coordinateResolution(k)
enddo
do k=min(nz,CS%nk)+1,CS%nk
- write(0,*) k,0.0,zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k)
+ write(0,*) k,0.0,zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k), &
+ CS%coordinateResolution(k)
enddo
call MOM_error( FATAL, &
'MOM_regridding, build_sigma_grid: top surface has moved!!!' )
@@ -1578,7 +1938,8 @@ subroutine build_rho_grid( G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS,
endif
! Calculate the final change in grid position after blending new and old grids
- call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) )
+ if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) &
+ call filtered_grid_motion(CS, nz, zOld, zNew, dzInterface(i,j,:))
#ifdef __DO_SAFETY_CHECKS__
do k=2,CS%nk
@@ -1635,7 +1996,8 @@ end subroutine build_rho_grid
!! \remark { Based on Bleck, 2002: An ocean-ice general circulation model framed in
!! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88.
!! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 }
-subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h, zScale )
+subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, &
+ frac_shelf_h, zScale )
type(ocean_grid_type), intent(in) :: G !< Grid structure
type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
@@ -1701,17 +2063,18 @@ subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface,
( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref )
enddo
- call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, nominalDepth, &
+ call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, i, j, nominalDepth, &
h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, &
z_col, z_col_new, zScale=zScale, &
h_neglect=h_neglect, h_neglect_edge=h_neglect_edge)
! Calculate the final change in grid position after blending new and old grids
- call filtered_grid_motion( CS, GV%ke, z_col, z_col_new, dz_col )
+ if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) &
+ call filtered_grid_motion( CS, GV%ke, z_col, z_col_new, dz_col )
! This adjusts things robust to round-off errors
dz_col(:) = -dz_col(:)
- call adjust_interface_motion( CS, GV%ke, h(i,j,:), dz_col(:) )
+ if (CS%use_adjust_interface_motion) call adjust_interface_motion( CS, GV%ke, h(i,j,:), dz_col(:) )
dzInterface(i,j,1:nki+1) = dz_col(1:nki+1)
if (nki0.) &
+ call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:))
! convert from depth to z
do K = 1, nz+1 ; dzInterface(i,j,K) = -dzInterface(i,j,K) ; enddo
- call adjust_interface_motion(CS, nz, h(i,j,:), dzInterface(i,j,:))
+ if (CS%use_adjust_interface_motion) call adjust_interface_motion(CS, nz, h(i,j,:), dzInterface(i,j,:))
enddo ; enddo
end subroutine build_grid_adaptive
@@ -1816,8 +2181,8 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int )
h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) )
if (h_new < -3.0*h_err) then
write(0,*) 'h<0 at k=',k,'h_old=',h_old(k), &
- 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), &
- 'h_new=',h_new,'h_err=',h_err
+ 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), &
+ 'h_new=',h_new,'h_err=',h_err
call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//&
'implied h<0 is larger than roundoff!')
endif
@@ -1828,8 +2193,8 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int )
h_new = ( dz_int(k) - dz_int(k+1) )
if (h_new < -3.0*h_err) then
write(0,*) 'h<0 at k=',k,'h_old was empty',&
- 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), &
- 'h_new=',h_new,'h_err=',h_err
+ 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), &
+ 'h_new=',h_new,'h_err=',h_err
call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//&
'implied h<0 is larger than roundoff!')
endif
@@ -1838,14 +2203,14 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int )
do k = min(CS%nk,nk),2,-1
h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) )
if (h_new Initialize the coordinate resolutions by calling the appropriate initialization
!! routine for the specified coordinate mode.
-subroutine initCoord(CS, GV, US, coord_mode, param_file)
+subroutine initCoord(CS, G, GV, US, coord_mode, param_file)
type(regridding_CS), intent(inout) :: CS !< Regridding control structure
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode.
!! See the documentation for regrid_consts
!! for the recognized values.
- type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(param_file_type), intent(in) :: param_file !< Parameter file
select case (coordinateMode(coord_mode))
@@ -2033,8 +2400,14 @@ subroutine initCoord(CS, GV, US, coord_mode, param_file)
case (REGRIDDING_RHO)
call init_coord_rho(CS%rho_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS)
case (REGRIDDING_HYCOM1)
- call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, &
- CS%interp_CS)
+ if (allocated(CS%coordinateResolution_3d)) then
+ call init_3d_coord_hycom(CS%hycom_CS, G, CS%nk, &
+ CS%coordinateResolution_3d, CS%target_density_3d, &
+ CS%interp_CS)
+ else
+ call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, &
+ CS%interp_CS)
+ endif
case (REGRIDDING_HYBGEN)
call init_hybgen_regrid(CS%hybgen_CS, GV, US, param_file)
case (REGRIDDING_ADAPTIVE)
@@ -2065,6 +2438,26 @@ subroutine setCoordinateResolution( dz, CS, scale )
end subroutine setCoordinateResolution
+!> Set the 3d fixed resolution data
+subroutine setCoordinateResolution_3d( dz_3d, CS, scale )
+ real, dimension(:,:,:), intent(in) :: dz_3d !< A vector of vertical grid spacings, in arbitrary coordinate
+ !! dependent units, such as [m] for a z-coordinate or [kg m-3]
+ !! for a density coordinate.
+ type(regridding_CS), intent(inout) :: CS !< Regridding control structure
+ real, optional, intent(in) :: scale !< A scaling factor converting dz to coordRes [Z m-1 ~> 1]
+
+ if (.not.allocated(CS%coordinateResolution_3d)) &
+ call MOM_error(FATAL,'setCoordinateResolution_3d: '//&
+ 'CS%coordinateResolution_3d not allocated.')
+
+ if (present(scale)) then
+ CS%coordinateResolution_3d(:,:,:) = scale*dz_3d(:,:,:)
+ else
+ CS%coordinateResolution_3d(:,:,:) = dz_3d(:,:,:)
+ endif
+
+end subroutine setCoordinateResolution_3d
+
!> Set target densities based on the old Rlay variable
subroutine set_target_densities_from_GV( GV, US, CS )
type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
@@ -2088,6 +2481,22 @@ subroutine set_target_densities_from_GV( GV, US, CS )
end subroutine set_target_densities_from_GV
+!> Set target densities based on vector of interface values
+subroutine set_target_densities_3d( CS, G, scale, rho_int_3d )
+ type(regridding_CS), intent(inout) :: CS !< Regridding control structure
+ type(ocean_grid_type),intent(in) :: G !< Ocean grid structure
+ real, intent(in) :: scale !< A scaling factor converting densities [R m3 kg-1 ~> 1]
+ real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: rho_int_3d !< Interface densities [kg m-3]
+
+ if (.not.allocated(CS%target_density_3d)) &
+ call MOM_error(FATAL,'set_target_densities_3d: '//&
+ 'CS%target_density_3d not allocated.')
+
+ CS%target_density_3d(:,:,:) = scale * rho_int_3d(:,:,:)
+ CS%target_density_set = .true.
+
+end subroutine set_target_densities_3d
+
!> Set target densities based on vector of interface values
subroutine set_target_densities( CS, rho_int )
type(regridding_CS), intent(inout) :: CS !< Regridding control structure
@@ -2120,12 +2529,14 @@ subroutine set_regrid_max_depths( CS, max_depths, units_to_H )
! Check for sign reversals in the depths.
if (max_depths(CS%nk+1) < max_depths(1)) then
- do K=1,CS%nk ; if (max_depths(K+1) > max_depths(K)) &
- call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths!")
+ do K=1,CS%nk
+ if (max_depths(K+1) > max_depths(K)) &
+ call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths!")
enddo
else
- do K=1,CS%nk ; if (max_depths(K+1) < max_depths(K)) &
- call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths.")
+ do K=1,CS%nk
+ if (max_depths(K+1) < max_depths(K)) &
+ call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths.")
enddo
endif
@@ -2285,8 +2696,8 @@ function getCoordinateInterfaces( CS, undo_scaling )
! densities, rather than computing the interfaces based on resolution
if (CS%regridding_scheme == REGRIDDING_RHO) then
if (.not. CS%target_density_set) &
- call MOM_error(FATAL, 'MOM_regridding, getCoordinateInterfaces: '//&
- 'target densities not set!')
+ call MOM_error(FATAL, 'MOM_regridding, getCoordinateInterfaces: '//&
+ 'target densities not set!')
if (unscale) then
getCoordinateInterfaces(:) = CS%coord_scale * CS%target_density(:)
@@ -2373,18 +2784,21 @@ end function getCoordinateShortName
!> Can be used to set any of the parameters for MOM_regridding.
subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_grid_weight, &
- interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, &
- compress_fraction, ref_pressure, &
+ use_depth_based_time_filter, depth_of_time_filter_shallow, depth_of_time_filter_deep, &
+ interp_scheme, use_adjust_interface_motion, compress_fraction, ref_pressure, &
integrate_downward_for_e, remap_answers_2018, remap_answer_date, regrid_answer_date, &
- adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0)
+ adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, &
+ adaptAlpha, adaptDoMin, adaptDrho0)
type(regridding_CS), intent(inout) :: CS !< Regridding control structure
logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells
real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the
!! new grid [H ~> m or kg m-2]
real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid [nondim]
- character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates
+ logical, optional, intent(in) :: use_depth_based_time_filter !< Allow depth-based time filtering
real, optional, intent(in) :: depth_of_time_filter_shallow !< Depth to start cubic [H ~> m or kg m-2]
real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic [H ~> m or kg m-2]
+ character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates
+ logical, optional, intent(in) :: use_adjust_interface_motion !< Call adjust_interface_motion()
real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density [nondim]
real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent
!! coordinates [R L2 T-2 ~> Pa]
@@ -2415,14 +2829,20 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri
call MOM_error(FATAL,'MOM_regridding, set_regrid_params: Weight is out side the range 0..1!')
CS%old_grid_weight = old_grid_weight
endif
- if (present(depth_of_time_filter_shallow)) CS%depth_of_time_filter_shallow = depth_of_time_filter_shallow
- if (present(depth_of_time_filter_deep)) CS%depth_of_time_filter_deep = depth_of_time_filter_deep
+ if (present(use_depth_based_time_filter)) CS%use_depth_based_time_filter = &
+ use_depth_based_time_filter
+ if (present(depth_of_time_filter_shallow)) CS%depth_of_time_filter_shallow = &
+ depth_of_time_filter_shallow
+ if (present(depth_of_time_filter_deep)) CS%depth_of_time_filter_deep = &
+ depth_of_time_filter_deep
if (present(depth_of_time_filter_shallow) .or. present(depth_of_time_filter_deep)) then
- if (CS%depth_of_time_filter_deep m]
select case ( CS%regridding_scheme )
- case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, &
- REGRIDDING_ADAPTIVE )
+ case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, &
+ REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE )
if (depth>0.) then
z = ssh
do k = 1, CS%nk
diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90
index 7a8d886ab7..c81dfc72b0 100644
--- a/src/ALE/MOM_remapping.F90
+++ b/src/ALE/MOM_remapping.F90
@@ -1,7 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides column-wise vertical remapping functions
module MOM_remapping
-! This file is part of MOM6. See LICENSE.md for the license.
! Original module written by Laurent White, 2008.06.09
use MOM_error_handler, only : MOM_error, FATAL
@@ -35,6 +38,7 @@ module MOM_remapping
use Recon1d_EPPM_CWK, only : EPPM_CWK_type => EPPM_CWK
use Recon1d_PPM_H4_2019, only : PPM_H4_2019_type => PPM_H4_2019
use Recon1d_PPM_H4_2018, only : PPM_H4_2018_type => PPM_H4_2018
+use Recon1d_PLM_WLS, only : PLM_WLS_type => PLM_WLS
implicit none ; private
@@ -436,7 +440,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, &
integer :: k, n
logical :: deb ! Do debugging
- deb=.false.; if (present(debug)) deb=debug
+ deb = .false. ; if (present(debug)) deb = debug
h_neg_edge = h_neglect ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge
@@ -574,12 +578,12 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, &
u_min = min(u_l, u_c)
u_max = max(u_l, u_c)
if (ppoly_r_E(i0,1) < u_min) then
- write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge undershoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, &
+ write(0,'(a,I0,5(1x,a,1pe24.16))') 'Left edge undershoot at ',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, &
'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min
problem_detected = .true.
endif
if (ppoly_r_E(i0,1) > u_max) then
- write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge overshoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, &
+ write(0,'(a,I0,5(1x,a,1pe24.16))') 'Left edge overshoot at ',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, &
'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max
problem_detected = .true.
endif
@@ -588,19 +592,19 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, &
u_min = min(u_c, u_r)
u_max = max(u_c, u_r)
if (ppoly_r_E(i0,2) < u_min) then
- write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge undershoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, &
+ write(0,'(a,I0,5(1x,a,1pe24.16))') 'Right edge undershoot at ',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, &
'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min
problem_detected = .true.
endif
if (ppoly_r_E(i0,2) > u_max) then
- write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge overshoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, &
+ write(0,'(a,I0,5(1x,a,1pe24.16))') 'Right edge overshoot at ',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, &
'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max
problem_detected = .true.
endif
endif
if (i0 > 1) then
if ( (u_c-u_l)*(ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2)) < 0.) then
- write(0,'(a,i4,5(1x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, &
+ write(0,'(a,I0,5(1x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, &
'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1)
write(0,'(5(a,1pe24.16,1x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2)
problem_detected = .true.
@@ -611,7 +615,7 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, &
write(0,'(3(a,1pe24.16,1x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r
write(0,'(a4,10a24)') 'i0','h0(i0)','u0(i0)','left edge','right edge','Polynomial coefficients'
do n = 1, n0
- write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:)
+ write(0,'(I0,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:)
enddo
call MOM_error(FATAL, 'MOM_remapping, check_reconstructions_1d: '// &
'Edge values or polynomial coefficients were inconsistent!')
@@ -1792,6 +1796,9 @@ subroutine setReconstructionType(string,CS)
case ("C_PPM_H4_2018")
allocate( PPM_H4_2018_type :: CS%reconstruction )
CS%remapping_scheme = REMAPPING_VIA_CLASS
+ case ("C_PLM_WLS")
+ allocate( PLM_WLS_type :: CS%reconstruction )
+ CS%remapping_scheme = REMAPPING_VIA_CLASS
case default
call MOM_error(FATAL, "setReconstructionType: "//&
"Unrecognized choice for REMAPPING_SCHEME ("//trim(string)//").")
@@ -1861,7 +1868,7 @@ subroutine test_recon_consistency(test, scheme, n0, niter, h_neglect)
integer :: iter ! Loop counter
integer :: seed_size ! Number of integers used by seed
integer, allocatable :: seed(:) ! Random number seed
- character(len=8) :: label ! Generated label
+ character(len=16) :: label ! Generated label
call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, &
force_bounds_in_subcell=.false. )
@@ -1889,8 +1896,8 @@ subroutine test_recon_consistency(test, scheme, n0, niter, h_neglect)
enddo
- write(label(1:8),'(i8)') niter
- call test%test( error, trim(adjustl(label))//' consistency tests of '//scheme )
+ write(label,'(I0)') niter
+ call test%test( error, trim(label)//' consistency tests of '//scheme )
call remapCS%reconstruction%destroy()
@@ -1911,7 +1918,7 @@ subroutine test_preserve_uniform(test, scheme, n0, niter, h_neglect)
integer :: iter ! Loop counter
integer :: seed_size ! Number of integers used by seed
integer, allocatable :: seed(:) ! Random number seed
- character(len=8) :: label ! Generated label
+ character(len=16) :: label ! Generated label
call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, &
force_bounds_in_subcell=.true., &
@@ -1947,8 +1954,8 @@ subroutine test_preserve_uniform(test, scheme, n0, niter, h_neglect)
enddo
- write(label(1:8),'(i8)') niter
- call test%test( error, trim(adjustl(label))//' uniformity tests of '//scheme )
+ write(label,'(I0)') niter
+ call test%test( error, trim(label)//' uniformity tests of '//scheme )
end subroutine test_preserve_uniform
@@ -1970,7 +1977,7 @@ subroutine test_unchanged_grid(test, scheme, n0, niter, h_neglect)
real :: u0(n0), u1(n0) ! Source and target values [A]
logical :: error ! Indicates a divergence
integer :: iter ! Loop counter
- character(len=8) :: label ! Generated label
+ character(len=16) :: label ! Generated label
call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, &
force_bounds_in_subcell=.true., &
@@ -2000,8 +2007,8 @@ subroutine test_unchanged_grid(test, scheme, n0, niter, h_neglect)
enddo
- write(label(1:8),'(i8)') niter
- call test%test( error, trim(adjustl(label))//' unchanged grid tests of '//scheme )
+ write(label,'(I0)') niter
+ call test%test( error, trim(label)//' unchanged grid tests of '//scheme )
call remapCS%reconstruction%destroy()
@@ -2025,7 +2032,7 @@ subroutine compare_two_schemes(test, CS1, CS2, n0, n1, niter, msg)
integer :: iter ! Loop counter
integer :: seed_size ! Number of integers used by seed
integer, allocatable :: seed(:) ! Random number seed
- character(len=8) :: label ! Generated label
+ character(len=16) :: label ! Generated label
call random_seed(size=seed_size)
allocate( seed(seed_Size) )
@@ -2061,8 +2068,8 @@ subroutine compare_two_schemes(test, CS1, CS2, n0, n1, niter, msg)
endif
enddo
- write(label(1:8),'(i8)') niter
- call test%test( error, trim(adjustl(label))//' comparisons of '//msg )
+ write(label,'(I0)') niter
+ call test%test( error, trim(label)//' comparisons of '//msg )
end subroutine compare_two_schemes
@@ -2111,6 +2118,7 @@ logical function remapping_unit_tests(verbose, num_comp_samp)
type(PPM_hybgen_type) :: PPM_hybgen
type(PPM_CWK_type) :: PPM_CWK
type(EPPM_CWK_type) :: EPPM_CWK
+ type(PLM_WLS_type) :: PLM_WLS
call test%set( verbose=verbose ) ! Sets the verbosity flag in test
! call test%set( stop_instantly=.true. ) ! While debugging
@@ -2740,6 +2748,7 @@ logical function remapping_unit_tests(verbose, num_comp_samp)
call test%test( PPM_CW%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CW unit test')
call test%test( PPM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CWK unit test')
call test%test( EPPM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'EPPM_CWK unit test')
+ call test%test( PLM_WLS%unit_tests(verbose, test%stdout, test%stderr), 'PLM_WLS unit test')
! Randomized, brute force tests
ntests = 3000
@@ -2769,6 +2778,7 @@ logical function remapping_unit_tests(verbose, num_comp_samp)
call test_recon_consistency(test, 'C_PPM_CW', n0, ntests, h_neglect)
call test_recon_consistency(test, 'C_PPM_CWK', n0, ntests, h_neglect)
call test_recon_consistency(test, 'C_EPPM_CWK', n0, ntests, h_neglect)
+ call test_recon_consistency(test, 'C_PLM_WLS', n0, ntests, h_neglect)
call test_preserve_uniform(test, 'PCM', n0, ntests, h_neglect)
call test_preserve_uniform(test, 'C_PCM', n0, ntests, h_neglect)
@@ -2795,6 +2805,7 @@ logical function remapping_unit_tests(verbose, num_comp_samp)
call test_preserve_uniform(test, 'C_PPM_CW', n0, ntests, h_neglect)
call test_preserve_uniform(test, 'C_PPM_CWK', n0, ntests, h_neglect)
call test_preserve_uniform(test, 'C_EPPM_CWK', n0, ntests, h_neglect)
+ call test_preserve_uniform(test, 'C_PLM_WLS', n0, ntests, h_neglect)
call test_unchanged_grid(test, 'C_PCM', n0, ntests, h_neglect)
call test_unchanged_grid(test, 'C_PLM_CW', n0, ntests, h_neglect)
@@ -2806,6 +2817,7 @@ logical function remapping_unit_tests(verbose, num_comp_samp)
call test_unchanged_grid(test, 'C_PPM_CW', n0, ntests, h_neglect)
call test_unchanged_grid(test, 'C_PPM_CWK', n0, ntests, h_neglect)
call test_unchanged_grid(test, 'C_EPPM_CWK', n0, ntests, h_neglect)
+ call test_unchanged_grid(test, 'C_PLM_WLS', n0, ntests, h_neglect)
! Check that remapping to the exact same grid leaves values unchanged
allocate( h0(8), u0(8) )
diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90
index d2051cc702..510ebde12c 100644
--- a/src/ALE/P1M_functions.F90
+++ b/src/ALE/P1M_functions.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Linear interpolation functions
module P1M_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
use regrid_edge_values, only : bound_edge_values, average_discontinuous_edge_values
implicit none ; private
diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90
index e9c234db32..e07cd9640f 100644
--- a/src/ALE/P3M_functions.F90
+++ b/src/ALE/P3M_functions.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Cubic interpolation functions
module P3M_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
use regrid_edge_values, only : bound_edge_values, average_discontinuous_edge_values
implicit none ; private
diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90
index f5899339e4..dff25e5fc6 100644
--- a/src/ALE/PCM_functions.F90
+++ b/src/ALE/PCM_functions.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise constant reconstruction functions
module PCM_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public PCM_reconstruction
diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90
index 6d6afd3885..ab70541747 100644
--- a/src/ALE/PLM_functions.F90
+++ b/src/ALE/PLM_functions.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise linear reconstruction functions
module PLM_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public PLM_boundary_extrapolation
diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90
index c11ec6e741..ad8fe2adb6 100644
--- a/src/ALE/PPM_functions.F90
+++ b/src/ALE/PPM_functions.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides functions used with the Piecewise-Parabolic-Method in the vertical ALE algorithm.
module PPM_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
! First version was created by Laurent White, June 2008.
! Substantially re-factored January 2016.
diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90
index 418a4b47a2..d0bd58a9fe 100644
--- a/src/ALE/PQM_functions.F90
+++ b/src/ALE/PQM_functions.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise quartic reconstruction functions
module PQM_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
use regrid_edge_values, only : bound_edge_values, check_discontinuous_edge_values
implicit none ; private
diff --git a/src/ALE/Recon1d_EMPLM_CWK.F90 b/src/ALE/Recon1d_EMPLM_CWK.F90
index 01d97058a9..bcd06c3f6f 100644
--- a/src/ALE/Recon1d_EMPLM_CWK.F90
+++ b/src/ALE/Recon1d_EMPLM_CWK.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Linear Method 1D reconstruction in index space and boundary extrapolation
!!
!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, except for assuming
@@ -7,8 +11,6 @@
!! cell (i.e. extrapolates from the interior).
module Recon1d_EMPLM_CWK
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : testing
use Recon1d_MPLM_CWK, only : MPLM_CWK
diff --git a/src/ALE/Recon1d_EMPLM_WA.F90 b/src/ALE/Recon1d_EMPLM_WA.F90
index fc46cf74f6..b72203e0f0 100644
--- a/src/ALE/Recon1d_EMPLM_WA.F90
+++ b/src/ALE/Recon1d_EMPLM_WA.F90
@@ -1,11 +1,13 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Extrapolated-Monotonized Piecewise Linear Method 1D reconstruction
!!
!! This extends MPLM_WA, following White and Adcroft, 2008 \cite white2008, by extrapolating for the slopes of the
!! first and last cells. This extrapolation is used by White et al., 2009, during grid-generation.
module Recon1d_EMPLM_WA
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_MPLM_WA, only : MPLM_WA, testing
implicit none ; private
diff --git a/src/ALE/Recon1d_EMPLM_WA_poly.F90 b/src/ALE/Recon1d_EMPLM_WA_poly.F90
index bcfc398cf9..8aa06a883a 100644
--- a/src/ALE/Recon1d_EMPLM_WA_poly.F90
+++ b/src/ALE/Recon1d_EMPLM_WA_poly.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Extrapolated-Monotonized Piecewise Linear Method 1D reconstruction
!!
!! This extends MPLM_poly, following White and Adcroft, 2008 \cite white2008, by extraplating for the slopes of the
@@ -7,8 +11,6 @@
!! but was the form used in OM4.
module Recon1d_EMPLM_WA_poly
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_MPLM_WA_poly, only : MPLM_WA_poly, testing
implicit none ; private
diff --git a/src/ALE/Recon1d_EPPM_CWK.F90 b/src/ALE/Recon1d_EPPM_CWK.F90
index 2b9ed9853d..e39bf557e0 100644
--- a/src/ALE/Recon1d_EPPM_CWK.F90
+++ b/src/ALE/Recon1d_EPPM_CWK.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Parabolic Method 1D reconstruction in model index space with linear
!! extrapolation for first and last cells
!!
@@ -6,8 +10,6 @@
!! representation with slope set by matching the edge of the first interior cell.
module Recon1d_EPPM_CWK
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : Recon1d, testing
use Recon1d_PPM_CWK, only : PPM_CWK
diff --git a/src/ALE/Recon1d_MPLM_CWK.F90 b/src/ALE/Recon1d_MPLM_CWK.F90
index dc401a8440..87d623cf53 100644
--- a/src/ALE/Recon1d_MPLM_CWK.F90
+++ b/src/ALE/Recon1d_MPLM_CWK.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Linear Method 1D reconstruction in index space
!!
!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, except for assuming
@@ -6,8 +10,6 @@
!! The first and last cells are always limited to PCM.
module Recon1d_MPLM_CWK
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : testing
use Recon1d_PLM_CWK, only : PLM_CWK
diff --git a/src/ALE/Recon1d_MPLM_WA.F90 b/src/ALE/Recon1d_MPLM_WA.F90
index b9fa635063..29b54ccdeb 100644
--- a/src/ALE/Recon1d_MPLM_WA.F90
+++ b/src/ALE/Recon1d_MPLM_WA.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Monotonized Piecewise Linear Method 1D reconstruction
!!
!! This implementation of PLM follows White and Adcroft, 2008 \cite white2008.
@@ -9,8 +13,6 @@
!! are referred to.
module Recon1d_MPLM_WA
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_PLM_CW, only : PLM_CW, testing
implicit none ; private
diff --git a/src/ALE/Recon1d_MPLM_WA_poly.F90 b/src/ALE/Recon1d_MPLM_WA_poly.F90
index 4a4bdc95bb..333377f726 100644
--- a/src/ALE/Recon1d_MPLM_WA_poly.F90
+++ b/src/ALE/Recon1d_MPLM_WA_poly.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Monotonized Piecewise Linear Method 1D reconstruction using polynomial representation
!!
!! This implementation of PLM follows White and Adcroft, 2008 \cite white2008.
@@ -9,8 +13,6 @@
!! not preferred but was the form used in OM4.
module Recon1d_MPLM_WA_poly
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_MPLM_WA, only : MPLM_WA, testing
implicit none ; private
diff --git a/src/ALE/Recon1d_PCM.F90 b/src/ALE/Recon1d_PCM.F90
index 3b64844983..efb943c354 100644
--- a/src/ALE/Recon1d_PCM.F90
+++ b/src/ALE/Recon1d_PCM.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> 1D reconstructions using the Piecewise Constant Method (PCM)
module Recon1d_PCM
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : Recon1d, testing
implicit none ; private
@@ -17,6 +19,7 @@ module Recon1d_PCM
!! average() *locally defined
!! f() *locally defined
!! dfdx() *locally defined
+!! - x() *locally defined
!! check_reconstruction() *locally defined
!! unit_tests() *locally defined
!! destroy() *locally defined
@@ -36,6 +39,8 @@ module Recon1d_PCM
procedure :: f => f
!> Implementation of the derivative of the PCM reconstruction at a point [A]
procedure :: dfdx => dfdx
+ !> Implementation of solver for x: f(x)=t
+ procedure :: x => x
!> Implementation of deallocation for PCM
procedure :: destroy => destroy
!> Implementation of check reconstruction for the PCM reconstruction
@@ -105,6 +110,24 @@ real function dfdx(this, k, x)
end function dfdx
+!> Solver for x: f(x)=t
+real function x(this, k, t)
+ class(PCM), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: t !< Value to solve for [A]
+ real :: slp ! Difference across cell [A]
+
+ slp = this%u_mean(min(k+1,this%n)) - this%u_mean(max(k-1,1))
+ if ( abs(slp) > 0. ) slp = sign(1., slp)
+ x = 0.5 ! Fall back if t==u_mean
+ ! if t>u_mean & slp=1 then x=1
+ ! if tu_mean & slp=-1 then x=0
+ ! if t 0. ) x = 0.5 + slp * sign(0.5, t - this%u_mean(k))
+end function x
+
!> Average between xa and xb for cell k of a 1D PCM reconstruction [A]
real function average(this, k, xa, xb)
class(PCM), intent(in) :: this !< This reconstruction
@@ -181,6 +204,16 @@ logical function unit_tests(this, verbose, stdout, stderr)
call test%real_arr(3, um, (/0.,0.,0./), 'dfdx in center')
call test%real_arr(3, ur, (/0.,0.,0./), 'dfdx on right edge')
+ call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0')
+ call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5')
+ call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1')
+ call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0')
+ call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5')
+ call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1')
+ call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0')
+ call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5')
+ call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1')
+
do k = 1, 3
um(k) = this%average(k, 0.5, 0.75)
enddo
diff --git a/src/ALE/Recon1d_PLM_CW.F90 b/src/ALE/Recon1d_PLM_CW.F90
index 0c53246286..be42a399f0 100644
--- a/src/ALE/Recon1d_PLM_CW.F90
+++ b/src/ALE/Recon1d_PLM_CW.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Linear Method 1D reconstruction
!!
!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, with cells
@@ -7,8 +11,6 @@
!! This does not yield monotonic profiles for the general remapping problem.
module Recon1d_PLM_CW
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : Recon1d, testing
implicit none ; private
@@ -23,6 +25,7 @@ module Recon1d_PLM_CW
!! - average() *locally defined
!! - f() *locally defined
!! - dfdx() *locally defined
+!! - x() *locally defined
!! - check_reconstruction() *locally defined
!! - unit_tests() *locally defined
!! - destroy() *locally defined
@@ -45,6 +48,8 @@ module Recon1d_PLM_CW
procedure :: f => f
!> Implementation of the derivative of the PLM_CW reconstruction at a point [A]
procedure :: dfdx => dfdx
+ !> Implementation of solver for x: f(x)=t
+ procedure :: x => x
!> Implementation of deallocation for PLM_CW
procedure :: destroy => destroy
!> Implementation of check reconstruction for the PLM_CW reconstruction
@@ -194,6 +199,31 @@ real function dfdx(this, k, x)
end function dfdx
+!> Solver for x such that f(x)=t
+real function x(this, k, t)
+ class(PLM_CW), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: t !< Value to solve for [A]
+ real :: slp ! Difference across cell [A]
+
+ slp = this%ur(k) - this%ul(k)
+ if ( abs(slp) > 0. ) then
+ x = ( t - this%ul(k) ) / slp
+ x = max( 0., min( x, 1. ) )
+ else
+ slp = this%ul(min(k+1,this%n)) - this%ur(max(k-1,1))
+ if ( abs(slp) > 0. ) slp = sign(1., slp)
+ x = 0.5 ! Fall back if t==u_mean
+ ! if t>u_mean & slp=1 then x=1
+ ! if tu_mean & slp=-1 then x=0
+ ! if t 0. ) x = 0.5 + slp * sign(0.5, t - this%u_mean(k))
+ endif
+end function x
+
!> Average between xa and xb for cell k of a 1D PLM reconstruction [A]
real function average(this, k, xa, xb)
class(PLM_CW), intent(in) :: this !< This reconstruction
@@ -334,6 +364,16 @@ logical function unit_tests(this, verbose, stdout, stderr)
call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center')
call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge')
+ call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0')
+ call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5')
+ call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1')
+ call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0')
+ call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5')
+ call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1')
+ call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0')
+ call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5')
+ call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1')
+
do k = 1, 3
um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell
enddo
diff --git a/src/ALE/Recon1d_PLM_CWK.F90 b/src/ALE/Recon1d_PLM_CWK.F90
index b30af80aa1..1e20f87318 100644
--- a/src/ALE/Recon1d_PLM_CWK.F90
+++ b/src/ALE/Recon1d_PLM_CWK.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Linear Method 1D reconstruction
!!
!! This implementation of PLM follows Colella and Woodward, 1984, except for assuming
@@ -10,8 +14,6 @@
!! resulting calculations are properly bounded.
module Recon1d_PLM_CWK
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : testing
use Recon1d_PLM_CW, only : PLM_CW
@@ -29,6 +31,7 @@ module Recon1d_PLM_CWK
!! - average() -> recon1d_plm_cw.average()
!! - f() -> recon1d_plm_cw.f()
!! - dfdx() -> recon1d_plm_cw.dfdx()
+!! - x() -> recon1d_plm_cw.x()
!! - check_reconstruction() -> recon1d_plm_cw.check_reconstruction()
!! - unit_tests() -> recon1d_plm_cw.unit_tests()
!! - destroy() -> recon1d_plm_cw.destroy()
diff --git a/src/ALE/Recon1d_PLM_WLS.F90 b/src/ALE/Recon1d_PLM_WLS.F90
new file mode 100644
index 0000000000..24d6988f24
--- /dev/null
+++ b/src/ALE/Recon1d_PLM_WLS.F90
@@ -0,0 +1,471 @@
+!> Piecewise Linear Method using Weighted Conservative Least Squares 1D reconstruction
+module Recon1d_PLM_WLS
+
+! This file is part of MOM6. See LICENSE.md for the license.
+
+use Recon1d_type, only : Recon1d, testing
+
+implicit none ; private
+
+public PLM_WLS, testing
+
+!> PLM reconstruction using Weighted Least Squares constrained to conserve for central cell
+!!
+!! The source for the methods ultimately used by this class are:
+!! - init() *locally defined
+!! - reconstruct() *locally defined
+!! - average() *locally defined
+!! - f() *locally defined
+!! - dfdx() *locally defined
+!! - x() -> recon1d_type.x()
+!! - check_reconstruction() *locally defined
+!! - unit_tests() *locally defined
+!! - destroy() *locally defined
+!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid()
+!! - init_parent() -> init()
+!! - reconstruct_parent() -> reconstruct()
+type, extends (Recon1d) :: PLM_WLS
+
+ real, allocatable :: ul(:) !< Left edge value [A]
+ real, allocatable :: ur(:) !< Right edge value [A]
+ real, allocatable, private :: slp(:) !< Difference across cell, ur - ul [A].
+ !! This is redundant with ul and ur and not used
+ !! in any evaluations, but is needed for testing.
+
+contains
+ !> Implementation of the PLM_WLS initialization
+ procedure :: init => init
+ !> Implementation of the PLM_WLS reconstruction
+ procedure :: reconstruct => reconstruct
+ !> Implementation of the PLM_WLS average over an interval [A]
+ procedure :: average => average
+ !> Implementation of evaluating the PLM_WLS reconstruction at a point [A]
+ procedure :: f => f
+ !> Implementation of the derivative of the PLM_WLS reconstruction at a point [A]
+ procedure :: dfdx => dfdx
+ !> Implementation of deallocation for PLM_WLS
+ procedure :: destroy => destroy
+ !> Implementation of check reconstruction for the PLM_WLS reconstruction
+ procedure :: check_reconstruction => check_reconstruction
+ !> Implementation of unit tests for the PLM_WLS reconstruction
+ procedure :: unit_tests => unit_tests
+
+ !> Duplicate interface to init()
+ procedure :: init_parent => init
+ !> Duplicate interface to reconstruct()
+ procedure :: reconstruct_parent => reconstruct
+
+end type PLM_WLS
+
+contains
+
+!> Initialize a 1D PLM reconstruction for n cells
+subroutine init(this, n, h_neglect, check)
+ class(PLM_WLS), intent(out) :: this !< This reconstruction
+ integer, intent(in) :: n !< Number of cells in this column
+ real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H]
+ logical, optional, intent(in) :: check !< If true, enable some consistency checking
+
+ this%n = n
+
+ allocate( this%u_mean(n) )
+ allocate( this%ul(n) )
+ allocate( this%ur(n) )
+ allocate( this%slp(n) )
+
+ this%h_neglect = tiny( this%u_mean(1) )
+ if (present(h_neglect)) this%h_neglect = h_neglect
+ this%check = .false.
+ if (present(check)) this%check = check
+
+end subroutine init
+
+!> Calculate a 1D PLM_WLS reconstruction based on h(:) and u(:)
+subroutine reconstruct(this, h, u)
+ class(PLM_WLS), intent(inout) :: this !< This reconstruction
+ real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H]
+ real, intent(in) :: u(*) !< Cell mean values [A]
+ ! Local variables
+ real :: slp ! The PLM slopes (difference across cell) [A]
+ real :: u_l, u_r, u_c ! Left, right, and center values [A]
+ real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H]
+ real :: h_l0, h_r0 ! Thickness of left and right cells with h_neglect added [H]
+ real :: hx2l, hx2r ! Contributions to denominator, [H3]
+ real :: hxyl, hxyr ! Contributions to numerator, [H2 A]
+ integer :: n, km1, k, kp1
+
+ n = this%n
+
+ ! Loop over all cells
+ do k = 1, n
+ km1 = max(1, k-1)
+ kp1 = min(n, k+1)
+ u_l = u(km1)
+ u_c = u(k)
+ u_r = u(kp1)
+
+ h_l = h(km1) * real( k - km1 ) ! This zeroes h_l at k==1
+ h_c = h(k)
+ h_r = h(kp1) * real( kp1 - k ) ! This zeroes h_r at k==n
+
+ ! This is the slope that minimizes the error
+ ! sum_l={-1,1} h(k+l) * [ u(k+l) - u(k) + slp * ( z(k+l) - z(k) ) ]
+ ! i.e. volume weighted least squares
+ h_l0 = h_l + this%h_neglect
+ h_r0 = h_r + this%h_neglect
+ hxyl = ( h_l * ( h_c + h_l ) ) * ( u_c - u_l )
+ hxyr = ( h_r * ( h_c + h_r ) ) * ( u_r - u_c )
+ hx2l = h_l0 * ( h_c + h_l0 )**2
+ hx2r = h_r0 * ( h_c + h_r0 )**2
+ slp = 2. * h_c * ( hxyr + hxyl ) / ( hx2l + hx2r )
+
+ ! Mean value
+ this%u_mean(k) = u_c
+
+ ! Left edge
+ this%ul(k) = u_c - 0.5 * slp
+
+ ! Right edge
+ this%ur(k) = u_c + 0.5 * slp
+
+ ! Store slope
+ this%slp(k) = slp
+ enddo
+
+end subroutine reconstruct
+
+!> Value of PLM_WLS reconstruction at a point in cell k [A]
+real function f(this, k, x)
+ class(PLM_WLS), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: x !< Non-dimensional position within element [nondim]
+ real :: du ! Difference across cell [A]
+
+ du = this%ur(k) - this%ul(k)
+
+ ! This expression might be used beyond the element to evaluate
+ ! LS errors. In other PLM implementations x is bounded to the
+ ! element and the expressions are constructed to not exceed
+ ! bounds. There are no such constraints for PLM_WLS.
+ f = this%u_mean(k) + du * ( x - 0.5)
+ !f = this%u_mean(k) + this%slp(k) * ( x - 0.5)
+
+end function f
+
+!> Derivative of PLM_WLS reconstruction at a point in cell k [A]
+real function dfdx(this, k, x)
+ class(PLM_WLS), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: x !< Non-dimensional position within element [nondim]
+
+ dfdx = this%ur(k) - this%ul(k)
+
+end function dfdx
+
+!> Average between xa and xb for cell k of a 1D PLM reconstruction [A]
+real function average(this, k, xa, xb)
+ class(PLM_WLS), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: xa !< Start of averaging interval on element (0 to 1)
+ real, intent(in) :: xb !< End of averaging interval on element (0 to 1)
+ real :: xmab ! Mid-point between xa and xb (0 to 1)
+ real :: u_a, u_b ! Values at xa and xb [A]
+
+ ! Mid-point between xa and xb
+ xmab = 0.5 * ( xa + xb )
+
+ ! This expression for u_a can overshoot u_r but is good for xmab<<1
+ u_a = this%ul(k) + ( this%ur(k) - this%ul(k) ) * xmab
+ ! This expression for u_b can overshoot u_l but is good for 1-xmab<<1
+ u_b = this%ur(k) + ( this%ul(k) - this%ur(k) ) * ( 1. - xmab )
+
+ ! Since u_a and u_b are both bounded, this will perserve uniformity but will the
+ ! sum be bounded? Emperically it seems to work...
+ average = 0.5 * ( u_a + u_b )
+
+end function average
+
+!> Deallocate the PLM reconstruction
+subroutine destroy(this)
+ class(PLM_WLS), intent(inout) :: this !< This reconstruction
+
+ deallocate( this%u_mean, this%ul, this%ur )
+
+end subroutine destroy
+
+!> Checks the PLM_WLS reconstruction for consistency
+logical function check_reconstruction(this, h, u)
+ class(PLM_WLS), intent(in) :: this !< This reconstruction
+ real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H]
+ real, intent(in) :: u(*) !< Cell mean values [A]
+ ! Local variables
+ integer :: k
+ real :: slp ! Cell slope [A]
+ type(PLM_WLS) :: perturbed !< A perturbed reconstruction
+ real :: u_l, u_r, u_c ! Left, right, and center values [A]
+ real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H]
+ real :: h_l0, h_r0, h_c0 ! Thickness of left, right, center cells with h_neglect added [H]
+ real :: x_l, x_r ! Positions of left and right cells [H]
+ real :: hx2l, hx2r ! Contributions to denominator, [H3]
+ real :: hxyl, hxyr ! Contributions to numerator, [H2 A]
+ real :: hy2l, hy2r ! Contributions to error, [H3]
+ real :: y_l, y_r ! Left, right, value differencess [A]
+ real :: b_h, bp_h ! slp / h_c [A H-1]
+ integer :: km1, kp1
+
+ check_reconstruction = .false.
+
+ do k = 1, this%n
+ if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true.
+ enddo
+
+ ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line)
+ do k = 1, this%n
+ if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true.
+ enddo
+
+ ! Check the cell is a straight line (to within machine precision)
+ do k = 1, this%n
+ if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * &
+ max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true.
+ enddo
+
+ ! Create a perturbable reconstruction
+ call perturbed%init( this%n, h_neglect=this%h_neglect )
+ call perturbed%reconstruct( h, u ) ! Should reproduce "this"
+ ! Check the copy is identical
+ do k = 1, this%n
+ if ( abs( perturbed%u_mean(k) - this%u_mean(k) ) > 0. ) check_reconstruction = .true.
+ if ( abs( perturbed%ul(k) - this%ul(k) ) > 0. ) check_reconstruction = .true.
+ if ( abs( perturbed%ur(k) - this%ur(k) ) > 0. ) check_reconstruction = .true.
+ if ( abs( perturbed%slp(k) - this%slp(k) ) > 0. ) check_reconstruction = .true.
+ enddo
+ ! Now perturb the slope. The local error should not decrease.
+ do k = 1, this%n
+ slp = this%slp(k) * ( 1.0 + 1. * epsilon(slp) )
+ perturbed%slp(k) = slp
+ perturbed%ul(k) = u(k) - 0.5 * slp
+ perturbed%ur(k) = u(k) + 0.5 * slp
+ if ( LS_error(perturbed, k, h, u) < LS_error(this, k, h, u) ) check_reconstruction = .true.
+
+ slp = this%slp(k) * ( 1.0 - 1. * epsilon(slp) )
+ perturbed%slp(k) = slp
+ perturbed%ul(k) = u(k) - 0.5 * slp
+ perturbed%ur(k) = u(k) + 0.5 * slp
+ if ( LS_error(perturbed, k, h, u) < LS_error(this, k, h, u) ) check_reconstruction = .true.
+ enddo
+
+end function check_reconstruction
+
+!> Returns local least squares error for a particular cell
+!!
+!! Note that this is the error relative to the minimum of the loss function so that at the
+!! true solution this function returns zero. See module documentation.
+real function LS_error(this, k, h, u)
+ type(PLM_WLS), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H]
+ real, intent(in) :: u(*) !< Cell mean values [A]
+ ! Local variables
+ real :: u_l, u_r, u_c ! Left, right, and center values [A]
+ real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H]
+ real :: h_l0, h_r0, hc0 ! Thickness of left, right, center cells with h_neglect added [H]
+ real :: hx2l, hx2r ! Contributions to denominator, [H3]
+ real :: hxyl, hxyr ! Contributions to numerator, [H2 A]
+ integer :: km1, kp1
+
+ km1 = max(1, k-1)
+ kp1 = min(this%n, k+1)
+ u_l = u(km1)
+ u_c = u(k)
+ u_r = u(kp1)
+
+ h_l = h(km1) * real( k - km1 ) ! This zeroes h_l at k==1
+ h_r = h(kp1) * real( kp1 - k ) ! This zeroes h_r at k==n
+ h_c = h(k)
+ hc0 = h_c + this%h_neglect
+
+ h_l0 = h_l + this%h_neglect
+ h_r0 = h_r + this%h_neglect
+ hxyl = ( h_l * 0.5 * ( h_c + h_l ) ) * ( u_c - u_l )
+ hxyr = ( h_r * 0.5 * ( h_c + h_r ) ) * ( u_r - u_c )
+ hx2l = h_l0 * 0.25 * ( h_c + h_l0 )**2
+ hx2r = h_r0 * 0.25 * ( h_c + h_r0 )**2
+ LS_error = h_c * ( ( hx2l + hx2r ) * this%slp(k) - h(k) * ( hxyl + hxyr ) )**2
+ LS_error = LS_error / ( hc0 * ( hx2l + hx2r ) )
+end function LS_error
+
+!> Runs PLM_WLS reconstruction unit tests and returns True for any fails, False otherwise
+logical function unit_tests(this, verbose, stdout, stderr)
+ class(PLM_WLS), intent(inout) :: this !< This reconstruction
+ logical, intent(in) :: verbose !< True, if verbose
+ integer, intent(in) :: stdout !< I/O channel for stdout
+ integer, intent(in) :: stderr !< I/O channel for stderr
+ ! Local variables
+ real, allocatable :: ul(:), ur(:), um(:) ! test values [A]
+ real, allocatable :: ull(:), urr(:) ! test values [A]
+ type(testing) :: test ! convenience functions
+ integer :: k
+
+ call test%set( stdout=stdout ) ! Sets the stdout channel in test
+ call test%set( stderr=stderr ) ! Sets the stderr channel in test
+ call test%set( verbose=verbose ) ! Sets the verbosity flag in test
+
+ call this%init(3, h_neglect=1.e-20)
+ call test%test( this%n /= 3, "Setting number of levels")
+ allocate( um(3), ul(3), ur(3), ull(3), urr(3) )
+
+ call this%reconstruct( (/1.,1.,1./), (/-1.,0.,2./) )
+ call test%real_arr(3, this%slp, (/1.,1.5,2./), "(1,1,1)(-1,0,2) slope")
+
+ do k = 1, 3
+ um(k) = LS_error(this, k, (/1.,1.,1./), (/-1.,0.,2./) )
+ enddo
+ call test%real_arr(3, um, (/0.,0.,0./), "(1,1,1)(-1,0,2) LS' rel error")
+
+ call this%reconstruct( (/0.,1.,1./), (/-1.,0.,2./) )
+ call test%real_arr(3, this%slp, (/0.,2.,2./), "(0,1,1)(-1,0,2) slope")
+
+ do k = 1, 3
+ um(k) = LS_error(this, k, (/0.,1.,1./), (/-1.,0.,2./) )
+ enddo
+ call test%real_arr(3, um, (/0.,0.,0./), "(0,1,1)(-1,0,2) LS' rel error")
+
+ call this%reconstruct( (/1.,1.,1./), (/-2.,0.,1./) )
+ call test%real_arr(3, this%slp, (/2.,1.5,1./), "(1,1,1)(-2,0,1) slope")
+
+ call this%reconstruct( (/1.,1.,0./), (/-2.,0.,1./) )
+ call test%real_arr(3, this%slp, (/2.,2.,0./), "(1,1,0)(-2,0,1) slope")
+
+ call this%destroy()
+ call this%init(3) ! Reset to defaults
+
+ ! Straight line data on uniform grid
+ call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) )
+ call test%real_arr(3, this%u_mean, (/1.,3.,5./), "Straight line data")
+
+ do k = 1, 3
+ ul(k) = this%f(k, 0.)
+ um(k) = this%f(k, 0.5)
+ ur(k) = this%f(k, 1.)
+ enddo
+ call test%real_arr(3, ul, (/0.,2.,4./), "Evaluation on left edge")
+ call test%real_arr(3, um, (/1.,3.,5./), "Evaluation in center")
+ call test%real_arr(3, ur, (/2.,4.,6./), "Evaluation on right edge")
+
+ do k = 1, 3
+ ul(k) = this%dfdx(k, 0.)
+ um(k) = this%dfdx(k, 0.5)
+ ur(k) = this%dfdx(k, 1.)
+ enddo
+ call test%real_arr(3, ul, (/2.,2.,2./), "dfdx on left edge")
+ call test%real_arr(3, um, (/2.,2.,2./), "dfdx in center")
+ call test%real_arr(3, ur, (/2.,2.,2./), "dfdx on right edge")
+
+ do k = 1, 3
+ um(k) = LS_error(this, k, (/2.,2.,2./), (/1.,3.,5./) )
+ enddo
+ call test%real_arr(3, um, (/0.,0.,0./), "Rel error is 0")
+
+ do k = 1, 3
+ um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.5 to 0.75 in each cell
+ enddo
+ call test%real_arr(3, um, (/1.25,3.25,5.25/), "Return interval average")
+
+ call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0')
+ call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5')
+ call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1')
+ call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0')
+ call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5')
+ call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1')
+ call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0')
+ call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5')
+ call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1')
+
+ call this%destroy()
+ deallocate( um, ul, ur, ull, urr )
+
+ allocate( um(4), ul(4), ur(4) )
+ call this%init(4)
+
+ deallocate( um, ul, ur )
+
+ unit_tests = test%summarize("PLM_WLS:unit_tests")
+
+end function unit_tests
+
+!> \namespace recon1d_plm_wls
+!!
+!! This implementation of PLM fits the slope using least squares, but retains conservation
+!! for the central cell by passing through the central value.
+!! Cell-wise reconstructions are NOT limited by neighbours.
+!! Thus, this reconstruction does not yield monotonic profiles needed for the general remapping problem.
+!!
+!! The algorithm solves the least squares problem of fitting a straight line through
+!! the neighboring data. The line is constained to pass through the center cell,
+!! \f$ (x_{k}, y_{k}) \f$, so that the construction is conservative. The more general
+!! function \f$ f(x) = a_{k} + b_{k} x \f$ would not conserve for arbitrary data.
+!!
+!! The unknown parameter \f$ b_{k} \f$ in the line
+!! \f[
+!! f(x) = y_{k} + b_{k} ( x - x_{k} ) / h_{k}
+!! \f]
+!! is fit to neighbors \f$ x_{k-1}, y_{k-1} \f$ and \f$ x_{k+1}, y_{k+1} \f$.
+!!
+!! Denoting \f$ y'_{k+j} = y_{k+j} - y_{k} \f$ and \f$ x'_{k+j} = x_{k+j} - x_{k} \f$
+!! the local error is
+!! \f{align}{
+!! e_{k+j} &= b_k \frac{ x_{k+j} - x_{k} }{ h_{k} } + y_{k} - y_{k+j} \\\\
+!! &= b_k \frac{ x'_{k+j} }{ h_{k} } - y'_{k+j}
+!! \;\; . \f}
+!!
+!! We use volume weighting in the loss
+!! \f[
+!! G(b) = h_{k-1} e_{k-1}^2 + h_{k+1} e_{k+1}^2
+!! \;\; . \f]
+!!
+!! When solving for \f$ b_k \f$, we solve \f$ dG/db = 0 \f$ where
+!! \f{align}{
+!! dG/db &= 2 h_{k-1} e_{k-1} \frac{ de_{k-1} }{db} + 2 h_{k+1} e_{k+1} \frac{ de_{k+1} }{db} \\\\
+!! &= 2 h_{k-1} ( b_k \frac{ x'_{k-1} }{ h_{k} } - \frac{ y'_{k-1} ) x'_{k-1} }{ h_{k} } +
+!! 2 h_{k+1} ( b_k \frac{ x'_{k+1} }{ h_{k} } - \frac{ y'_{k+1} ) x'_{k+1} }{ h_{k} } \\\\
+!! &= 4 b_k \frac{ < h x'^2 > }{ h_{k}^2 } - 4 \frac{ < h x' y' > }{ h_{k} }
+!! \f}
+!! and where \f$ < a > = \frac{1}{2} ( a_{k-1} + a_{k+1} ) \f$.
+!! Thus
+!! \f[
+!! b_k = \frac{ h_{k} < h x' y' > }{ < h x'^2 > } \;\; .
+!! \f]
+!!
+!! When evaluating the loss, \f$ G \f$, some rearrangement is necessary to reduce truncation
+!! errors. Since
+!! \f{align}{
+!! e_{k+j}^2 &= \left( b \frac{ x'_{k+j} }{ h_{k} } - y'_{k+j} \right)^2 \\\\
+!! &= b^2 \frac{ {x'}_{k+j}^2 }{ h_{k}^2 } - 2 b \frac{ x'_{k+j} y'_{k+j} }{ h_{k} } + {y'}_{k+j}^2
+!! \f}
+!! then
+!! \f{align}{
+!! G(b) &= 2 < h e^2 > \\\\
+!! &= 2 b^2 \frac{ < h {x'}^2 > }{ h_{k}^2 } - 4 b \frac{ < h x' y' > }{ h_{k} } + 2 < h' {y'}^2 >
+!! \;\; .
+!! \f}
+!!
+!! If we denote the value of b that yields the minimum value as \f$ b^* \f$ then
+!! \f[
+!! G(b^*) = < h {y'}^2 > - \frac{ < h x' y' >^2 }{ < h {x'}^2 > }
+!! \;\; .
+!! \f]
+!!
+!! Let
+!! \f{align}{
+!! G''(b) &= G(b) - G(b^*) \\\\
+!! &= b^2 \frac{ < h {x'}^2 > }{ h_{k}^2 } - 2 b \frac{ < h x' y' > }{ h_{k} }
+!! + \frac{ < h x' y' > }{ < h {x'}^2 > } \\\\
+!! &= \frac{ \left( b < h {x'}^2 > - h_{k} < h x' y' > \right)^2 }{ h_{k} < h {x'}^2 > }
+!! \;\; .
+!! \f}
+!! Minimizing \f$ G''(b) \f$ is equivalent to minimizing \f$ G(b) \f$ for the same data.
+!! \f$ G''(b^*)=0 \f$ so evaluation with the last form, in the vicinity of \f$ b^* \f$, avoids
+!! large cancelling terms.
+
+end module Recon1d_PLM_WLS
diff --git a/src/ALE/Recon1d_PLM_hybgen.F90 b/src/ALE/Recon1d_PLM_hybgen.F90
index 0cf2e8e001..0d5fa26e26 100644
--- a/src/ALE/Recon1d_PLM_hybgen.F90
+++ b/src/ALE/Recon1d_PLM_hybgen.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Linear Method 1D reconstruction ported from "hybgen" module in Hycom.
!!
!! This implementation of PLM follows Colella and Woodward, 1984, with cells resorting to PCM for
@@ -11,8 +15,6 @@
!! equiavalent to the recon1d_plm_hybgen module (this implementation).
module Recon1d_PLM_hybgen
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : Recon1d, testing
implicit none ; private
@@ -29,6 +31,7 @@ module Recon1d_PLM_hybgen
!! - average() *locally defined
!! - f() *locally defined
!! - dfdx() *locally defined
+!! - x() -> recon1d_plm_cw.x()
!! - check_reconstruction() *locally defined
!! - unit_tests() *locally defined
!! - destroy() *locally defined
@@ -358,6 +361,16 @@ logical function unit_tests(this, verbose, stdout, stderr)
call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center')
call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge')
+ call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0')
+ call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5')
+ call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1')
+ call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0')
+ call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5')
+ call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1')
+ call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0')
+ call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5')
+ call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1')
+
do k = 1, 3
um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell
enddo
diff --git a/src/ALE/Recon1d_PPM_CW.F90 b/src/ALE/Recon1d_PPM_CW.F90
index 9523ad46ea..7a0734ec88 100644
--- a/src/ALE/Recon1d_PPM_CW.F90
+++ b/src/ALE/Recon1d_PPM_CW.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Parabolic Method 1D reconstruction following Colella and Woodward, 1984
!!
!! This is a near faithful implementation of PPM following Colella and Woodward, 1984, with
@@ -9,8 +13,6 @@
!! set to PCM. The reconstructions are grid-spacing dependent, and so quasi-forth order in h.
module Recon1d_PPM_CW
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : Recon1d, testing
use Recon1d_PLM_CW, only : PLM_CW
@@ -26,6 +28,7 @@ module Recon1d_PPM_CW
!! - average() *locally defined
!! - f() *locally defined
!! - dfdx() *locally defined
+!! - x() *locally defined
!! - check_reconstruction() *locally defined
!! - unit_tests() *locally defined
!! - destroy() *locally defined
@@ -49,6 +52,8 @@ module Recon1d_PPM_CW
procedure :: f => f
!> Implementation of the derivative of the PPM_CW reconstruction at a point [A]
procedure :: dfdx => dfdx
+ !> Implementation of solver for x: f(x)=t
+! procedure :: x => x
!> Implementation of deallocation for PPM_CW
procedure :: destroy => destroy
!> Implementation of check reconstruction for the PPM_CW reconstruction
@@ -152,13 +157,13 @@ subroutine reconstruct(this, h, u)
this%ur(n) = u(n) ! PCM
this%ul(n) = u(n) ! PCM
- do K = 2, n ! K=2 is interface between cells 1 and 2
+ do K = 2, n-1 ! K=2 is interface between cells 1 and 2
u0 = u(k-1)
u1 = u(k)
u2 = u(k+1)
a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) )
du = this%ur(k) - this%ul(k)
- if ( ( u2 - u1 ) * ( u1 - u0 ) <- 0.0 ) then ! Large scale extrema
+ if ( ( u2 - u1 ) * ( u1 - u0 ) <= 0.0 ) then ! Large scale extrema
this%ul(k) = u1
this%ur(k) = u1
elseif ( du * a6 > du * du ) then ! Extrema on right
@@ -333,6 +338,7 @@ logical function unit_tests(this, verbose, stdout, stderr)
call test%set( stdout=stdout ) ! Sets the stdout channel in test
call test%set( stderr=stderr ) ! Sets the stderr channel in test
call test%set( verbose=verbose ) ! Sets the verbosity flag in test
+call test%set( stop_instantly=.true. )
if (verbose) write(stdout,'(a)') 'PPM_CW:unit_tests testing with linear fn'
@@ -366,6 +372,10 @@ logical function unit_tests(this, verbose, stdout, stderr)
call test%real_arr(5, um, (/0.,3.,3.,3.,0./), 'dfdx in center')
call test%real_arr(5, ur, (/0.,3.,3.,3.,0./), 'dfdx on right edge')
+ call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0')
+ call test%real_scalar( this%x(2,4.), 0.5, 'f-1(2,4)=0.5')
+ call test%real_scalar( this%x(2,5.5), 1., 'f-1(2,5.5)=1')
+
do k = 1, 5
um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell
enddo
@@ -392,6 +402,10 @@ logical function unit_tests(this, verbose, stdout, stderr)
call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center')
call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge')
+ call test%real_scalar( this%x(3,12.), 0., 'f-1(3,12)=0')
+ call test%real_scalar( this%x(3,18.75), 0.5, 'f-1(3,18.75)=0.5', robits=1)
+ call test%real_scalar( this%x(3,27.), 1., 'f-1(3,27)=1')
+
! x = 3 i i=0 at origin
! f(x) = x^2 / 3 = 3 i^2
! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5
diff --git a/src/ALE/Recon1d_PPM_CWK.F90 b/src/ALE/Recon1d_PPM_CWK.F90
index a0cbce5877..42d6cd04f7 100644
--- a/src/ALE/Recon1d_PPM_CWK.F90
+++ b/src/ALE/Recon1d_PPM_CWK.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Parabolic Method 1D reconstruction in model index space
!!
!! This implementation of PPM follows Colella and Woodward, 1984, using uniform thickness
@@ -10,8 +14,6 @@
!! when the grid spacing is variable.
module Recon1d_PPM_CWK
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : Recon1d, testing
use Recon1d_PLM_CWK, only : PLM_CWK
@@ -27,6 +29,7 @@ module Recon1d_PPM_CWK
!! - average() *locally defined
!! - f() *locally defined
!! - dfdx() *locally defined
+!! - x() *locally defined
!! - check_reconstruction() *locally defined
!! - unit_tests() *locally defined
!! - destroy() *locally defined
@@ -50,6 +53,8 @@ module Recon1d_PPM_CWK
procedure :: f => f
!> Implementation of the derivative of the PPM_CWK reconstruction at a point [A]
procedure :: dfdx => dfdx
+ !> Implementation of solver for x: f(x)=t
+ procedure :: x => x
!> Implementation of deallocation for PPM_CWK
procedure :: destroy => destroy
!> Implementation of check reconstruction for the PPM_CWK reconstruction
@@ -137,13 +142,13 @@ subroutine reconstruct(this, h, u)
this%ur(n) = u(n) ! PCM
this%ul(n) = u(n) ! PCM
- do K = 2, n ! K=2 is interface between cells 1 and 2
+ do K = 2, n-1 ! K=2 is interface between cells 1 and 2
u0 = u(k-1)
u1 = u(k)
u2 = u(k+1)
a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) )
du = this%ur(k) - this%ul(k)
- if ( ( u2 - u1 ) * ( u1 - u0 ) <- 0.0 ) then ! Large scale extrema
+ if ( ( u2 - u1 ) * ( u1 - u0 ) <= 0.0 ) then ! Large scale extrema
this%ul(k) = u1
this%ur(k) = u1
elseif ( du * a6 > du * du ) then ! Extrema on right
@@ -215,6 +220,62 @@ real function dfdx(this, k, x)
end function dfdx
+!> Solver for x: f(x)=t
+real function x(this, k, t)
+ class(PPM_CWK), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: t !< Value to solve for [A]
+ real :: slp ! Difference in edge values, ur-ul [A]
+ real :: a6 ! Colella and Woodward curvature parameter [A]
+ real :: sD ! Square root of the quadratic discriminant [A]
+ real :: b ! The b in f(x) = a x^2 + b x + c [A]
+ real :: c ! The c in f(x) = a x^2 + b x + c [A]
+
+ ! The PPM profile is the quadratic profile: f(x) = ul + (slp+a6)*x - a6*x^2.
+ ! Setting f(x)=t gives: -a6*x^2 + (slp+a6)*x + (ul-t) = 0.
+ ! In the common parlance of solving a*x^2 + b*x + c = 0, this means
+ ! a = -a6; b = slp+a6; c = ul-t
+ ! The quadratic formula x = ( -b +/- sD ) / ( 2a ) with sD = sqrt(b^2-4*a*c)
+ ! can suffer from catastrophic cancellation in some scenarios.
+ ! A mathematically equivalent form of x = 2c / ( -b -/+ sD ) also can fail.
+ ! Usually, to avoid catastrophic cancellation, we use the rule
+ ! If b>0 then the two roots are
+ ! ra = -(b+sD)/(2a)
+ ! rc = -2c/(b+sD)
+ ! otherwise if b<0 then the two roots are
+ ! ra = (-b+sD)/(2a)
+ ! rc = 2c/(-b+sD)
+ ! In all expressions, sD and b do not have cancelling contributions due to the signs.
+ ! Note that here, if b>0 then c<0, and vice versa, because we are looking
+ ! for f(x)=t which shifts "c" by t so that the root we are interested in
+ ! falls in the range 0 <= x <= 1 (assuming t falls in ul...ur).
+ ! When b>0 and a>0 then -b/(2a)<0 and ra<00 and a<0 then -b/(2a)>0 and ra>rc, so we need rc
+ ! When b<0 and a>0 then -b/(2a)>0 and ra>rc, so we need rc
+ ! When b<0 and a<0 then -b/(2a)<0 and ra<0 0.) then
+ ! The max(0,..a.) here is out of an abundance of caution, but if the PPM parameters
+ ! have been made monotonic then the max is not necessary.
+ sD = sqrt( max( 0., b**2 + 4. * a6 * c ) )
+ ! Calculate the reciprocal of the denominator. Note: even if b=0, sign(sD,b)=sD>0.
+ x = 1. / ( b + sign( sD, b ) )
+ ! The actual root is
+ x = -2. * c * x
+ x = max( 0., min( 1., x ) )
+ else
+ ! Constant (or inconsistent) profile (ul=ur, a6=?): infer position from adjacent cell slopes.
+ x = 0.5 ! fallback
+ slp = this%ul(min(k+1,this%n)) - this%ur(max(k-1,1))
+ if (abs(slp) > 0.) x = 0.5 + sign( 0.5, slp ) ! either 0 or 1
+ endif
+end function x
+
!> Average between xa and xb for cell k of a 1D PPM reconstruction [A]
real function average(this, k, xa, xb)
class(PPM_CWK), intent(in) :: this !< This reconstruction
@@ -373,6 +434,17 @@ logical function unit_tests(this, verbose, stdout, stderr)
call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center')
call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge')
+ call test%real_scalar( this%x(3,12.), 0., 'f-1(3,12)=0')
+ call test%real_scalar( this%x(3,15.1875), 0.25, 'f-1(3,15.1875)=0.25')
+ call test%real_scalar( this%x(3,18.75), 0.5, 'f-1(3,18.75)=0.5')
+ call test%real_scalar( this%x(3,27.), 1., 'f-1(3,27)=1')
+
+ call this%reconstruct( (/2.,2.,2.,2.,2./), (/-1.,-7.,-19.,-37.,-61./) )
+ call test%real_scalar( this%x(3,-12.), 0., 'f-1(3,-12)=0')
+ call test%real_scalar( this%x(3,-15.1875), 0.25, 'f-1(3,-15.1875)=0.25')
+ call test%real_scalar( this%x(3,-18.75), 0.5, 'f-1(3,-18.75)=0.5')
+ call test%real_scalar( this%x(3,-27.), 1., 'f-1(3,-27)=1')
+
! x = 3 i i=0 at origin
! f(x) = x^2 / 3 = 3 i^2
! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5
diff --git a/src/ALE/Recon1d_PPM_H4_2018.F90 b/src/ALE/Recon1d_PPM_H4_2018.F90
index d668b70ace..401c95e504 100644
--- a/src/ALE/Recon1d_PPM_H4_2018.F90
+++ b/src/ALE/Recon1d_PPM_H4_2018.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Parabolic Method 1D reconstruction with h4 interpolation for edges (2018 version)
!!
!! This implementation of PPM follows White and Adcroft 2008 \cite white2008, with cells
@@ -8,8 +12,6 @@
!! The first and last cells are always limited to PCM.
module Recon1d_PPM_H4_2018
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_PPM_H4_2019, only : PPM_H4_2019, testing
use regrid_edge_values, only : bound_edge_values, check_discontinuous_edge_values
use regrid_solvers, only : solve_linear_system
diff --git a/src/ALE/Recon1d_PPM_H4_2019.F90 b/src/ALE/Recon1d_PPM_H4_2019.F90
index d01ff3fb2b..26985be644 100644
--- a/src/ALE/Recon1d_PPM_H4_2019.F90
+++ b/src/ALE/Recon1d_PPM_H4_2019.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Parabolic Method 1D reconstruction with h4 interpolation for edges
!!
!! This implementation of PPM follows White and Adcroft 2008 \cite white2008, with cells
@@ -8,8 +12,6 @@
!! The first and last cells are always limited to PCM.
module Recon1d_PPM_H4_2019
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : Recon1d, testing
implicit none ; private
diff --git a/src/ALE/Recon1d_PPM_hybgen.F90 b/src/ALE/Recon1d_PPM_hybgen.F90
index 2978dd9269..9d26e27eed 100644
--- a/src/ALE/Recon1d_PPM_hybgen.F90
+++ b/src/ALE/Recon1d_PPM_hybgen.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Piecewise Parabolic Method 1D reconstruction following Colella and Woodward, 1984
!!
!! This implementation of PPM follows Colella and Woodward, 1984 \cite colella1984, with
@@ -10,8 +14,6 @@
!! (reached with "PPM_CW"), are equivalent. Similarly recon1d_ppm_hybgen (this implementation) is equivalent also.
module Recon1d_PPM_hybgen
-! This file is part of MOM6. See LICENSE.md for the license.
-
use Recon1d_type, only : testing
use Recon1d_PPM_CW, only : PPM_CW
@@ -127,14 +129,14 @@ subroutine reconstruct(this, h, u)
this%ur(n) = u(n) ! PCM
this%ul(n) = u(n) ! PCM
- do K = 2, n ! K=2 is interface between cells 1 and 2
+ do K = 2, n-1 ! K=2 is interface between cells 1 and 2
u0 = u(k-1)
u1 = u(k)
u2 = u(k+1)
a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) )
a6 = 6.0 * u1 - 3.0 * ( this%ul(k) + this%ur(k) )
du = this%ur(k) - this%ul(k)
- if ( ( u2 - u1 ) * ( u1 - u0 ) <- 0.0 ) then ! Large scale extrema
+ if ( ( u2 - u1 ) * ( u1 - u0 ) <= 0.0 ) then ! Large scale extrema
this%ul(k) = u1
this%ur(k) = u1
elseif ( du * a6 > du * du ) then ! Extrema on right
diff --git a/src/ALE/Recon1d_type.F90 b/src/ALE/Recon1d_type.F90
index 4411e1288e..505adc6c2e 100644
--- a/src/ALE/Recon1d_type.F90
+++ b/src/ALE/Recon1d_type.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A generic type for vertical 1D reconstructions
module Recon1d_type
-! This file is part of MOM6. See LICENSE.md for the license.
-
use numerical_testing_type, only : testing
implicit none ; private
@@ -15,7 +17,8 @@ module Recon1d_type
integer :: n = 0 !< Number of cells in column
real, allocatable, dimension(:) :: u_mean !< Cell mean [A]
- real :: h_neglect = 0. !< A negligibly small width used in cell reconstructions [same as h, H]
+ real :: h_neglect = 0. !< A negligibly small width used in cell reconstructions in the same units as h [H]
+ real :: x_tolerance = 1. * epsilon(1.) !< Solver tolerance for x in element (0,1) [nondim]
logical :: check = .false. !< If true, enable some consistency checking
logical :: debug = .false. !< If true, dump info as calculations are made (do not enable)
@@ -50,6 +53,8 @@ module Recon1d_type
! The following functions/subroutines are shared across all reconstructions and provided by this module
! unless replaced for the purpose of optimization
+ !> Solves for x such that f(x)=t
+ procedure :: x => x
!> Remaps the column to subgrid h_sub
procedure :: remap_to_sub_grid => remap_to_sub_grid
!> Set debugging
@@ -80,7 +85,7 @@ end subroutine i_init
subroutine i_reconstruct(this, h, u)
import :: Recon1d
class(Recon1d), intent(inout) :: this !< This reconstruction
- real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H]
+ real, intent(in) :: h(*) !< Grid spacing (thickness), typically in [H]
real, intent(in) :: u(*) !< Cell mean values [A]
end subroutine i_reconstruct
@@ -97,7 +102,7 @@ end function i_average
!> Point-wise value of reconstruction [A]
!!
- !! THe function is only valid for 0 <= x <= 1. x is effectively clipped to this range.
+ !! The function is only valid for 0 <= x <= 1. x is effectively clipped to this range.
real function i_f(this, k, x)
import :: Recon1d
class(Recon1d), intent(in) :: this !< This reconstruction
@@ -107,7 +112,7 @@ end function i_f
!> Point-wise value of derivative reconstruction [A]
!!
- !! THe function is only valid for 0 <= x <= 1. x is effectively clipped to this range.
+ !! The function is only valid for 0 <= x <= 1. x is effectively clipped to this range.
real function i_dfdx(this, k, x)
import :: Recon1d
class(Recon1d), intent(in) :: this !< This reconstruction
@@ -115,6 +120,18 @@ real function i_dfdx(this, k, x)
real, intent(in) :: x !< Non-dimensional position within element [nondim]
end function i_dfdx
+ !> Point-wise solver for x: f(x)=t [nondim]
+ !!
+ !! The function solves for the non-dimensional position x within the cell where
+ !! the reconstruction f(x)=t. The solver returns x=0 or x=1 if the target, t,
+ !! is outside of the cell.
+ real function i_x(this, k, t)
+ import :: Recon1d
+ class(Recon1d), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: t !< Value to solve for [A]
+ end function i_x
+
!> Returns true if some inconsistency is detected, false otherwise
!!
!! The nature of "consistency" is defined by the implementations
@@ -122,7 +139,7 @@ end function i_dfdx
logical function i_check_reconstruction(this, h, u)
import :: Recon1d
class(Recon1d), intent(in) :: this !< This reconstruction
- real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H]
+ real, intent(in) :: h(*) !< Grid spacing (thickness), typically in [H]
real, intent(in) :: u(*) !< Cell mean values [A]
end function i_check_reconstruction
@@ -145,7 +162,7 @@ end subroutine i_init_parent
subroutine i_reconstruct_parent(this, h, u)
import :: Recon1d
class(Recon1d), intent(inout) :: this !< This reconstruction
- real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H]
+ real, intent(in) :: h(*) !< Grid spacing (thickness), typically in [H]
real, intent(in) :: u(*) !< Cell mean values [A]
end subroutine i_reconstruct_parent
@@ -164,6 +181,62 @@ end function i_unit_tests
contains
+!> Solve for x such that f(x)=t
+!!
+!! This solver uses bounded Newton-Raphson method with a fixed
+!! number of iterations
+real function x(this, k, t)
+ class(Recon1d), intent(in) :: this !< This reconstruction
+ integer, intent(in) :: k !< Cell number
+ real, intent(in) :: t !< Value to solve for [A]
+ real :: xl, xr, xo ! Left/right bounds and guess [nondim]
+ real :: fl, fr ! Left right values [A]
+ real :: slp ! Difference across cell or derivative wrt nondim x [A]
+ real :: f_at_x ! Value at current x [A]
+ integer :: iter
+
+ x = 0.5 ! Fall back for special conditions
+ fl = this%f(k, 0.)
+ fr = this%f(k, 1.)
+ slp = fr - fl
+ if ( ( fl - t ) * ( t - fr ) > 0. ) then
+ ! t is inside the range fl..fr
+ xl = 0.
+ xr = 1.
+ xo = ( t - this%f(k, 0.) ) / slp ! First guess by regula falsi
+ f_at_x = this%f(k, xo)
+ do iter = 1,10
+ slp = this%dfdx(k, xo)
+ x = xo - ( f_at_x - t ) / slp ! Newton-Raphson step
+ if ( x < xl ) x = 0.5 * ( xl + xo ) ! Replace with bi-section
+ if ( x > xr ) x = 0.5 * ( xr + xo ) ! Replace with bi-section
+ f_at_x = this%f(k, x)
+ if ( abs(f_at_x - t) <= 0. .or. abs(x - xo) < this%x_tolerance ) return
+ if ( f_at_x < t ) xl = x ! Replace left bound
+ if ( f_at_x > t ) xr = x ! Replace right bound
+ xo = x
+ enddo
+ elseif ( abs(slp) > 0. ) then
+ slp = sign(1., slp)
+ ! if t>u_mean & slp=1 then x=1
+ ! if tu_mean & slp=-1 then x=0
+ ! if t 0. ) slp = sign(1., slp)
+ ! if t>u_mean & slp=1 then x=1
+ ! if tu_mean & slp=-1 then x=0
+ ! if t 0. ) x = 0.5 + slp * sign(0.5, t - this%u_mean(k))
+ endif
+end function x
+
!> Remaps the column to subgrid h_sub
!!
!! It is assumed that h_sub is a perfect sub-grid of h0, meaning each h0 cell
diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90
index 0e28ae0395..3b6a068f66 100644
--- a/src/ALE/coord_adapt.F90
+++ b/src/ALE/coord_adapt.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Regrid columns for the adaptive coordinate
module coord_adapt
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS, only : calculate_density_derivs
use MOM_error_handler, only : MOM_error, FATAL
use MOM_unit_scaling, only : unit_scale_type
diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90
index 1e5474770a..03e86663bb 100644
--- a/src/ALE/coord_hycom.F90
+++ b/src/ALE/coord_hycom.F90
@@ -1,16 +1,21 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Regrid columns for the HyCOM coordinate
module coord_hycom
-! This file is part of MOM6. See LICENSE.md for the license.
-
-use MOM_error_handler, only : MOM_error, FATAL
-use MOM_remapping, only : remapping_CS, remapping_core_h
+use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, NOTE
use MOM_EOS, only : EOS_type, calculate_density
+use MOM_remapping, only : remapping_CS, remapping_core_h
+use MOM_variables, only : ocean_grid_type
use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, regridding_set_ppolys
use regrid_interp, only : DEGREE_MAX
implicit none ; private
+#include
+
!> Control structure containing required parameters for the HyCOM coordinate
type, public :: hycom_CS ; private
@@ -32,11 +37,20 @@ module coord_hycom
!> If true, an interface only moves if it improves the density fit
logical :: only_improves = .false.
+ !> If true, use 3-D control fields
+ logical :: use_3d = .false.
+
+ !> Nominal density of interfaces [R ~> kg m-3]
+ real, allocatable, dimension(:,:,:) :: target_density_3d
+
+ !> Nominal near-surface resolution [Z ~> m]
+ real, allocatable, dimension(:,:,:) :: coordinateResolution_3d
+
!> Interpolation control structure
type(interp_CS_type) :: interp_CS
end type hycom_CS
-public init_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom
+public init_coord_hycom, init_3d_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom
contains
@@ -56,18 +70,59 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp
CS%nk = nk
CS%coordinateResolution(:) = coordinateResolution(:)
CS%target_density(:) = target_density(:)
+ CS%use_3d = .false.
CS%interp_CS = interp_CS
+ if (is_root_pe()) call MOM_error(NOTE, "init_coord_hycom: use_3d = .false.")
+
end subroutine init_coord_hycom
+!> Initialise a hycom_CS with pointers to parameters
+subroutine init_3d_coord_hycom(CS, G, nk, coordinateResolution, target_density, interp_CS)
+ type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure
+ type(ocean_grid_type),intent(in) :: G !< Ocean grid structure
+ integer, intent(in) :: nk !< Number of layers in generated grid
+ real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [Z ~> m]
+ real, dimension(SZI_(G),SZJ_(G),nk+1), intent(in) :: target_density !< Interface target densities [R ~> kg m-3]
+ type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation
+ ! Local variables
+ integer :: i,j,k
+
+ if (associated(CS)) call MOM_error(FATAL, "init_3d_coord_hycom: CS already associated!")
+
+ allocate(CS)
+ allocate(CS%coordinateResolution_3d(nk,SZI_(G),SZJ_(G)), source=0.0)
+ allocate(CS%target_density_3d(nk+1,SZI_(G),SZJ_(G)), source=0.0)
+
+ CS%nk = nk
+ CS%use_3d = .true.
+ CS%interp_CS = interp_CS
+
+ do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1
+ if (G%mask2dT(i,j)>0.) then
+ do k= 1,nk
+ CS%coordinateResolution_3d(k,i,j) = coordinateResolution(i,j,k)
+ CS%target_density_3d(k,i,j) = target_density(i,j,k)
+ enddo
+ CS%target_density_3d(nk+1,i,j) = target_density(i,j,nk+1)
+ endif !mask2dT
+ enddo ; enddo
+
+ if (is_root_pe()) call MOM_error(NOTE, "init_3d_coord_hycom: use_3d = .true.")
+
+end subroutine init_3d_coord_hycom
+
!> This subroutine deallocates memory in the control structure for the coord_hycom module
subroutine end_coord_hycom(CS)
type(hycom_CS), pointer :: CS !< Coordinate control structure
! nothing to do
if (.not. associated(CS)) return
- deallocate(CS%coordinateResolution)
- deallocate(CS%target_density)
+
+ if (allocated(CS%coordinateResolution)) deallocate(CS%coordinateResolution)
+ if (allocated(CS%target_density)) deallocate(CS%target_density)
+ if (allocated(CS%coordinateResolution_3d)) deallocate(CS%coordinateResolution_3d)
+ if (allocated(CS%target_density_3d)) deallocate(CS%target_density_3d)
if (allocated(CS%max_interface_depths)) deallocate(CS%max_interface_depths)
if (allocated(CS%max_layer_thickness)) deallocate(CS%max_layer_thickness)
deallocate(CS)
@@ -85,14 +140,14 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, only_
if (present(max_interface_depths)) then
if (size(max_interface_depths) /= CS%nk+1) &
- call MOM_error(FATAL, "set_hycom_params: max_interface_depths inconsistent size")
+ call MOM_error(FATAL, "set_hycom_params: max_interface_depths inconsistent size")
allocate(CS%max_interface_depths(CS%nk+1))
CS%max_interface_depths(:) = max_interface_depths(:)
endif
if (present(max_layer_thickness)) then
if (size(max_layer_thickness) /= CS%nk) &
- call MOM_error(FATAL, "set_hycom_params: max_layer_thickness inconsistent size")
+ call MOM_error(FATAL, "set_hycom_params: max_layer_thickness inconsistent size")
allocate(CS%max_layer_thickness(CS%nk))
CS%max_layer_thickness(:) = max_layer_thickness(:)
endif
@@ -103,12 +158,14 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, only_
end subroutine set_hycom_params
!> Build a HyCOM coordinate column
-subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, &
+subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, ix, jy, depth, h, T, S, p_col, &
z_col, z_col_new, zScale, h_neglect, h_neglect_edge)
type(hycom_CS), intent(in) :: CS !< Coordinate control structure
type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options
type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure
integer, intent(in) :: nz !< Number of levels
+ integer, intent(in) :: ix !< x direction array index
+ integer, intent(in) :: jy !< y direction array index
real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2])
real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC]
real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt]
@@ -150,7 +207,7 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_
z_scale = 1.0 ; if (present(zScale)) z_scale = zScale
if (CS%only_improves .and. nz == CS%nk) then
- call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, &
+ call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, ix, jy, depth, &
h, T, S, p_col, rho_col, RiA_ini, h_neglect, h_neglect_edge)
else
! Work bottom recording potential density
@@ -164,20 +221,25 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_
! Interpolates for the target interface position with the rho_col profile
! Based on global density profile, interpolate to generate a new grid
- call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, &
- CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge)
+ if (CS%use_3d) then
+ call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, &
+ CS%target_density_3d(:,ix,jy), CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge)
+ else
+ call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, &
+ CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge)
+ endif
if (CS%only_improves .and. nz == CS%nk) then
! Only move an interface if it improves the density fit
z_1 = 0.5 * ( z_col(1) + z_col(2) )
z_nz = 0.5 * ( z_col(nz) + z_col(nz+1) )
do k = 1,CS%nk
- p_col_new(k) = p_col(1) + ( 0.5 * ( z_col_new(K) + z_col_new(K+1) ) - z_1 ) / ( z_nz - z_1 ) * &
- ( p_col(nz) - p_col(1) )
+ p_col_new(k) = p_col(1) + ( 0.5 * ( z_col_new(K) + z_col_new(K+1) ) - z_1 ) &
+ / ( z_nz - z_1 ) * ( p_col(nz) - p_col(1) )
enddo
! Remap from original h and T,S to get T,S_col_new
call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new)
call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new)
- call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, &
+ call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, ix, jy, depth, &
h_col_new, T_col_new, S_col_new, p_col_new, r_col_new, RiA_new, h_neglect, h_neglect_edge)
do k= 2,CS%nk
if ( abs(RiA_ini(K)) <= abs(RiA_new(K)) .and. z_col(K) > z_col_new(K-1) .and. &
@@ -191,11 +253,19 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_
! as deep as a nominal target z* grid
nominal_z = 0.
stretching = z_col(nz+1) / depth ! Stretches z* to z
- do k = 2, CS%nk+1
- nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching
- z_col_new(k) = max( z_col_new(k), nominal_z )
- z_col_new(k) = min( z_col_new(k), z_col(nz+1) )
- enddo
+ if (CS%use_3d) then
+ do k = 2, CS%nk+1
+ nominal_z = nominal_z + (z_scale * CS%coordinateResolution_3d(k-1,ix,jy)) * stretching
+ z_col_new(k) = max( z_col_new(k), nominal_z )
+ z_col_new(k) = min( z_col_new(k), z_col(nz+1) )
+ enddo
+ else
+ do k = 2, CS%nk+1
+ nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching
+ z_col_new(k) = max( z_col_new(k), nominal_z )
+ z_col_new(k) = min( z_col_new(k), z_col(nz+1) )
+ enddo
+ endif
if (maximum_depths_set .and. maximum_h_set) then ; do k=2,CS%nk
! The loop bounds are 2 & nz so the top and bottom interfaces do not move.
@@ -210,12 +280,14 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_
end subroutine build_hycom1_column
!> Calculate interface density anomaly w.r.t. the target.
-subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, &
- R, RiAnom, h_neglect, h_neglect_edge)
+subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, ix, jy, depth, h, T, S, &
+ p_col, R, RiAnom, h_neglect, h_neglect_edge)
type(hycom_CS), intent(in) :: CS !< Coordinate control structure
type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options
type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure
integer, intent(in) :: nz !< Number of levels
+ integer, intent(in) :: ix !< x direction array index
+ integer, intent(in) :: jy !< y direction array index
real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2])
real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC]
real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt]
@@ -247,19 +319,35 @@ subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h,
call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h, ppoly_E, ppoly_S, ppoly_C, &
degree, h_neglect, h_neglect_edge)
- R(1) = rho_col(1)
- RiAnom(1) = ppoly_E(1,1) - CS%target_density(1)
- do k= 2,nz
- R(k) = rho_col(k)
- if (ppoly_E(k-1,2) > CS%target_density(k)) then
- RiAnom(k) = ppoly_E(k-1,2) - CS%target_density(k) !interface is heavier than target
- elseif (ppoly_E(k,1) < CS%target_density(k)) then
- RiAnom(k) = ppoly_E(k,1) - CS%target_density(k) !interface is lighter than target
- else
- RiAnom(k) = 0.0 !interface spans the target
- endif
- enddo
- RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density(nz+1)
+ if (CS%use_3d) then
+ R(1) = rho_col(1)
+ RiAnom(1) = ppoly_E(1,1) - CS%target_density_3d(1,ix,jy)
+ do k= 2,nz
+ R(k) = rho_col(k)
+ if (ppoly_E(k-1,2) > CS%target_density_3d(k,ix,jy)) then
+ RiAnom(k) = ppoly_E(k-1,2) - CS%target_density_3d(k,ix,jy) !interface is heavier than target
+ elseif (ppoly_E(k,1) < CS%target_density_3d(k,ix,jy)) then
+ RiAnom(k) = ppoly_E(k,1) - CS%target_density_3d(k,ix,jy) !interface is lighter than target
+ else
+ RiAnom(k) = 0.0 !interface spans the target
+ endif
+ enddo
+ RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density_3d(nz+1,ix,jy)
+ else
+ R(1) = rho_col(1)
+ RiAnom(1) = ppoly_E(1,1) - CS%target_density(1)
+ do k= 2,nz
+ R(k) = rho_col(k)
+ if (ppoly_E(k-1,2) > CS%target_density(k)) then
+ RiAnom(k) = ppoly_E(k-1,2) - CS%target_density(k) !interface is heavier than target
+ elseif (ppoly_E(k,1) < CS%target_density(k)) then
+ RiAnom(k) = ppoly_E(k,1) - CS%target_density(k) !interface is lighter than target
+ else
+ RiAnom(k) = 0.0 !interface spans the target
+ endif
+ enddo
+ RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density(nz+1)
+ endif !use_3d:else
end subroutine build_hycom1_target_anomaly
diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90
index c967687dc8..904517ef15 100644
--- a/src/ALE/coord_rho.F90
+++ b/src/ALE/coord_rho.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Regrid columns for the continuous isopycnal (rho) coordinate
module coord_rho
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL
use MOM_remapping, only : remapping_CS, remapping_core_h
use MOM_EOS, only : EOS_type, calculate_density
diff --git a/src/ALE/coord_sigma.F90 b/src/ALE/coord_sigma.F90
index a2a5820487..60e05654d9 100644
--- a/src/ALE/coord_sigma.F90
+++ b/src/ALE/coord_sigma.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Regrid columns for the sigma coordinate
module coord_sigma
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL
implicit none ; private
diff --git a/src/ALE/coord_zlike.F90 b/src/ALE/coord_zlike.F90
index 7f284217b2..ad7772d7ae 100644
--- a/src/ALE/coord_zlike.F90
+++ b/src/ALE/coord_zlike.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Regrid columns for a z-like coordinate (z-star, z-level)
module coord_zlike
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL
implicit none ; private
diff --git a/src/ALE/polynomial_functions.F90 b/src/ALE/polynomial_functions.F90
index b01e097b83..0b232dc359 100644
--- a/src/ALE/polynomial_functions.F90
+++ b/src/ALE/polynomial_functions.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Polynomial functions
module polynomial_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public :: evaluation_polynomial, integration_polynomial, first_derivative_polynomial
diff --git a/src/ALE/regrid_consts.F90 b/src/ALE/regrid_consts.F90
index 0c5ccf268f..b3ca485f0a 100644
--- a/src/ALE/regrid_consts.F90
+++ b/src/ALE/regrid_consts.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Contains constants for interpreting input parameters that control regridding.
module regrid_consts
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL
use MOM_string_functions, only : uppercase
diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90
index 54cec45cba..15dc4a2005 100644
--- a/src/ALE/regrid_edge_values.F90
+++ b/src/ALE/regrid_edge_values.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Edge value estimation for high-order reconstruction
module regrid_edge_values
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL
use regrid_solvers, only : solve_linear_system, linear_solver
use regrid_solvers, only : solve_tridiagonal_system, solve_diag_dominant_tridiag
@@ -1003,7 +1005,8 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date
real, dimension(7) :: x ! Coordinate system with 0 at edges in the same units as h [H]
real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim]
real, parameter :: C5_6 = 5.0 / 6.0 ! A rational parameter [nondim]
- real :: dx, xavg ! Differences and averages of successive values of x [same units as h]
+ real :: dx ! Differences between successive values of x in the same units as h [H]
+ real :: xavg ! Average of successive values of x in the same units as h [H]
real, dimension(6,6) :: Asys ! The matrix that is being inverted for a solution,
! in units that might vary with the second (j) index as [H^j]
real, dimension(6) :: Bsys ! The right hand side of the system to solve for C in various
diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90
index 6e0be9ebba..e2b756c334 100644
--- a/src/ALE/regrid_interp.F90
+++ b/src/ALE/regrid_interp.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Vertical interpolation for regridding
module regrid_interp
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL
use MOM_string_functions, only : uppercase
@@ -335,19 +337,19 @@ subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values,
integer, intent(in) :: n1 !< The number of points on the output grid
real, dimension(n0), intent(in) :: densities !< Input cell densities [R ~> kg m-3]
real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces [R ~> kg m-3]
- real, dimension(n0), intent(in) :: h0 !< Initial cell widths [H]
- real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H]
- real, dimension(n1), intent(inout) :: h1 !< Output cell widths [H]
- real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H]
+ real, dimension(n0), intent(in) :: h0 !< Initial cell widths usually in [H ~> m or kg m-2] or [Z ~> m]
+ real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H ~> m or kg m-2] or [Z ~> m]
+ real, dimension(n1), intent(inout) :: h1 !< Output cell widths [H ~> m or kg m-2] or [Z ~> m]
+ real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H ~> m or kg m-2] or [Z ~> m]
real, intent(in) :: h_neglect !< A negligibly small width for the
- !! purpose of cell reconstructions [H]
- !! in the same units as h0.
- real, optional, intent(in) :: h_neglect_edge !< A negligibly small width
- !! for the purpose of edge value calculations [H]
- !! in the same units as h0.
+ !! purpose of cell reconstructions in the same
+ !! units as h0 [H ~> m or kg m-2] or [Z ~> m].
+ real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the
+ !! purpose of edge value calculations in the same
+ !! units as h0 [H ~> m or kg m-2] or [Z ~> m]
real, dimension(n0,2) :: ppoly0_E ! Polynomial edge values [R ~> kg m-3]
- real, dimension(n0,2) :: ppoly0_S ! Polynomial edge slopes [R H-1]
+ real, dimension(n0,2) :: ppoly0_S ! Polynomial edge slopes [R H-1 ~> kg m-4 or m-1] or [R Z-1 ~> kg m-4]
real, dimension(n0,DEGREE_MAX+1) :: ppoly0_C ! Polynomial interpolant coeficients on the local 0-1 grid [R ~> kg m-3]
integer :: degree
diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90
index 6e5b3a0cb0..328a06204a 100644
--- a/src/ALE/regrid_solvers.F90
+++ b/src/ALE/regrid_solvers.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Solvers of linear systems.
module regrid_solvers
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL
implicit none ; private
@@ -164,7 +166,7 @@ subroutine linear_solver( N, A, R, X )
if (A(N,N) == 0.0) then
! no pivot could be found, and the sytem is singular
call MOM_error(FATAL, 'The final pivot in linear_solver is zero.')
- end if
+ endif
! Solve the system by back substituting into what is now an upper-right matrix.
X(N) = R(N) / A(N,N) ! The last row is now trivially solved.
diff --git a/src/core/MOM.F90 b/src/core/MOM.F90
index 156a397ff6..120c0481e3 100644
--- a/src/core/MOM.F90
+++ b/src/core/MOM.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The central module of the MOM6 ocean model
module MOM
-! This file is part of MOM6. See LICENSE.md for the license.
-
! Infrastructure modules
use MOM_array_transform, only : rotate_array, rotate_vector
use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum, totalTandS
@@ -44,7 +46,7 @@ module MOM
use MOM_restart, only : query_initialized, set_initialized, restart_registry_lock
use MOM_restart, only : restart_init, is_new_run, determine_is_new_run, MOM_restart_CS
use MOM_spatial_means, only : global_mass_integral
-use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+)
+use MOM_time_manager, only : time_type, real_to_time, operator(+)
use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/)
use MOM_time_manager, only : operator(>=), operator(==), increment_date
use MOM_unit_tests, only : unit_tests
@@ -96,13 +98,14 @@ module MOM
use MOM_forcing_type, only : homogenize_forcing, homogenize_mech_forcing
use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end
use MOM_grid, only : set_first_direction
-use MOM_harmonic_analysis, only : HA_accum_FtF, HA_accum_FtSSH, harmonic_analysis_CS
+use MOM_harmonic_analysis, only : HA_accum, harmonic_analysis_CS
use MOM_hor_index, only : hor_index_type, hor_index_init
use MOM_hor_index, only : rotate_hor_index
use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz
use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end
use MOM_interface_filter, only : interface_filter_CS
use MOM_internal_tides, only : int_tide_CS
+use MOM_kappa_shear, only : kappa_shear_at_vertex
use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end
use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS
use MOM_MEKE, only : MEKE_alloc_register_restart, step_forward_MEKE
@@ -111,11 +114,16 @@ 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 : read_OBC_segment_data, initialize_OBC_segment_reservoirs
+use MOM_open_boundary, only : setup_OBC_tracer_reservoirs
+use MOM_open_boundary, only : setup_OBC_thickness_reservoirs
use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields
-use MOM_open_boundary, only : open_boundary_setup_vert
-use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init
+use MOM_open_boundary, only : open_boundary_setup_vert, initialize_segment_data
+use MOM_open_boundary, only : update_OBC_segment_data, rotate_OBC_config
+use MOM_open_boundary, only : open_boundary_halo_update, write_OBC_info, chksum_OBC_segments
+use MOM_open_boundary, only : segment_thickness_reservoir_init
use MOM_porous_barriers, only : porous_widths_layer, porous_widths_interface, porous_barriers_init
use MOM_porous_barriers, only : porous_barrier_CS
use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS
@@ -123,7 +131,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
@@ -222,17 +230,19 @@ module MOM
real :: time_in_thermo_cycle !< The running time of the current time-stepping
!! cycle in calls that step the thermodynamics [T ~> s].
- type(ocean_grid_type) :: G_in !< Input grid metric
+ type(ocean_grid_type), allocatable :: G_in !< Input grid metric
type(ocean_grid_type), pointer :: G => NULL() !< Model grid metric
logical :: rotate_index = .false. !< True if index map is rotated
logical :: homogenize_forcings = .false. !< True if all inputs are homogenized
logical :: update_ustar = .false. !< True to update ustar from homogenized tau
+ logical :: vertex_shear = .false. !< True if vertex shear is on
type(verticalGrid_type), pointer :: &
GV => NULL() !< structure containing vertical grid info
type(unit_scale_type), pointer :: &
US => NULL() !< structure containing various unit conversion factors
- type(thermo_var_ptrs) :: tv !< structure containing pointers to available thermodynamic fields
+ type(thermo_var_ptrs), allocatable :: tv
+ !< structure containing pointers to available thermodynamic fields
real :: t_dyn_rel_adv !< The time of the dynamics relative to tracer advection and lateral mixing
!! [T ~> s], or equivalently the elapsed time since advectively updating the
!! tracers. t_dyn_rel_adv is invariably positive and may span multiple coupling timesteps.
@@ -248,8 +258,8 @@ module MOM
!! have been stored for use in diagnostics.
type(diag_ctrl) :: diag !< structure to regulate diagnostic output timing
- type(vertvisc_type) :: visc !< structure containing vertical viscosities,
- !! bottom drag viscosities, and related fields
+ type(vertvisc_type), allocatable :: visc
+ !< structure containing vertical viscosities, bottom drag viscosities, and related fields
type(MEKE_type) :: MEKE !< Fields related to the Mesoscale Eddy Kinetic Energy
logical :: adiabatic !< If true, there are no diapycnal mass fluxes, and no calls
!! to routines to calculate or apply diapycnal fluxes.
@@ -286,9 +296,12 @@ 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.
+ integer :: dyn_h_stencil !< The stencil for thickness for the dynamics based on
+ !! the continuity solver and Coriolis schemes.
! These elements are used to control the dynamics updates.
logical :: do_dynamics !< If false, does not call step_MOM_dyn_*. This is an
!! undocumented run-time flag that is fragile.
@@ -309,8 +322,6 @@ module MOM
logical :: useMEKE !< If true, call the MEKE parameterization.
logical :: use_stochastic_EOS !< If true, use the stochastic EOS parameterizations.
logical :: useWaves !< If true, update Stokes drift
- logical :: use_diabatic_time_bug !< If true, uses the wrong calendar time for diabatic processes,
- !! as was done in MOM6 versions prior to February 2018.
real :: dtbt_reset_period !< The time interval between dynamic recalculation of the
!! barotropic time step [T ~> s]. If this is negative dtbt is never
!! calculated, and if it is 0, dtbt is calculated every step.
@@ -326,7 +337,7 @@ module MOM
real, dimension(:,:), pointer :: frac_shelf_h => NULL() !< fraction of total area occupied
!! by ice shelf [nondim]
real, dimension(:,:), pointer :: mass_shelf => NULL() !< Mass of ice shelf [R Z ~> kg m-2]
- type(accel_diag_ptrs) :: ADp !< structure containing pointers to accelerations,
+ type(accel_diag_ptrs), allocatable :: ADp !< structure containing pointers to accelerations,
!! for derived diagnostics (e.g., energy budgets)
type(cont_diag_ptrs) :: CDp !< structure containing pointers to continuity equation
!! terms, for derived diagnostics (e.g., energy budgets)
@@ -377,6 +388,7 @@ module MOM
!! roundoff for non-Boussinesq cases.
logical :: use_particles !< Turns on the particles package
logical :: use_uh_particles !< particles are advected by uh/h
+ logical :: uh_particles_bug !< If true, uses an inconsistent timestep for particle advection
logical :: use_dbclient !< Turns on the database client used for ML inference/analysis
character(len=10) :: particle_type !< Particle types include: surface(default), profiling and sail drone.
@@ -411,7 +423,7 @@ module MOM
!< Pointer to the control structure for the diabatic driver
type(MEKE_CS) :: MEKE_CSp
!< Pointer to the control structure for the MEKE updates
- type(VarMix_CS) :: VarMix
+ type(VarMix_CS), allocatable :: VarMix
!< Control structure for the variable mixing module
type(tracer_registry_type), pointer :: tracer_Reg => NULL()
!< Pointer to the MOM tracer registry
@@ -475,6 +487,7 @@ module MOM
integer :: id_clock_ocean
integer :: id_clock_dynamics
integer :: id_clock_thermo
+integer :: id_clock_MOM_end
integer :: id_clock_remap
integer :: id_clock_tracer
integer :: id_clock_diabatic
@@ -493,6 +506,7 @@ module MOM
integer :: id_clock_ALE
integer :: id_clock_other
integer :: id_clock_offline_tracer
+integer :: id_clock_save_restart
integer :: id_clock_unit_tests
integer :: id_clock_stoch
integer :: id_clock_varT
@@ -596,6 +610,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
real :: I_wt_ssh ! The inverse of the time weights [T-1 ~> s-1]
type(time_type) :: Time_local, end_time_thermo
+ type(time_type) :: Time_end_diag ! End time of a diagnostic segment, as a time type
+
type(group_pass_type) :: pass_tau_ustar_psurf
logical :: showCallTree
@@ -626,6 +642,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
call cpu_clock_begin(id_clock_other)
if (CS%debug) then
+ !$omp target update from(u, v, h)
call query_debugging_checks(do_redundant=debug_redundant)
call MOM_state_chksum("Beginning of step_MOM ", u, v, h, CS%uh, CS%vh, G, GV, US)
endif
@@ -661,6 +678,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
call set_derived_forcing_fields(forces, fluxes, G, US, GV%Rho0)
endif
endif
+ !$omp target enter data map(to: forces, forces%taux, forces%tauy, forces%ustar)
! This will be replaced later with the pressures from forces or fluxes if they are available.
if (associated(CS%tv%p_surf)) CS%tv%p_surf(:,:) = 0.0
@@ -670,6 +688,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)
+
dt = time_interval / real(n_max)
thermo_does_span_coupling = (CS%thermo_spans_coupling .and. &
(CS%dt_therm > 1.5*cycle_time))
@@ -682,7 +701,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
elseif (.not.do_thermo) then
dt_therm = CS%dt_therm
if (present(cycle_length)) dt_therm = min(CS%dt_therm, cycle_length)
- ! ntstep is not used.
+ ntstep = 1 ! ntstep is initialized to avoid an error in a secondary logical test,
+ ! but the nonzero value of ntstep does not matter when do_thermo is false.
else
ntstep = MAX(1, MIN(n_max, floor(CS%dt_therm/dt + 0.001)))
dt_therm = dt*ntstep
@@ -694,7 +714,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
elseif (.not.do_thermo) then
dt_tr_adv = CS%dt_tr_adv
if (present(cycle_length)) dt_tr_adv = min(CS%dt_tr_adv, cycle_length)
- ! ntstep is not used.
+ ! ntastep is not used.
else
ntastep = MAX(1, MIN(n_max, floor(CS%dt_tr_adv/dt + 0.001)))
dt_tr_adv = dt*ntastep
@@ -719,7 +739,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
if (nonblocking_p_surf_update) then
call start_group_pass(pass_tau_ustar_psurf, G%Domain)
else
- call do_group_pass(pass_tau_ustar_psurf, G%Domain)
+ call do_group_pass(pass_tau_ustar_psurf, G%Domain, omp_offload=.true.)
endif
call cpu_clock_end(id_clock_pass)
@@ -729,6 +749,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
do j=jsd,jed ; do i=isd,ied ; CS%tv%p_surf(i,j) = forces%p_surf(i,j) ; enddo ; enddo
if (allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) then
+ !$omp target update from(h)
! The internal ocean state depends on the surface pressues, so update SpV_avg.
dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo)
call calc_derived_thermo(CS%tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug)
@@ -753,6 +774,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
if (associated(CS%tv%p_surf) .and. associated(fluxes%p_surf)) then
do j=js,je ; do i=is,ie ; CS%tv%p_surf(i,j) = fluxes%p_surf(i,j) ; enddo ; enddo
if (allocated(CS%tv%SpV_avg)) then
+ !$omp target update from(h)
call pass_var(CS%tv%p_surf, G%Domain, clock=id_clock_pass)
! The internal ocean state depends on the surface pressues, so update SpV_avg.
call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz)
@@ -764,7 +786,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
@@ -772,11 +797,14 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
if (cycle_start) then
CS%time_in_cycle = 0.0
- do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo
+ do concurrent (j=js:je, i=is:ie)
+ CS%ssh_rint(i,j) = 0.
+ enddo
if (CS%VarMix%use_variable_mixing) then
- call enable_averages(cycle_time, Time_start + real_to_time(US%T_to_s*cycle_time), CS%diag)
- call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, dt)
+ Time_end_diag = Time_start + real_to_time(cycle_time, unscale=US%T_to_s)
+ call enable_averages(cycle_time, Time_end_diag, CS%diag)
+ call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, CS%OBC, dt)
call calc_depth_function(G, CS%VarMix)
call disable_averaging(CS%diag)
endif
@@ -803,7 +831,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
endif
if (CS%UseWaves) then
! Update wave information, which is presently kept static over each call to step_mom
- call enable_averages(time_interval, Time_start + real_to_time(US%T_to_s*time_interval), CS%diag)
+ !$omp target update from(h)
+ Time_end_diag = Time_start + real_to_time(time_interval, unscale=US%T_to_s)
+ call enable_averages(time_interval, Time_end_diag, CS%diag)
call find_ustar(forces, CS%tv, U_star, G, GV, US, halo=1)
call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1)
call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn)
@@ -811,6 +841,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
endif
else ! not do_dyn.
if (CS%UseWaves) then ! Diagnostics are not enabled in this call.
+ !$omp target update from(h)
call find_ustar(fluxes, CS%tv, U_star, G, GV, US, halo=1)
call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1)
call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn)
@@ -818,6 +849,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
endif
if (CS%debug) then
+ !$omp target update from(u, v, h)
if (cycle_start) &
call MOM_state_chksum("Before steps ", u, v, h, CS%uh, CS%vh, G, GV, US)
if (cycle_start .and. debug_redundant) &
@@ -830,18 +862,16 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
call cpu_clock_end(id_clock_other)
rel_time = 0.0
+
+ ! TODO: This appears safe to remove but needs verification.
+ !**!$omp target update to(u, v, h, CS%uhtr, CS%vhtr)
+
do n=1,n_max
- if (CS%use_diabatic_time_bug) then
- ! This wrong form of update was used until Feb 2018, recovered with CS%use_diabatic_time_bug=T.
- CS%Time = Time_start + real_to_time(US%T_to_s*int(floor(rel_time+0.5*dt+0.5)))
- rel_time = rel_time + dt
- else
- rel_time = rel_time + dt ! The relative time at the end of the step.
- ! Set the universally visible time to the middle of the time step.
- CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt))
- endif
+ rel_time = rel_time + dt ! The relative time at the end of the step.
+ ! Set the universally visible time to the middle of the time step.
+ CS%Time = Time_start + real_to_time(rel_time - 0.5*dt, unscale=US%T_to_s)
! Set the local time to the end of the time step.
- Time_local = Time_start + real_to_time(US%T_to_s*rel_time)
+ Time_local = Time_start + real_to_time(rel_time, unscale=US%T_to_s)
if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n)
@@ -852,7 +882,6 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
!===========================================================================
! This is the first place where the diabatic processes and remapping could occur.
if (CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0) .and. do_thermo) then ! do thermodynamics.
-
if (.not.do_dyn) then
dtdia = dt
elseif (thermo_does_span_coupling) then
@@ -869,34 +898,35 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
endif
end_time_thermo = Time_local
- if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) then
+ if (dtdia > dt) then
! If necessary, temporarily reset CS%Time to the center of the period covered
! by the call to step_MOM_thermo, noting that they begin at the same time.
- ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T.
- CS%Time = CS%Time + real_to_time(0.5*US%T_to_s*(dtdia-dt))
- endif
- if (dtdia > dt .or. CS%use_diabatic_time_bug) then
+ CS%Time = CS%Time + real_to_time(0.5*(dtdia-dt), unscale=US%T_to_s)
! The end-time of the diagnostic interval needs to be set ahead if there
! are multiple dynamic time steps worth of thermodynamics applied here.
- ! This line was not conditional prior to Feb 2018, recovered with CS%use_diabatic_time_bug=T.
- end_time_thermo = Time_local + real_to_time(US%T_to_s*(dtdia-dt))
+ end_time_thermo = Time_local + real_to_time(dtdia-dt, unscale=US%T_to_s)
endif
! Apply diabatic forcing, do mixing, and regrid.
call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, &
end_time_thermo, .true., Waves=Waves)
- if ( CS%use_ALE_algorithm ) &
+
+ if ( CS%use_ALE_algorithm ) then
+ !$omp target update from(u, v, h)
call ALE_regridding_and_remapping(CS, G, GV, US, u, v, h, CS%tv, dtdia, Time_local)
+ !$omp target update to(u, v, h)
+ endif
+
call post_diabatic_halo_updates(CS, G, GV, US, u, v, h, CS%tv)
+
CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia
! The diabatic processes are now ahead of the dynamics by dtdia.
CS%t_dyn_rel_thermo = -dtdia
if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)")
- if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & ! Reset CS%Time to its previous value.
- ! This step was missing prior to Feb 2018, recovered with CS%use_diabatic_time_bug=T.
- CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt))
+ if (dtdia > dt) & ! Reset CS%Time to its previous value.
+ CS%Time = Time_start + real_to_time(rel_time - 0.5*dt, unscale=US%T_to_s)
endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))"
if (do_dyn) then
@@ -904,12 +934,14 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
! advective tendencies. If there are more than one dynamics steps per advective
! step (i.e DT_THERM > DT), this needs to be stored at the first dynamics call.
if (.not.CS%preadv_h_stored .and. (CS%t_dyn_rel_adv == 0.)) then
+ !$omp target update from(h)
call diag_copy_diag_to_storage(CS%diag_pre_dyn, h, CS%diag)
CS%preadv_h_stored = .true.
endif
! The pre-dynamics velocities might be stored for debugging truncations.
if (associated(CS%u_prev) .and. associated(CS%v_prev)) then
+ !$omp target update from(u, v)
do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB
CS%u_prev(I,j,k) = u(I,j,k)
enddo ; enddo ; enddo
@@ -950,42 +982,38 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
enddo ; enddo
endif
- if (associated(CS%HA_CSp)) call HA_accum_FtF(Time_Local, CS%HA_CSp)
-
call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, &
dt_tradv_here, bbl_time_int, CS, &
Time_local, Waves=Waves)
!===========================================================================
! 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
if (do_advection) then ! Do advective transport and lateral tracer mixing.
+ !$omp target update from(h, CS%uhtr, CS%vhtr)
call step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local)
if (CS%diabatic_first .and. abs(CS%t_dyn_rel_thermo) > 1e-6*dt) call MOM_error(FATAL, &
"step_MOM: Mismatch between the dynamics and diabatic times "//&
"with DIABATIC_FIRST.")
+ !$omp target update to(CS%uhtr, CS%vhtr)
endif
endif ! end of (do_dyn)
!===========================================================================
! 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
! by the coupler, the value of diabatic_first does not matter.
@@ -999,16 +1027,21 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
! If necessary, temporarily reset CS%Time to the center of the period covered
! by the call to step_MOM_thermo, noting that they end at the same time.
- ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T.
- if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) &
- CS%Time = CS%Time - real_to_time(0.5*US%T_to_s*(dtdia-dt))
+ if (dtdia > dt) &
+ CS%Time = CS%Time - real_to_time(0.5*(dtdia-dt), unscale=US%T_to_s)
! Apply diabatic forcing, do mixing, and regrid.
call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, &
Time_local, .false., Waves=Waves)
- if ( CS%use_ALE_algorithm ) &
+
+ if ( CS%use_ALE_algorithm ) then
+ !$omp target update from(u, v, h)
call ALE_regridding_and_remapping(CS, G, GV, US, u, v, h, CS%tv, dtdia, Time_local)
+ !$omp target update to(u, v, h)
+ endif
+
call post_diabatic_halo_updates(CS, G, GV, US, u, v, h, CS%tv)
+
CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia
if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then
@@ -1019,32 +1052,41 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
endif
! Reset CS%Time to its previous value.
- ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T.
- if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) &
- CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt))
+ if (dtdia > dt) &
+ CS%Time = Time_start + real_to_time(rel_time - 0.5*dt, unscale=US%T_to_s)
endif
if (do_dyn) then
+ !$omp target enter data map(alloc: ssh)
+
call cpu_clock_begin(id_clock_dynamics)
! Determining the time-average sea surface height is part of the algorithm.
! This may be eta_av if Boussinesq, or need to be diagnosed if not.
CS%time_in_cycle = CS%time_in_cycle + dt
- call find_eta(h, CS%tv, G, GV, US, ssh, CS%eta_av_bc, dZref=G%Z_ref)
- do j=js,je ; do i=is,ie
- CS%ssh_rint(i,j) = CS%ssh_rint(i,j) + dt*ssh(i,j)
- enddo ; enddo
+ !$omp target enter data map(to: CS%eta_av_bc)
+ call find_eta(h, CS%tv, G, GV, US, ssh, eta_bt=CS%eta_av_bc, dZref=G%Z_ref)
+ !$omp target exit data map(release: CS%eta_av_bc)
+
+ do concurrent (j=js:je, i=is:ie)
+ CS%ssh_rint(i,j) = CS%ssh_rint(i,j) + dt * ssh(i,j)
+ enddo
+
if (CS%IDs%id_ssh_inst > 0) then
+ !$omp target update from(ssh)
call enable_averages(dt, Time_local, CS%diag)
call post_data(CS%IDs%id_ssh_inst, ssh, CS%diag)
call disable_averaging(CS%diag)
endif
call cpu_clock_end(id_clock_dynamics)
+
+ !$omp target exit data map(delete: ssh)
endif
!===========================================================================
! Calculate diagnostics at the end of the time step if the state is self-consistent.
if (MOM_state_is_synchronized(CS)) then
!### Perhaps this should be if (CS%t_dyn_rel_thermo == 0.0)
+ !$omp target update from(u, v, h, CS%uhtr, CS%vhtr)
call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics)
! Diagnostics that require the complete state to be up-to-date can be calculated.
@@ -1063,20 +1105,30 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
if (do_dyn .and. .not.CS%count_calls) CS%nstep_tot = CS%nstep_tot + 1
if (showCallTree) call callTree_leave("DT cycles (step_MOM)")
+ enddo
- enddo ! complete the n loop
+ ! TODO: This appears safe to remove but needs verification.
+ !**!$omp target update from(u, v, h, CS%uhtr, CS%vhtr)
if (CS%count_calls .and. cycle_start) CS%nstep_tot = CS%nstep_tot + 1
call cpu_clock_begin(id_clock_other)
if (CS%time_in_cycle > 0.0) then
+ !$omp target enter data map(alloc: ssh)
+
I_wt_ssh = 1.0/CS%time_in_cycle
- do j=js,je ; do i=is,ie
- ssh(i,j) = CS%ssh_rint(i,j)*I_wt_ssh
+ do concurrent (j=js:je, i=is:ie)
+ ssh(i,j) = CS%ssh_rint(i,j) * I_wt_ssh
CS%ave_ssh_ibc(i,j) = ssh(i,j)
- enddo ; enddo
- if (associated(CS%HA_CSp)) call HA_accum_FtSSH('ssh', ssh, Time_local, G, CS%HA_CSp)
+ enddo
+ !$omp target update from(CS%ave_ssh_ibc)
+
+ if (associated(CS%HA_CSp)) then
+ !$omp target update from(ssh)
+ call HA_accum('ssh', ssh, Time_local, G, CS%HA_CSp)
+ endif
+
if (do_dyn) then
call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, &
CS%calc_rho_for_sea_lev)
@@ -1114,15 +1166,24 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
endif
call cpu_clock_begin(id_clock_diagnostics)
+
+ !$omp target update from(ssh) &
+ !$omp if (CS%time_in_cycle > 0. .or. CS%time_in_thermo_cycle > 0.)
+
if (CS%time_in_cycle > 0.0) then
call enable_averages(CS%time_in_cycle, Time_local, CS%diag)
call post_surface_dyn_diags(CS%sfc_IDs, G, CS%diag, sfc_state_diag, ssh)
endif
+
if (CS%time_in_thermo_cycle > 0.0) then
call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag)
call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, &
sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc)
endif
+
+ !$omp target exit data map(delete: ssh) &
+ !$omp if (CS%time_in_cycle > 0. .or. CS%time_in_thermo_cycle > 0.)
+
call disable_averaging(CS%diag)
call cpu_clock_end(id_clock_diagnostics)
if (CS%rotate_index) then
@@ -1136,11 +1197,12 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS
call accumulate_net_input(fluxes, sfc_state, CS%tv, fluxes%dt_buoy_accum, &
G, US, CS%sum_output_CSp)
- if (MOM_state_is_synchronized(CS)) &
+ if (MOM_state_is_synchronized(CS)) then
+ !$omp target update from(u, v, h)
call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, &
G, GV, US, CS%sum_output_CSp, CS%tracer_flow_CSp, &
- dt_forcing=real_to_time(US%T_to_s*time_interval) )
-
+ dt_forcing=real_to_time(time_interval, unscale=US%T_to_s) )
+ endif
call cpu_clock_end(id_clock_other)
! De-rotate fluxes and copy back to the input, since they can be changed.
@@ -1192,6 +1254,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
v => NULL(), & ! v : meridional velocity component [L T-1 ~> m s-1]
h => NULL() ! h : layer thickness [H ~> m or kg m-2]
+ type(time_type) :: Time_end_diag ! End time of a diagnostic segment, as a time type
logical :: calc_dtbt ! Indicates whether the dynamically adjusted
! barotropic time step needs to be updated.
logical :: showCallTree
@@ -1208,9 +1271,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
showCallTree = callTree_showQuery()
call cpu_clock_begin(id_clock_dynamics)
+
call cpu_clock_begin(id_clock_stoch)
if (CS%use_stochastic_EOS) call MOM_stoch_eos_run(G, u, v, dt, Time_local, CS%stoch_eos_CS)
call cpu_clock_end(id_clock_stoch)
+
call cpu_clock_begin(id_clock_varT)
if (CS%use_stochastic_EOS) then
call MOM_calc_varT(G, GV, US, h, CS%tv, CS%stoch_eos_CS, dt)
@@ -1221,27 +1286,35 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse_first .and. &
(CS%thickness_diffuse .or. CS%interface_filter)) then
- call enable_averages(dt_tr_adv, Time_local+real_to_time(US%T_to_s*(dt_tr_adv-dt)), CS%diag)
+ Time_end_diag = Time_local + real_to_time(dt_tr_adv - dt, unscale=US%T_to_s)
+ call enable_averages(dt_tr_adv, Time_end_diag, CS%diag)
if (CS%thickness_diffuse) then
+ !$omp target update from(h, CS%uhtr, CS%vhtr)
call cpu_clock_begin(id_clock_thick_diff)
+
if (CS%VarMix%use_variable_mixing) &
call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC)
+
call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_tr_adv, G, GV, US, &
CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, &
CS%stoch_CS)
+
call cpu_clock_end(id_clock_thick_diff)
- call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil))
+ call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil)
+ !$omp target update to(h, CS%uhtr, CS%vhtr)
if (showCallTree) call callTree_waypoint("finished thickness_diffuse_first (step_MOM)")
endif
if (CS%interface_filter) then
+ !$omp target update from(h, CS%uhtr, CS%vhtr)
if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass)
CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo)
call cpu_clock_begin(id_clock_int_filter)
call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_tr_adv, G, GV, US, &
CS%CDp, CS%interface_filter_CSp)
call cpu_clock_end(id_clock_int_filter)
- call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil))
+ call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil)
+ !$omp target update to(h, CS%uhtr, CS%vhtr)
if (showCallTree) call callTree_waypoint("finished interface_filter_first (step_MOM)")
endif
@@ -1253,17 +1326,19 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
! Update porous barrier fractional cell metrics
if (CS%use_porbar) then
+ !$omp target update from(h)
call enable_averages(dt, Time_local, CS%diag)
call porous_widths_layer(h, CS%tv, G, GV, US, CS%pbv, CS%por_bar_CS)
call disable_averaging(CS%diag)
call pass_vector(CS%pbv%por_face_areaU, CS%pbv%por_face_areaV, &
G%Domain, direction=To_All+SCALAR_PAIR, clock=id_clock_pass, halo=CS%cont_stencil)
+ !$omp target update to(CS%pbv%por_face_areaU, CS%pbv%por_face_areaV)
endif
! The bottom boundary layer properties need to be recalculated.
if (bbl_time_int > 0.0) then
- call enable_averages(bbl_time_int, &
- Time_local + real_to_time(US%T_to_s*(bbl_time_int-dt)), CS%diag)
+ Time_end_diag = Time_local + real_to_time(bbl_time_int - dt, unscale=US%T_to_s)
+ call enable_averages(bbl_time_int, Time_end_diag, CS%diag)
! Calculate the BBL properties and store them inside visc (u,h).
call cpu_clock_begin(id_clock_BBL_visc)
call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, US, CS%set_visc_CSp, CS%pbv)
@@ -1283,6 +1358,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,
@@ -1298,16 +1374,22 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
endif
if (CS%use_alt_split) then
+ !$omp target update from(u, v, h, CS%uhtr, CS%vhtr)
+ !$omp target update from(CS%visc%bbl_thick_u, CS%visc%bbl_thick_v)
+ !$omp target update from(CS%visc%kv_bbl_u, CS%visc%kv_bbl_v)
call step_MOM_dyn_split_RK2b(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, &
p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, &
CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2b_CSp, calc_dtbt, CS%VarMix, &
CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves)
+ !$omp target update to(u, v, h, CS%uhtr, CS%vhtr)
else
call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, &
p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, &
CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, &
CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, CS%stoch_CS, waves=waves)
+ ! TODO: uh, vh, CS%eta_av_bc ?
endif
+
if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_split (step_MOM)")
elseif (CS%do_dynamics) then ! ------------------------------------ not SPLIT
@@ -1319,41 +1401,50 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
! useful for debugging purposes.
if (CS%use_RK2) then
+ !$omp target update from(u, v, h, CS%uhtr, CS%vhtr)
+ !$omp target update from(CS%visc%bbl_thick_u, CS%visc%bbl_thick_v)
+ !$omp target update from(CS%visc%kv_bbl_u, CS%visc%kv_bbl_v)
call step_MOM_dyn_unsplit_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, &
p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, &
CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE, CS%pbv, &
CS%stoch_CS)
+ !$omp target update to(u, v, h, CS%uhtr, CS%vhtr)
else
+ !$omp target update from(u, v, h, CS%uhtr, CS%vhtr)
+ !$omp target update from(CS%visc%bbl_thick_u, CS%visc%bbl_thick_v)
+ !$omp target update from(CS%visc%kv_bbl_u, CS%visc%kv_bbl_v)
call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, &
p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, &
CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, CS%pbv, &
CS%stoch_CS, Waves=Waves)
+ !$omp target update to(u, v, h, CS%uhtr, CS%vhtr)
endif
- if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_unsplit (step_MOM)")
- endif ! -------------------------------------------------- end SPLIT
+ if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_unsplit (step_MOM)")
+ endif
if (CS%use_particles .and. CS%do_dynamics .and. (.not. CS%use_uh_particles)) then
if (CS%thickness_diffuse_first) call MOM_error(WARNING,"particles_run: "//&
"Thickness_diffuse_first is true and use_uh_particles is false. "//&
"This is usually a bad combination.")
- !Run particles using unweighted velocity
+ ! Run particles using unweighted velocity
+ !$omp target update from(u, v, h)
call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, &
CS%tv, dt, CS%use_uh_particles)
call particles_to_z_space(CS%particles, h)
endif
-
-
! Update the model's current to reflect wind-wave growth
if (Waves%Stokes_DDT .and. (.not.Waves%Passive_Stokes_DDT)) then
+ !$omp target update from(u, v)
do J=jsq,jeq ; do i=is,ie
v(i,J,:) = v(i,J,:) + Waves%ddt_us_y(i,J,:)*dt
- enddo; enddo
+ enddo ; enddo
do j=js,je ; do I=isq,ieq
u(I,j,:) = u(I,j,:) + Waves%ddt_us_x(I,j,:)*dt
- enddo; enddo
- call pass_vector(u,v,G%Domain)
+ enddo ; enddo
+ call pass_vector(u, v, G%Domain)
+ !$omp target update to(u, v)
endif
! Added an additional output to track Stokes drift time tendency.
! It is mostly for debugging, and perhaps doesn't need to hang
@@ -1361,34 +1452,38 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
if (Waves%Stokes_DDT .and. (Waves%id_3dstokes_y_from_ddt>0)) then
do J=jsq,jeq ; do i=is,ie
Waves%us_y_from_ddt(i,J,:) = Waves%us_y_from_ddt(i,J,:) + Waves%ddt_us_y(i,J,:)*dt
- enddo; enddo
+ enddo ; enddo
endif
if (Waves%Stokes_DDT .and. (Waves%id_3dstokes_x_from_ddt>0)) then
do j=js,je ; do I=isq,ieq
Waves%us_x_from_ddt(I,j,:) = Waves%us_x_from_ddt(I,j,:) + Waves%ddt_us_x(I,j,:)*dt
- enddo; enddo
+ enddo ; enddo
endif
-
if ((CS%thickness_diffuse .or. CS%interface_filter) .and. &
.not.CS%thickness_diffuse_first) then
if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, unscale=GV%H_to_MKS)
if (CS%thickness_diffuse) then
+ !$omp target update from(h, CS%uhtr, CS%vhtr)
call cpu_clock_begin(id_clock_thick_diff)
+
if (CS%VarMix%use_variable_mixing) &
call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC)
+
call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, &
CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, CS%stoch_CS)
- if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, unscale=GV%H_to_MKS)
call cpu_clock_end(id_clock_thick_diff)
- call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil))
+ call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil)
+ if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, unscale=GV%H_to_MKS)
+ !$omp target update to(h, CS%uhtr, CS%vhtr)
if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)")
endif
if (CS%interface_filter) then
+ !$omp target update from(h, CS%uhtr, CS%vhtr)
if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass)
CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo)
call cpu_clock_begin(id_clock_int_filter)
@@ -1400,7 +1495,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
CS%CDp, CS%interface_filter_CSp)
endif
call cpu_clock_end(id_clock_int_filter)
- call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil))
+ call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil)
+ !$omp target update to(h, CS%uhtr, CS%vhtr)
if (showCallTree) call callTree_waypoint("finished interface_filter (step_MOM)")
endif
endif
@@ -1412,11 +1508,13 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
call uvchksum("Pre-mixedlayer_restrat uhtr", &
CS%uhtr, CS%vhtr, G%HI, haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2)
endif
+ !$omp target update from(h, CS%uhtr, CS%vhtr)
call cpu_clock_begin(id_clock_ml_restrat)
call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, &
CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp)
call cpu_clock_end(id_clock_ml_restrat)
- call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil))
+ call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil)
+ !$omp target update to(h, CS%uhtr, CS%vhtr)
if (CS%debug) then
call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, unscale=GV%H_to_MKS)
call uvchksum("Post-mixedlayer_restrat [uv]htr", &
@@ -1429,19 +1527,25 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
call diag_update_remap_grids(CS%diag)
if (CS%useMEKE .and. CS%MEKE_in_dynamics) then
+ !$omp target update from(u, v, h)
+ !$omp target update from(CS%visc%bbl_thick_u, CS%visc%bbl_thick_v)
+ !$omp target update from(CS%visc%kv_bbl_u, CS%visc%kv_bbl_v)
call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, &
CS%visc, dt, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr, &
CS%u, CS%v, CS%tv, Time_local)
+ !$omp target update to(u, v)
endif
call disable_averaging(CS%diag)
! Advance the dynamics time by dt.
CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt
- if (CS%use_particles .and. CS%do_dynamics .and. CS%use_uh_particles) then
- !Run particles using thickness-weighted velocity
+ if (CS%use_particles .and. CS%do_dynamics .and. CS%use_uh_particles .and. &
+ CS%uh_particles_bug) then
+ !$omp target update to(h, CS%uhtr, CS%vhtr)
+ ! Run particles using thickness-weighted velocity
call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, &
- CS%tv, CS%t_dyn_rel_adv, CS%use_uh_particles)
+ CS%tv, CS%t_dyn_rel_adv, CS%use_uh_particles)
endif
CS%n_dyn_steps_in_adv = CS%n_dyn_steps_in_adv + 1
@@ -1457,16 +1561,33 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, &
call cpu_clock_end(id_clock_dynamics)
- call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics)
+ ! Diagnostic finalization
+
+ call cpu_clock_begin(id_clock_other)
+ call cpu_clock_begin(id_clock_diagnostics)
+
call enable_averages(dt, Time_local, CS%diag)
+
! These diagnostics are available after every time dynamics step.
- if (IDs%id_u > 0) call post_data(IDs%id_u, u, CS%diag)
- if (IDs%id_v > 0) call post_data(IDs%id_v, v, CS%diag)
- if (IDs%id_h > 0) call post_data(IDs%id_h, h, CS%diag)
+ if (IDs%id_u > 0) then
+ !$omp target update from(u)
+ call post_data(IDs%id_u, u, CS%diag)
+ endif
+ if (IDs%id_v > 0) then
+ !$omp target update from(v)
+ call post_data(IDs%id_v, v, CS%diag)
+ endif
+ if (IDs%id_h > 0) then
+ !$omp target update from(h)
+ call post_data(IDs%id_h, h, CS%diag)
+ endif
+
if (CS%use_stochastic_EOS) call post_stoch_EOS_diags(CS%stoch_eos_CS, CS%tv, CS%diag)
+
call disable_averaging(CS%diag)
- call cpu_clock_end(id_clock_diagnostics) ; call cpu_clock_end(id_clock_other)
+ call cpu_clock_end(id_clock_diagnostics)
+ call cpu_clock_end(id_clock_other)
end subroutine step_MOM_dynamics
!> step_MOM_tracer_dyn does tracer advection and lateral diffusion, bringing the
@@ -1505,6 +1626,13 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local)
call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer)
call enable_averages(CS%t_dyn_rel_adv, Time_local, CS%diag)
+ if (CS%use_particles .and. CS%use_uh_particles .and. (.not. CS%uh_particles_bug)) then
+ ! Run particles using thickness-weighted velocity
+ call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, &
+ CS%tv, CS%t_dyn_rel_adv, CS%use_uh_particles)
+ endif
+
+
if (CS%alternate_first_direction) then
! This calculation of the value of G%first_direction from the start of the accumulation of
! mass transports for use by the tracers is the equivalent to adding 2*n_dyn_steps before
@@ -1524,7 +1652,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local)
if (associated(CS%OBC)) then
call pass_vector(CS%uhtr, CS%vhtr, G%Domain)
call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, &
- CS%t_dyn_rel_adv, CS%tracer_Reg)
+ CS%tracer_Reg)
endif
call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo)
@@ -1548,9 +1676,13 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local)
call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo)
if (CS%useMEKE .and. (.not. CS%MEKE_in_dynamics)) then
+ !$omp target update from(CS%u, CS%v)
+ !$omp target update from(CS%visc%bbl_thick_u, CS%visc%bbl_thick_v)
+ !$omp target update from(CS%visc%kv_bbl_u, CS%visc%kv_bbl_v)
call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, &
CS%visc, CS%t_dyn_rel_adv, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr, &
CS%u, CS%v, CS%tv, Time_local)
+ !$omp target update to(CS%u, CS%v)
endif
if (associated(CS%tv%T)) then
@@ -1605,13 +1737,11 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, &
logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging.
logical :: showCallTree
- type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h
+ type(group_pass_type) :: pass_T_S
integer :: dynamics_stencil ! The computational stencil for the calculations
! in the dynamic core.
integer :: halo_sz ! The size of a halo where data must be valid.
- integer :: i, j, k, is, ie, js, je, nz
- is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
showCallTree = callTree_showQuery()
if (showCallTree) call callTree_enter("step_MOM_thermo(), MOM.F90")
if (CS%debug) call query_debugging_checks(do_redundant=debug_redundant)
@@ -1646,9 +1776,12 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, &
call cpu_clock_begin(id_clock_BBL_visc)
!update porous barrier fractional cell metrics
if (CS%use_porbar) then
+ !$omp target update from(h)
call porous_widths_interface(h, CS%tv, G, GV, US, CS%pbv, CS%por_bar_CS)
call pass_vector(CS%pbv%por_layer_widthU, CS%pbv%por_layer_widthV, &
G%Domain, direction=To_ALL+SCALAR_PAIR, clock=id_clock_pass, halo=CS%cont_stencil)
+ !$omp target update to(CS%pbv%por_layer_widthU, CS%pbv%por_layer_widthV)
+ !$omp target update to(CS%pbv%por_face_areaU, CS%pbv%por_face_areaV)
endif
call set_viscous_BBL(u, v, h, tv, CS%visc, G, GV, US, CS%set_visc_CSp, CS%pbv)
call cpu_clock_end(id_clock_BBL_visc)
@@ -1657,6 +1790,12 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, &
call cpu_clock_begin(id_clock_thermo)
if (.not.CS%adiabatic) then
+ !$omp target update from(CS%visc%Ray_u) if (allocated(CS%visc%Ray_u))
+ !$omp target update from(CS%visc%Ray_v) if (allocated(CS%visc%Ray_v))
+ !$omp target update from(CS%visc%bbl_thick_u) if (allocated(CS%visc%bbl_thick_u))
+ !$omp target update from(CS%visc%bbl_thick_v) if (allocated(CS%visc%bbl_thick_v))
+ !$omp target update from(CS%visc%Kv_bbl_u) if (allocated(CS%visc%Kv_bbl_u))
+ !$omp target update from(CS%visc%Kv_bbl_v) if (allocated(CS%visc%Kv_bbl_v))
if (CS%debug) then
call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, unscale=US%L_T_to_m_s)
call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, unscale=GV%H_to_MKS)
@@ -1671,8 +1810,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, &
call cpu_clock_begin(id_clock_diabatic)
+ !$omp target update from(u, v, h)
call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, dtdia, &
Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS, CS%OBC, Waves)
+ !$omp target update to (u,v,h)
fluxes%fluxes_used = .true.
if (CS%stoch_CS%do_skeb) then
@@ -1772,9 +1913,7 @@ subroutine ALE_regridding_and_remapping(CS, G, GV, US, u, v, h, tv, dtdia, Time_
logical :: use_ice_shelf ! Needed for selecting the right ALE interface.
logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging.
logical :: showCallTree
- type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h
- integer :: dynamics_stencil ! The computational stencil for the calculations
- ! in the dynamic core.
+ type(group_pass_type) :: pass_T_S_h
integer :: i, j, k, is, ie, js, je, nz
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
@@ -1937,12 +2076,10 @@ subroutine post_diabatic_halo_updates(CS, G, GV, US, u, v, h, tv)
logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging.
logical :: showCallTree
- type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h
+ type(group_pass_type) :: pass_uv_T_S_h
integer :: dynamics_stencil ! The computational stencil for the calculations
! in the dynamic core.
- integer :: i, j, k, is, ie, js, je, nz
- is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
showCallTree = callTree_showQuery()
if (showCallTree) call callTree_enter("post_diabatic_halo_updates, MOM.F90")
if (CS%debug) call query_debugging_checks(do_redundant=debug_redundant)
@@ -1958,7 +2095,11 @@ subroutine post_diabatic_halo_updates(CS, G, GV, US, u, v, h, tv)
if (associated(tv%S)) &
call create_group_pass(pass_uv_T_S_h, tv%S, G%Domain, halo=dynamics_stencil)
call create_group_pass(pass_uv_T_S_h, h, G%Domain, halo=dynamics_stencil)
- call do_group_pass(pass_uv_T_S_h, G%Domain, clock=id_clock_pass)
+ ! TODO: Safe? what about T and S?
+ call do_group_pass(pass_uv_T_S_h, G%Domain, clock=id_clock_pass, omp_offload=.true.)
+
+ 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
@@ -2033,12 +2174,12 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS
! Check to see if vertical tracer functions should be done
do_vertical = (first_iter .or. (accumulated_time >= vertical_time))
- if (do_vertical) vertical_time = accumulated_time + real_to_time(US%T_to_s*dt_offline_vertical)
+ if (do_vertical) vertical_time = accumulated_time + real_to_time(dt_offline_vertical, unscale=US%T_to_s)
! Increment the amount of time elapsed since last read and check if it's time to roll around
- accumulated_time = accumulated_time + real_to_time(US%T_to_s*time_interval)
+ accumulated_time = accumulated_time + real_to_time(time_interval, unscale=US%T_to_s)
- last_iter = (accumulated_time >= real_to_time(US%T_to_s*dt_offline))
+ last_iter = (accumulated_time >= real_to_time(dt_offline, unscale=US%T_to_s))
if (CS%use_ALE_algorithm) then
! If this is the first iteration in the offline timestep, then we need to read in fields and
@@ -2065,7 +2206,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 +2233,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 +2455,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]
@@ -2338,8 +2484,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
CS%Time => Time
+ id_clock_ocean = cpu_clock_id('Ocean', grain=CLOCK_COMPONENT)
id_clock_init = cpu_clock_id('Ocean Initialization', grain=CLOCK_SUBCOMPONENT)
- call cpu_clock_begin(id_clock_init)
+ call cpu_clock_begin(id_clock_ocean) ; call cpu_clock_begin(id_clock_init)
Start_time = Time ; if (present(Time_in)) Start_time = Time_in
@@ -2356,6 +2503,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
! Determining the internal unit scaling factors for this run.
call unit_scaling_init(param_file, CS%US)
US => CS%US
+ !$omp target enter data map(to: CS%US)
! Read relevant parameters and write them to the model log.
call log_version(param_file, "MOM", version, "", log_to_all=.true., layout=.true., debugging=.true.)
@@ -2399,6 +2547,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
"FPMIX=True only works when SPLIT=True.")
endif
+ ! NOTE: tv is used, even if there is no thermodynamics
+ allocate(CS%tv)
+
call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, &
"If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.)
call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, &
@@ -2455,7 +2606,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, &
"If True, advect temperature and salinity horizontally "//&
"If False, T/S are registered for advection. "//&
- "This is intended only to be used in offline tracer mode."//&
+ "This is intended only to be used in offline tracer mode, "//&
"and is by default false in that case", &
default=.false. )
endif
@@ -2500,6 +2651,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 periodically changed to correct the bugs, at which point this "//&
+ "parameter will no longer be used to set their default. Setting this to false "//&
+ "means that bugs are only used if they are actively selected, but it also "//&
+ "means that answers may change when code is updated due to newly found bugs.", &
+ default=.true.)
call get_param(param_file, "MOM", "DT", CS%dt, &
"The (baroclinic) dynamics time step. The time-step that "//&
@@ -2600,7 +2765,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
"The time between OBC segment data updates for OBGC tracers. "//&
"This must be an integer multiple of DT and DT_THERM. "//&
"The default is set to DT.", &
- units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(CS%OBC))
+ units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(OBC_in))
! This is here in case these values are used inappropriately.
use_frazil = .false. ; bound_salinity = .false. ; use_p_surf_in_EOS = .false.
@@ -2705,11 +2870,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
default=default_answer_date, do_not_log=non_Bous)
if (non_Bous) CS%answer_date = 99991231
- call get_param(param_file, "MOM", "USE_DIABATIC_TIME_BUG", CS%use_diabatic_time_bug, &
- "If true, uses the wrong calendar time for diabatic processes, as was "//&
- "done in MOM6 versions prior to February 2018. This is not recommended.", &
- default=.false.)
-
call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, &
"If true, write the initial conditions to a file given "//&
"by IC_OUTPUT_FILE.", default=.false.)
@@ -2755,7 +2915,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call get_param(param_file, "MOM", "USE_PARTICLES", CS%use_particles, &
"If true, use the particles package.", default=.false.)
call get_param(param_file, "MOM", "USE_UH_PARTICLES", CS%use_uh_particles, &
- "If true, use the uh velocity in the particles package.",default=.false.)
+ "If true, use the uh velocity in the particles package.", &
+ default=.false., do_not_log=.not.CS%use_particles)
+ call get_param(param_file, "MOM", "UH_PARTICLES_BUG", CS%uh_particles_bug, &
+ "If true, use a bug in which the particles are advected inconsistently"//&
+ "with the dynamics timestep instead of the tracer timestep.", &
+ default=enable_bugs, do_not_log=.not.CS%use_uh_particles)
CS%ensemble_ocean=.false.
call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, &
"If False, The model is being run in serial mode as a single realization. "//&
@@ -2794,6 +2959,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call get_param(param_file, "MOM", "INDEX_TURNS", turns, &
"Number of counterclockwise quarter-turn index rotations.", &
default=1, debuggingParam=.true.)
+ else
+ turns = 0
endif
! Set up the model domain and grids.
@@ -2802,6 +2969,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
#else
symmetric = .false.
#endif
+ allocate(CS%G_in)
G_in => CS%G_in
#ifdef STATIC_MEMORY_
call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, &
@@ -2845,16 +3013,36 @@ 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)
+ !$omp target enter data map(to: CS%G_in)
+ !$omp target enter data map(to: G%dxT, G%dxCu, G%dxCv, G%dxBu)
+ !$omp target enter data map(to: G%dyT, G%dyCu, G%dyCv, G%dyBu)
+ !$omp target enter data map(to: G%dx_Cv, G%dy_Cu)
+ !$omp target enter data map(to: G%IdxT, G%IdxCu, G%IdxCv, G%IdxBu)
+ !$omp target enter data map(to: G%IdyT, G%IdyCu, G%IdyCv, G%IdyBu)
+ !$omp target enter data map(to: G%mask2dBu, G%mask2dT)
+ !$omp target enter data map(to: G%areaT, G%areaCu, G%areaCv)
+ !$omp target enter data map(to: G%IareaT, G%IareaCu, G%IareaCv, G%IareaBu)
+ !$omp target enter data map(to: G%bathyT)
+ !$omp target enter data map(to: G%CoriolisBu, G%Coriolis2Bu)
+ !$omp target enter data map(to: G%mask2dCu, G%mask2dCv)
+ !$omp target enter data map(to: G%OBCmaskCu, G%OBCmaskCv)
+ !$omp target enter data map(to: G%IdxCu_OBCmask, G%IdyCv_OBCmask)
+ ! NOTE: This may be time dependent
+ !$omp target enter data map(to: G%meanSL)
+
call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)")
call verticalGridInit( param_file, CS%GV, US )
GV => CS%GV
+ ! This does not work. GV%RLay changes sometime later.
+ !!!$omp target enter data map(to: GV, GV%Rlay, GV%g_prime)
+
! Now that the vertical grid has been initialized, rescale parameters that depend on factors
! that are set with the vertical grid to their desired units. This added rescaling step would
! be unnecessary if the vertical grid were initialized earlier in this routine.
@@ -2864,9 +3052,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
endif
CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z
- ! Finish OBC configuration that depend on the vertical grid
- call open_boundary_setup_vert(GV, US, OBC_in)
-
! Shift from using the temporary dynamic grid type to using the final (potentially static)
! and properly rotated ocean-specific grid type and horizontal index type.
if (CS%rotate_index) then
@@ -2882,9 +3067,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
@@ -2906,6 +3088,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call tracer_registry_init(param_file, CS%tracer_Reg)
+ !$omp target update to(CS)
+
! Allocate and initialize space for the primary time-varying MOM variables.
is = HI%isc ; ie = HI%iec ; js = HI%jsc ; je = HI%jec ; nz = GV%ke
isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed
@@ -2915,6 +3099,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
ALLOC_(CS%h(isd:ied,jsd:jed,nz)) ; CS%h(:,:,:) = GV%Angstrom_H
ALLOC_(CS%uh(IsdB:IedB,jsd:jed,nz)) ; CS%uh(:,:,:) = 0.0
ALLOC_(CS%vh(isd:ied,JsdB:JedB,nz)) ; CS%vh(:,:,:) = 0.0
+ !$omp target enter data map(to: CS%u, CS%v, CS%h, CS%uh, CS%vh)
if (use_temperature) then
ALLOC_(CS%T(isd:ied,jsd:jed,nz)) ; CS%T(:,:,:) = 0.0
ALLOC_(CS%S(isd:ied,jsd:jed,nz)) ; CS%S(:,:,:) = 0.0
@@ -2965,7 +3150,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)
@@ -2981,9 +3169,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
ALLOC_(CS%uhtr(IsdB:IedB,jsd:jed,nz)) ; CS%uhtr(:,:,:) = 0.0
ALLOC_(CS%vhtr(isd:ied,JsdB:JedB,nz)) ; CS%vhtr(:,:,:) = 0.0
+ !$omp target enter data map(to: CS%uhtr, CS%vhtr)
CS%t_dyn_rel_adv = 0.0 ; CS%t_dyn_rel_thermo = 0.0 ; CS%t_dyn_rel_diag = 0.0
CS%n_dyn_steps_in_adv = 0
+ allocate(CS%ADp)
+ !$omp target enter data map(alloc: CS%ADp)
+
if (debug_truncations) then
allocate(CS%u_prev(IsdB:IedB,jsd:jed,nz), source=0.0)
allocate(CS%v_prev(isd:ied,JsdB:JedB,nz), source=0.0)
@@ -3009,8 +3201,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
if (CS%interp_p_surf) allocate(CS%p_surf_prev(isd:ied,jsd:jed), source=0.0)
ALLOC_(CS%ssh_rint(isd:ied,jsd:jed)) ; CS%ssh_rint(:,:) = 0.0
+ !$omp target enter data map(to: CS%ssh_rint)
ALLOC_(CS%ave_ssh_ibc(isd:ied,jsd:jed)) ; CS%ave_ssh_ibc(:,:) = 0.0
+ !$omp target enter data map(to: CS%ave_ssh_ibc)
ALLOC_(CS%eta_av_bc(isd:ied,jsd:jed)) ; CS%eta_av_bc(:,:) = 0.0 ! -G%Z_ref
+ !$omp target enter data map(to: CS%eta_av_bc)
CS%time_in_cycle = 0.0 ; CS%time_in_thermo_cycle = 0.0
!allocate porous topography variables
@@ -3018,13 +3213,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
allocate(CS%pbv%por_face_areaV(isd:ied,JsdB:JedB,nz), source=1.0)
allocate(CS%pbv%por_layer_widthU(IsdB:IedB,jsd:jed,nz+1), source=1.0)
allocate(CS%pbv%por_layer_widthV(isd:ied,JsdB:JedB,nz+1), source=1.0)
+ !$omp target enter data map(to: CS%pbv)
+ !$omp target enter data map(to: CS%pbv%por_face_areaU, CS%pbv%por_face_areaV)
+ !$omp target enter data map(to: CS%pbv%por_layer_widthU, CS%pbv%por_layer_widthV)
! Use the Wright equation of state by default, unless otherwise specified
! Note: this line and the following block ought to be in a separate
! initialization routine for tv.
if (use_EOS) then
allocate(CS%tv%eqn_of_state)
- call EOS_init(param_file, CS%tv%eqn_of_state, US)
+ call EOS_init(param_file, CS%tv%eqn_of_state, US, use_conT_absS)
endif
if (use_temperature) then
allocate(CS%tv%TempxPmE(isd:ied,jsd:jed), source=0.0)
@@ -3044,6 +3242,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call register_restarts_dyn_split_RK2b(HI, GV, US, param_file, &
CS%dyn_split_RK2b_CSp, restart_CSp, CS%uh, CS%vh)
elseif (CS%split) then
+ allocate(CS%dyn_split_RK2_CSp)
+ !$omp target enter data map(alloc: CS%dyn_split_RK2_CSp)
call register_restarts_dyn_split_RK2(HI, GV, US, param_file, &
CS%dyn_split_RK2_CSp, restart_CSp, CS%uh, CS%vh)
elseif (CS%use_RK2) then
@@ -3060,40 +3260,43 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
CS%tracer_Reg, restart_CSp)
call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp)
+
+ allocate(CS%visc)
+ !$omp target enter data map(alloc: CS%visc)
call set_visc_register_restarts(HI, G, GV, US, param_file, CS%visc, restart_CSp, use_ice_shelf)
+
call mixedlayer_restrat_register_restarts(HI, GV, US, param_file, &
CS%mixedlayer_restrat_CSp, restart_CSp)
- if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then
- ! NOTE: register_temp_salt_segments includes allocation of tracer fields
- ! along segments. Bit reproducibility requires that MOM_initialize_state
- ! be called on the input index map, so we must setup both OBC and OBC_in.
- !
- ! XXX: This call on OBC_in allocates the tracer fields on the unrotated
- ! grid, but also incorrectly stores a pointer to a tracer_type for the
- ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg.
- !
- ! While incorrect and potentially dangerous, it does not seem that this
- ! pointer is used during initialization, so we leave it for now.
- call register_temp_salt_segments(GV, US, OBC_in, CS%tracer_Reg, param_file)
- endif
-
if (associated(CS%OBC)) then
+ ! This call initializes the relevant vertical remapping structures.
+ call open_boundary_setup_vert(GV, US, CS%OBC)
+
! Set up remaining information about open boundary conditions that is needed for OBCs.
+ ! 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.
if (use_temperature) &
call register_temp_salt_segments(GV, US, CS%OBC, CS%tracer_Reg, param_file)
- !This is the equivalent call to register_temp_salt_segments for external tracers with OBC
+ ! This is the equivalent call to register_temp_salt_segments for external tracers with OBC
call call_tracer_register_obc_segments(GV, param_file, CS%tracer_flow_CSp, CS%tracer_Reg, CS%OBC)
+ ! Set up the thickness reservoirs if using them.
+ if (CS%OBC%use_h_res) &
+ call segment_thickness_reservoir_init(GV, US, CS%OBC, param_file)
+
! This needs the number of tracers and to have called any code that sets whether
! reservoirs are used.
call open_boundary_register_restarts(HI, GV, US, CS%OBC, CS%tracer_Reg, &
param_file, restart_CSp, use_temperature)
+
+ ! This call allocates the arrays on the segments for open boundary data, but it must occur
+ ! after any calls to call_tracer_register_obc_segments.
+ call initialize_segment_data(GV, US, CS%OBC, param_file, turns, use_temperature)
+
+ if (CS%debug_OBCs) call write_OBC_info(CS%OBC, G, GV, US)
endif
if (present(waves_CSp)) then
@@ -3120,7 +3323,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)
@@ -3136,7 +3339,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)")
if (CS%use_ALE_algorithm) then
- call ALE_init(param_file, GV, US, G%max_depth, CS%ALE_CSp)
+ call ALE_init(param_file, G, GV, US, G%max_depth, CS%ALE_CSp)
call callTree_waypoint("returned from ALE_init() (initialize_MOM)")
endif
@@ -3155,7 +3358,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
G%ke = GV%ke
if (use_ice_shelf) then
- point_calving=.false.; if (present(calve_ice_shelf_bergs)) point_calving=calve_ice_shelf_bergs
+ point_calving = .false. ; if (present(calve_ice_shelf_bergs)) point_calving = calve_ice_shelf_bergs
endif
if (CS%rotate_index) then
@@ -3176,6 +3379,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
CS%tv%T => T_in
CS%tv%S => S_in
+
+ if (associated(CS%OBC)) then
+ ! Log this parameter in MOM_initialize_state
+ call get_param(param_file, "MOM", "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, &
+ "If true, set the OBC tracer reservoirs at the startup of a new run from the "//&
+ "interior tracer concentrations regardless of properties that may be explicitly "//&
+ "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.)
+ if (OBC_reservoir_init_bug .and. (allocated(CS%OBC%tres_x) .or. allocated(CS%OBC%tres_y))) &
+ call MOM_error(FATAL, "OBC_RESERVOIR_INIT_BUG can not be set to true with grid rotation.")
+ endif
endif
if (use_ice_shelf) then
@@ -3228,9 +3441,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 +3449,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)
@@ -3249,12 +3461,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf)
call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, &
param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, &
- CS%sponge_CSp, CS%ALE_sponge_CSp,CS%oda_incupd_CSp, CS%OBC, Time_in, &
- frac_shelf_h=CS%frac_shelf_h, mass_shelf=CS%mass_shelf)
+ CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in, &
+ frac_shelf_h=CS%frac_shelf_h, mass_shelf=CS%mass_shelf, OBC_for_bug=CS%OBC)
else
call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, &
param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, &
- CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in)
+ CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in, OBC_for_bug=CS%OBC)
endif
! Reset the first direction if it was found in a restart file.
@@ -3271,6 +3483,21 @@ 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 read_OBC_segment_data(G, GV, US, CS%OBC, CS%tv, CS%h, Time)
+ call update_OBC_segment_data(G, GV, US, CS%OBC, CS%h, Time)
+ call initialize_OBC_segment_reservoirs(GV, CS%OBC)
+ endif
+
if (use_ice_shelf .and. CS%debug) then
call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0)
call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2)
@@ -3309,8 +3536,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)
@@ -3405,6 +3631,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug)
endif
+ ! XXX: Where to put this??
+ ! XXX: G transfer should possibly also be here.
+
+ !$omp target enter data map(to: GV, GV%Rlay, GV%g_prime)
diag => CS%diag
! Initialize the diag mediator.
@@ -3459,7 +3689,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
CS%useMEKE = MEKE_init(Time, G, GV, US, param_file, diag, CS%dbcomms_CS, CS%MEKE_CSp, CS%MEKE, &
restart_CSp, CS%MEKE_in_dynamics)
+ allocate(CS%VarMix)
+ !$omp target enter data map(alloc: CS%VarMix)
call VarMix_init(Time, G, GV, US, param_file, diag, CS%VarMix)
+
+ !$omp target enter data map(to: CS%set_visc_CSp)
call set_visc_init(Time, G, GV, US, param_file, diag, CS%visc, CS%set_visc_CSp, restart_CSp, CS%OBC)
call thickness_diffuse_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%thickness_diffuse_CSp)
if (CS%interface_filter) &
@@ -3482,16 +3716,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, CS%HA_CSp, restart_CSp, &
CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, &
CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, &
- CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil)
+ CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, &
+ cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil)
else
call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, &
G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, CS%HA_CSp, restart_CSp, &
CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, &
CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, &
- CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil)
+ CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, &
+ cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil)
endif
if (CS%dtbt_reset_period > 0.0) then
- CS%dtbt_reset_interval = real_to_time(US%T_to_s*CS%dtbt_reset_period)
+ CS%dtbt_reset_interval = real_to_time(CS%dtbt_reset_period, unscale=US%T_to_s)
! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval.
CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * &
((Time - Time_init) / CS%dtbt_reset_interval)
@@ -3503,22 +3739,23 @@ 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)
+ CS%ntrunc, cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil)
else
- call initialize_dyn_unsplit(CS%u, CS%v, CS%h, Time, G, GV, US, &
- param_file, diag, CS%dyn_unsplit_CSp, &
+ call initialize_dyn_unsplit(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, &
+ US, param_file, diag, CS%dyn_unsplit_CSp, &
CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, &
CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, &
- CS%ntrunc, cont_stencil=CS%cont_stencil)
+ CS%ntrunc, cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil)
endif
+ CS%dyn_h_stencil = max(2, CS%dyn_h_stencil)
!Set OBC segment data update period
if (associated(CS%OBC) .and. CS%dt_obc_seg_period > 0.0) then
- CS%dt_obc_seg_interval = real_to_time(US%T_to_s*CS%dt_obc_seg_period)
+ CS%dt_obc_seg_interval = real_to_time(CS%dt_obc_seg_period, unscale=US%T_to_s)
CS%dt_obc_seg_time = Time + CS%dt_obc_seg_interval
endif
@@ -3561,6 +3798,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)
@@ -3569,13 +3808,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
if (associated(CS%sponge_CSp)) &
call init_sponge_diags(Time, G, GV, US, diag, CS%sponge_CSp)
- if (associated(CS%ALE_sponge_CSp)) &
- call init_ALE_sponge_diags(Time, G, diag, CS%ALE_sponge_CSp, US)
-
if (associated(CS%oda_incupd_CSp)) &
call init_oda_incupd_diags(Time, G, GV, diag, CS%oda_incupd_CSp, US)
-
call tracer_advect_init(Time, G, US, param_file, diag, CS%tracer_adv_CSp)
call tracer_hor_diff_init(Time, G, GV, US, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, &
CS%tracer_diff_CSp)
@@ -3609,6 +3844,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
CS%ALE_sponge_CSp, CS%tv)
if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp
+ if (associated(CS%ALE_sponge_CSp)) &
+ call init_ALE_sponge_diags(Time, G, diag, CS%ALE_sponge_CSp, US)
+
! If running in offline tracer mode, initialize the necessary control structure and
! parameters
if (present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode
@@ -3623,6 +3861,15 @@ 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 setup_OBC_thickness_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
@@ -3641,11 +3888,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
endif
if (.not.query_initialized(CS%ave_ssh_ibc, "ave_ssh", restart_CSp)) then
+ !$omp target update to(CS%h)
if (CS%split) then
- call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, eta, dZref=G%Z_ref)
+ !$omp target enter data map(to: eta)
+ call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, eta_bt=eta, dZref=G%Z_ref)
+ !$omp target exit data map(release: eta)
else
call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, dZref=G%Z_ref)
endif
+ !$omp target update from(CS%ave_ssh_ibc)
call set_initialized(CS%ave_ssh_ibc, "ave_ssh", restart_CSp)
endif
if (CS%split) deallocate(eta)
@@ -3668,7 +3919,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, &
call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time)
call callTree_leave("initialize_MOM()")
- call cpu_clock_end(id_clock_init)
+ call cpu_clock_end(id_clock_init) ; call cpu_clock_end(id_clock_ocean)
end subroutine initialize_MOM
@@ -3702,7 +3953,10 @@ subroutine finish_MOM_initialization(Time, dirs, CS)
restart_CSp_tmp = CS%restart_CS
call restart_registry_lock(restart_CSp_tmp, unlocked=.true.)
allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1))
+ !$omp target update to(CS%h)
+ !$omp target enter data map(alloc: z_interface)
call find_eta(CS%h, CS%tv, G, GV, US, z_interface, dZref=G%Z_ref)
+ !$omp target exit data map(from: z_interface)
call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, &
"Interface heights", "meter", z_grid='i', conversion=US%Z_to_m)
! NOTE: write_ic=.true. routes routine to fms2 IO write_initial_conditions interface
@@ -3750,11 +4004,11 @@ end subroutine register_diags
subroutine MOM_timing_init(CS)
type(MOM_control_struct), intent(in) :: CS !< control structure set up by initialize_MOM.
- id_clock_ocean = cpu_clock_id('Ocean', grain=CLOCK_COMPONENT)
id_clock_dynamics = cpu_clock_id('Ocean dynamics', grain=CLOCK_SUBCOMPONENT)
id_clock_thermo = cpu_clock_id('Ocean thermodynamics and tracers', grain=CLOCK_SUBCOMPONENT)
id_clock_remap = cpu_clock_id('Ocean grid generation and remapping', grain=CLOCK_SUBCOMPONENT)
id_clock_other = cpu_clock_id('Ocean Other', grain=CLOCK_SUBCOMPONENT)
+ id_clock_MOM_end = cpu_clock_id('Ocean MOM_end', grain=CLOCK_SUBCOMPONENT)
id_clock_tracer = cpu_clock_id('(Ocean tracer advection)', grain=CLOCK_MODULE_DRIVER)
if (.not.CS%adiabatic) then
id_clock_diabatic = cpu_clock_id('(Ocean diabatic driver)', grain=CLOCK_MODULE_DRIVER)
@@ -3782,6 +4036,8 @@ subroutine MOM_timing_init(CS)
id_clock_stoch = cpu_clock_id('(Stochastic EOS)', grain=CLOCK_MODULE)
id_clock_varT = cpu_clock_id('(SGS Temperature Variance)', grain=CLOCK_MODULE)
+ id_clock_save_restart = cpu_clock_id('(Ocean MOM save_restart)', grain=CLOCK_MODULE)
+
end subroutine MOM_timing_init
!> Set the fields that are needed for bitwise identical restarting
@@ -3940,8 +4196,8 @@ subroutine extract_surface_state(CS, sfc_state_in)
G => CS%G ; G_in => CS%G_in ; GV => CS%GV ; US => CS%US
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
- iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB
- isdB = G%isdB ; iedB = G%iedB; jsdB = G%jsdB ; jedB = G%jedB
+ iscB = G%iscB ; iecB = G%iecB ; jscB = G%jscB ; jecB = G%jecB
+ isdB = G%isdB ; iedB = G%iedB ; jsdB = G%jsdB ; jedB = G%jedB
h => CS%h
use_temperature = associated(CS%tv%T)
@@ -4077,7 +4333,7 @@ subroutine extract_surface_state(CS, sfc_state_in)
depth_ml = CS%Hmix_UV
if (CS%answer_date < 20190101) depth_ml = GV%H_to_Z*CS%Hmix_UV
!$OMP parallel do default(shared) private(depth,dh,hv)
- do J=js-1,ie
+ do J=js-1,je
do i=is,ie
depth(i) = 0.0
sfc_state%v(i,J) = 0.0
@@ -4244,8 +4500,8 @@ subroutine extract_surface_state(CS, sfc_state_in)
do j=js,je ; do i=is,ie
if (G%mask2dT(i,j)>0.) then
localError = sfc_state%sea_lev(i,j) < -G%bathyT(i,j) - G%Z_ref &
- .or. sfc_state%sea_lev(i,j) >= CS%bad_val_ssh_max &
- .or. sfc_state%sea_lev(i,j) <= -CS%bad_val_ssh_max &
+ .or. sfc_state%sea_lev(i,j) >= CS%bad_val_ssh_max + (G%meanSL(i,j) - G%Z_ref) &
+ .or. sfc_state%sea_lev(i,j) <= -CS%bad_val_ssh_max + (G%meanSL(i,j) - G%Z_ref) &
.or. sfc_state%sea_lev(i,j) + G%bathyT(i,j) + G%Z_ref < CS%bad_val_col_thick
if (use_temperature) localError = localError &
.or. sfc_state%SSS(i,j)<0. &
@@ -4258,7 +4514,7 @@ subroutine extract_surface_state(CS, sfc_state_in)
ig = i + G%HI%idg_offset ! Global i-index
jg = j + G%HI%jdg_offset ! Global j-index
if (use_temperature) then
- write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),8(a,es11.4,1x))') &
+ write(msg(1:240),'(2(a,I0,1x),4(a,f8.3,1x),8(a,es11.4,1x))') &
'Extreme surface sfc_state detected: i=',ig,'j=',jg, &
'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), &
'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), &
@@ -4267,7 +4523,7 @@ subroutine extract_surface_state(CS, sfc_state_in)
'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), &
'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J)
else
- write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),6(a,es11.4))') &
+ write(msg(1:240),'(2(a,I0,1x),4(a,f8.3,1x),6(a,es11.4))') &
'Extreme surface sfc_state detected: i=',ig,'j=',jg, &
'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), &
'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), &
@@ -4284,8 +4540,8 @@ subroutine extract_surface_state(CS, sfc_state_in)
enddo ; enddo
call sum_across_PEs(numberOfErrors)
if (numberOfErrors>0) then
- write(msg(1:240),'(3(a,i9,1x))') 'There were a total of ',numberOfErrors, &
- 'locations detected with extreme surface values!'
+ write(msg(1:240),'(a,i0,a)') 'There were a total of ',numberOfErrors, &
+ ' locations detected with extreme surface values!'
call MOM_error(FATAL, trim(msg))
endif
endif
@@ -4409,6 +4665,7 @@ subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, &
logical :: showCallTree
showCallTree = callTree_showQuery()
+ call cpu_clock_begin(id_clock_ocean) ; call cpu_clock_begin(id_clock_save_restart)
if (showCallTree) call callTree_waypoint("About to call save_restart (step_MOM)")
call save_restart(directory, time, G, CS%restart_CS, &
time_stamped=time_stamped, filename=filename, GV=GV, &
@@ -4416,6 +4673,7 @@ subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, &
if (showCallTree) call callTree_waypoint("Done with call to save_restart (step_MOM)")
if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped)
+ call cpu_clock_end(id_clock_save_restart) ; call cpu_clock_end(id_clock_ocean)
end subroutine save_MOM_restart
@@ -4423,12 +4681,16 @@ end subroutine save_MOM_restart
subroutine MOM_end(CS)
type(MOM_control_struct), intent(inout) :: CS !< MOM control structure
+ call cpu_clock_begin(id_clock_ocean) ; call cpu_clock_begin(id_clock_MOM_end)
+
call MOM_sum_output_end(CS%sum_output_CSp)
if (CS%use_ALE_algorithm) call ALE_end(CS%ALE_CSp)
!deallocate porous topography variables
+ !$omp target exit data map(delete: CS%pbv%por_face_areaU, CS%pbv%por_face_areaV)
deallocate(CS%pbv%por_face_areaU) ; deallocate(CS%pbv%por_face_areaV)
+ !$omp target exit data map(delete: CS%pbv%por_layer_widthU, CS%pbv%por_layer_widthV)
deallocate(CS%pbv%por_layer_widthU) ; deallocate(CS%pbv%por_layer_widthV)
! NOTE: Allocated in PressureForce_FV_Bouss
@@ -4466,17 +4728,25 @@ subroutine MOM_end(CS)
call thickness_diffuse_end(CS%thickness_diffuse_CSp, CS%CDp)
if (CS%interface_filter) call interface_filter_end(CS%interface_filter_CSp, CS%CDp)
call VarMix_end(CS%VarMix)
+
call set_visc_end(CS%visc, CS%set_visc_CSp)
+ !$omp target exit data map(delete: CS%visc, CS%set_visc_CSp)
+ deallocate(CS%visc)
+
call MEKE_end(CS%MEKE)
if (associated(CS%tv%internal_heat)) deallocate(CS%tv%internal_heat)
if (associated(CS%tv%TempxPmE)) deallocate(CS%tv%TempxPmE)
DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) ; DEALLOC_(CS%eta_av_bc)
+ !$omp target exit data map(delete: CS%ave_ssh_ibc)
+ !$omp target exit data map(delete: CS%ssh_rint)
+ !$omp target exit data map(delete: CS%eta_av_bc)
! TODO: debug_truncations deallocation
DEALLOC_(CS%uhtr) ; DEALLOC_(CS%vhtr)
+ !$omp target exit data map(delete: CS%uhtr, CS%vhtr)
if (associated(CS%Hml)) deallocate(CS%Hml)
if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit)
@@ -4489,8 +4759,10 @@ subroutine MOM_end(CS)
DEALLOC_(CS%u) ; DEALLOC_(CS%v) ; DEALLOC_(CS%h)
DEALLOC_(CS%uh) ; DEALLOC_(CS%vh)
+ !$omp target exit data map(delete: CS%u, CS%v, CS%h, CS%uh, 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)
@@ -4506,6 +4778,9 @@ subroutine MOM_end(CS)
call deallocate_MOM_domain(CS%G_in%domain, cursory=.true.)
call unit_scaling_end(CS%US)
+
+ call cpu_clock_end(id_clock_MOM_end) ; call cpu_clock_end(id_clock_ocean)
+
end subroutine MOM_end
!> \namespace mom
diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90
index 3cb78a1cb4..71794b16af 100644
--- a/src/core/MOM_CoriolisAdv.F90
+++ b/src/core/MOM_CoriolisAdv.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Accelerations due to the Coriolis force and momentum advection
module MOM_CoriolisAdv
-! This file is part of MOM6. See LICENSE.md for the license.
-
!> \author Robert Hallberg, April 1994 - June 2002
use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl
@@ -14,6 +16,8 @@ module MOM_CoriolisAdv
use MOM_grid, only : ocean_grid_type
use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W
use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S
+use MOM_open_boundary, only : OBC_VORTICITY_ZERO, OBC_VORTICITY_FREESLIP
+use MOM_open_boundary, only : OBC_VORTICITY_COMPUTED, OBC_VORTICITY_SPECIFIED
use MOM_string_functions, only : uppercase
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : accel_diag_ptrs, porous_barrier_type
@@ -22,7 +26,7 @@ module MOM_CoriolisAdv
implicit none ; private
-public CorAdCalc, CoriolisAdv_init, CoriolisAdv_end
+public CorAdCalc, CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil
#include
@@ -37,11 +41,15 @@ module MOM_CoriolisAdv
!! - SADOURNY75_ENSTRO - Sadourny, JAS 1975, Enstrophy
!! - ARAKAWA_LAMB81 - Arakawa & Lamb, MWR 1981, Energy & Enstrophy
!! - ARAKAWA_LAMB_BLEND - A blend of Arakawa & Lamb with Arakawa & Hsu and Sadourny energy.
+ !! - WENOVI3RD_PV_ENSTRO - 3rd-order WENO scheme for PV reconstruction
+ !! - WENOVI5TH_PV_ENSTRO - 5th-order WENO scheme for PV reconstruction
+ !! - WENOVI7TH_PV_ENSTRO - 7th-order WENO scheme for PV reconstruction
!! The default, SADOURNY75_ENERGY, is the safest choice then the
!! deformation radius is poorly resolved.
integer :: KE_Scheme !< KE_SCHEME selects the discretization for
!! the kinetic energy. Valid values are:
!! KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV
+ logical :: KE_use_limiter !< If true, use the Koren limiter for KE_UP3 scheme
integer :: PV_Adv_Scheme !< PV_ADV_SCHEME selects the discretization for PV advection
!! Valid values are:
!! - PV_ADV_CENTERED - centered (aka Sadourny, 75)
@@ -73,6 +81,7 @@ module MOM_CoriolisAdv
!! relative to the other one is used. This is only
!! available at present if Coriolis scheme is
!! SADOURNY75_ENERGY.
+ logical :: weno_velocity_smooth !< If true, use velocity to compute the smoothness indicator for WENO
type(time_type), pointer :: Time !< A pointer to the ocean model's clock.
type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output.
!>@{ Diagnostic IDs
@@ -97,20 +106,28 @@ module MOM_CoriolisAdv
integer, parameter :: SADOURNY75_ENSTRO = 4
integer, parameter :: ARAKAWA_LAMB81 = 5
integer, parameter :: AL_BLEND = 6
+integer, parameter :: wenovi7th_PV_ENSTRO = 7
+integer, parameter :: wenovi5th_PV_ENSTRO = 8
+integer, parameter :: wenovi3rd_PV_ENSTRO = 9
character*(20), parameter :: SADOURNY75_ENERGY_STRING = "SADOURNY75_ENERGY"
character*(20), parameter :: ARAKAWA_HSU_STRING = "ARAKAWA_HSU90"
character*(20), parameter :: ROBUST_ENSTRO_STRING = "ROBUST_ENSTRO"
character*(20), parameter :: SADOURNY75_ENSTRO_STRING = "SADOURNY75_ENSTRO"
character*(20), parameter :: ARAKAWA_LAMB_STRING = "ARAKAWA_LAMB81"
character*(20), parameter :: AL_BLEND_STRING = "ARAKAWA_LAMB_BLEND"
+character*(20), parameter :: WENOVI7TH_PV_ENSTRO_STRING = "WENOVI7TH_PV_ENSTRO"
+character*(20), parameter :: WENOVI5TH_PV_ENSTRO_STRING = "WENOVI5TH_PV_ENSTRO"
+character*(20), parameter :: WENOVI3RD_PV_ENSTRO_STRING = "WENOVI3RD_PV_ENSTRO"
!>@}
!>@{ Enumeration values for KE_Scheme
integer, parameter :: KE_ARAKAWA = 10
integer, parameter :: KE_SIMPLE_GUDONOV = 11
integer, parameter :: KE_GUDONOV = 12
+integer, parameter :: KE_UP3 = 13
character*(20), parameter :: KE_ARAKAWA_STRING = "KE_ARAKAWA"
character*(20), parameter :: KE_SIMPLE_GUDONOV_STRING = "KE_SIMPLE_GUDONOV"
character*(20), parameter :: KE_GUDONOV_STRING = "KE_GUDONOV"
+character*(20), parameter :: KE_UP3_STRING = "KE_UP3"
!>@}
!>@{ Enumeration values for PV_Adv_Scheme
integer, parameter :: PV_ADV_CENTERED = 21
@@ -148,6 +165,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
q, & ! Layer potential vorticity [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1].
qS, & ! Layer Stokes vorticity [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1].
Ih_q, & ! The inverse of thickness interpolated to q points [H-1 ~> m-1 or m2 kg-1].
+ h_q, & ! The thickness interpolated to q points [H-1 ~> m-1 or m2 kg-1].
Area_q ! The sum of the ocean areas at the 4 adjacent thickness points [L2 ~> m2].
real, dimension(SZIB_(G),SZJ_(G)) :: &
@@ -203,6 +221,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
! surrounding a q point [H L2 ~> m3 or kg].
real :: vol_neglect ! A volume so small that is expected to be
! lost in roundoff [H L2 ~> m3 or kg].
+ real :: area_neglect ! An area so small that is expected to be
+ ! lost in roundoff [L2 ~> m2].
real :: temp1, temp2 ! Temporary variables [L2 T-2 ~> m2 s-2].
real :: eps_vel ! A tiny, positive velocity [L T-1 ~> m s-1].
@@ -226,7 +246,19 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
real :: UHeff, VHeff ! More temporary variables [H L2 T-1 ~> m3 s-1 or kg s-1].
real :: QUHeff,QVHeff ! More temporary variables [H L2 T-2 ~> m3 s-2 or kg s-2].
integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
+ integer :: Is_q, Ie_q, Js_q, Je_q ! The scheme-dependent range of values at which vorticity is set.
logical :: Stokes_VF
+ real :: u_v, v_u ! u_v is the u velocity at v point, v_u is the v velocity at u point [L T-1 ~> m s-1]
+ real :: q_v, q_u ! PV at the u and v points [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]
+ logical :: use_weno ! True if using one of the WENO schemes
+ integer :: seventh_order, fifth_order, third_order ! Order of accuracy for the WENO calculations
+ real :: u_q8(8) ! Eight-point zonal velocity at WENO stencils [L T-1 ~> m s-1]
+ real :: u_q6(6) ! Six-point zonal velocity at WENO stencils [L T-1 ~> m s-1]
+ real :: u_q4(4) ! Four-point zonal velocity at WENO stencils [L T-1 ~> m s-1]
+ real :: v_q8(8) ! Eight-point meridional velocity at WENO stencils [L T-1 ~> m s-1]
+ real :: v_q6(6) ! Six-point meridional velocity at WENO stencils [L T-1 ~> m s-1]
+ real :: v_q4(4) ! Four-point meridional velocity at WENO stencils [L T-1 ~> m s-1]
+ integer :: stencil ! Stencil size of WENO scheme
! To work, the following fields must be set outside of the usual
! is to ie range before this subroutine is called:
@@ -239,50 +271,95 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke
vol_neglect = GV%H_subroundoff * (1e-4 * US%m_to_L)**2
+ area_neglect = (1e-4 * US%m_to_L)**2
eps_vel = 1.0e-10*US%m_s_to_L_T
h_tiny = GV%Angstrom_H ! Perhaps this should be set to h_neglect instead.
- !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h)
- do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+2
+ stencil = CoriolisAdv_stencil(CS)
+
+ use_weno = CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO &
+ .or. CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO &
+ .or. CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO
+
+ if (use_weno) then
+ Is_q = is - stencil ; Ie_q = ie + stencil - 1 ; Js_q = js - stencil ; Je_q = je + stencil - 1
+ else
+ Is_q = G%IscB - 1 ; Ie_q = G%IecB + 1 ; Js_q = G%JscB - 1 ; Je_q = G%JecB + 1
+ endif
+
+ !$omp target enter data map(alloc: Area_h, Area_q)
+
+ do concurrent (j=Js_q:Je_q+1, I=Is_q:Ie_q+1)
Area_h(i,j) = G%mask2dT(i,j) * G%areaT(i,j)
- enddo ; enddo
- if (associated(OBC)) then ; do n=1,OBC%number_of_segments
- if (.not. OBC%segment(n)%on_pe) cycle
- I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
- if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then
- do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied)
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- Area_h(i,j+1) = Area_h(i,j)
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
- Area_h(i,j) = Area_h(i,j+1)
- endif
- enddo
- elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then
- do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed)
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- Area_h(i+1,j) = Area_h(i,j)
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
- Area_h(i,j) = Area_h(i+1,j)
- endif
- enddo
- endif
- enddo ; endif
- !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h,Area_q)
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ enddo
+
+ if (associated(OBC)) then
+ !$omp target update from(Area_h)
+
+ do n=1,OBC%number_of_segments
+ if (.not. OBC%segment(n)%on_pe) cycle
+ I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
+ if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then
+ do i = max(Is_q,OBC%segment(n)%HI%isd), min(Ie_q+1,OBC%segment(n)%HI%ied)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
+ Area_h(i,j+1) = Area_h(i,j)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
+ Area_h(i,j) = Area_h(i,j+1)
+ endif
+ enddo
+ elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then
+ do j = max(Js_q,OBC%segment(n)%HI%jsd), min(Je_q+1,OBC%segment(n)%HI%jed)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
+ Area_h(i+1,j) = Area_h(i,j)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
+ Area_h(i,j) = Area_h(i+1,j)
+ endif
+ enddo
+ endif
+ enddo
+
+ !$omp target update to(Area_h)
+ endif
+
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
Area_q(i,j) = (Area_h(i,j) + Area_h(i+1,j+1)) + &
(Area_h(i+1,j) + Area_h(i,j+1))
- enddo ; enddo
+ enddo
Stokes_VF = .false.
if (present(Waves)) then ; if (associated(Waves)) then
Stokes_VF = Waves%Stokes_VF
endif ; endif
- !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,GV,CS,AD,Area_h,Area_q,&
- !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,vol_neglect,h_tiny,OBC,eps_vel, &
- !$OMP pbv, Stokes_VF)
- do k=1,nz
+ !$omp target enter data map(alloc: dvdx, dudy)
+ !$omp target enter data map(alloc: hArea_u, hArea_v)
+ !$omp target enter data map(alloc: rel_vort, abs_vort, q, Ih_q)
+ !$omp target enter data map(alloc: h_q) if (use_weno)
+ !$omp target enter data map(alloc: a, b, c, d, ep_u, ep_v)
+ !$omp target enter data map(alloc: KE, KEx, KEy)
+ ! TODO: These Stokes_VF fields seem associated with diagnostics
+ !$omp target enter data map(alloc: dvSdx, duSdy, stk_vort, qS) if (Stokes_VF)
+ !$omp target enter data map(alloc: CAuS, CAvS) if (Stokes_VF)
+ !$omp target enter data map(alloc: uh_center, vh_center) if (CS%Coriolis_En_Dis)
+ ! TODO: May also need SADOURNEY75_ENERGY
+ !$omp target enter data map(alloc: uh_min, vh_min) if (CS%Coriolis_En_Dis)
+ !$omp target enter data map(alloc: uh_max, vh_max) if (CS%Coriolis_En_Dis)
+
+ ! Diagnostics
+ !$omp target enter data map(alloc: RV) if (CS%id_RV > 0)
+ !$omp target enter data map(alloc: PV) if (CS%id_PV > 0)
+ !$omp target enter data map(alloc: q2) &
+ !$omp if(associated(AD%rv_x_u) .or. associated(AD%rv_x_v))
+ !$omp target enter data map(alloc: AD%gradKEu) if (associated(AD%gradKEu))
+ !$omp target enter data map(alloc: AD%gradKEv) if (associated(AD%gradKEv))
+ !$omp target enter data map(alloc: AD%rv_x_u) if (associated(AD%rv_x_u))
+ !$omp target enter data map(alloc: AD%rv_x_v) if (associated(AD%rv_x_v))
+
+ ! TODO: Do this outside of the function
+ !$omp target enter data map(to: pbv, pbv%por_face_areaU, pbv%por_face_areaV) &
+ !$omp if (CS%Coriolis_En_Dis)
+ do k=1,nz
! Here the second order accurate layer potential vorticities, q,
! are calculated. hq is second order accurate in space. Relative
! vorticity is second order accurate everywhere with free slip b.c.s,
@@ -290,230 +367,272 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
! First calculate the contributions to the circulation around the q-point.
if (Stokes_VF) then
if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
dvSdx(I,J) = (-Waves%us_y(i+1,J,k)*G%dyCv(i+1,J)) - &
(-Waves%us_y(i,J,k)*G%dyCv(i,J))
duSdy(I,J) = (-Waves%us_x(I,j+1,k)*G%dxCu(I,j+1)) - &
(-Waves%us_x(I,j,k)*G%dxCu(I,j))
- enddo; enddo
+ enddo
endif
if (.not. Waves%Passive_Stokes_VF) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
dvdx(I,J) = ((v(i+1,J,k)-Waves%us_y(i+1,J,k))*G%dyCv(i+1,J)) - &
((v(i,J,k)-Waves%us_y(i,J,k))*G%dyCv(i,J))
dudy(I,J) = ((u(I,j+1,k)-Waves%us_x(I,j+1,k))*G%dxCu(I,j+1)) - &
((u(I,j,k)-Waves%us_x(I,j,k))*G%dxCu(I,j))
- enddo; enddo
+ enddo
else
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J))
dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j))
- enddo; enddo
+ enddo
endif
else
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J))
dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j))
- enddo; enddo
+ enddo
endif
- do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2
+
+ do concurrent (J=Js_q:Je_q, i=Is_q:Ie_q+1)
hArea_v(i,J) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i,j+1) * h(i,j+1,k)))
- enddo ; enddo
- do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1
+ enddo
+
+ do concurrent (j=Js_q:Je_q+1, I=Is_q:Ie_q)
hArea_u(I,j) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i+1,j) * h(i+1,j,k)))
- enddo ; enddo
+ enddo
if (CS%Coriolis_En_Dis) then
- do j=Jsq,Jeq+1 ; do I=is-1,ie
+ do concurrent (J=Jsq:Jeq+1, I=is-1:ie)
uh_center(I,j) = 0.5 * ((G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k)) * (h(i,j,k) + h(i+1,j,k))
- enddo ; enddo
- do J=js-1,je ; do i=Isq,Ieq+1
+ enddo
+
+ do concurrent (J=js-1:je, i=Isq:Ieq+1)
vh_center(i,J) = 0.5 * ((G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k)) * (h(i,j,k) + h(i,j+1,k))
- enddo ; enddo
+ enddo
endif
! Adjust circulation components to relative vorticity and thickness projected onto
! velocity points on open boundaries.
- if (associated(OBC)) then ; do n=1,OBC%number_of_segments
- if (.not. OBC%segment(n)%on_pe) cycle
- I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
- if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then
- if (OBC%zero_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
- dvdx(I,J) = 0. ; dudy(I,J) = 0.
- enddo ; endif
- if (OBC%freeslip_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
- dudy(I,J) = 0.
- enddo ; endif
- if (OBC%computed_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- dudy(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%dxCu(I,j)
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
- dudy(I,J) = 2.0*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dxCu(I,j+1)
- endif
- enddo ; endif
- if (OBC%specified_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j)*G%dyBu(I,J)
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
- dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j+1)*G%dyBu(I,J)
+ if (associated(OBC)) then
+ !$omp target update from(Area_h)
+ !$omp target update from(dvdx, dudy)
+ !$omp target update from(hArea_u, hArea_v)
+ !$omp target update from(uh_center, vh_center)
+
+ do n=1,OBC%number_of_segments
+ if (.not. OBC%segment(n)%on_pe) cycle
+
+ I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
+
+ if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then
+ select case (OBC%vorticity_config)
+ case (OBC_VORTICITY_ZERO)
+ do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
+ dvdx(I,J) = 0. ; dudy(I,J) = 0.
+ enddo
+ case (OBC_VORTICITY_FREESLIP)
+ do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
+ dudy(I,J) = 0.
+ enddo
+ case (OBC_VORTICITY_COMPUTED)
+ do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
+ if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
+ dudy(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%dxCu(I,j)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
+ dudy(I,J) = 2.0*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dxCu(I,j+1)
+ endif
+ enddo
+ case (OBC_VORTICITY_SPECIFIED)
+ do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
+ if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
+ dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j)*G%dyBu(I,J)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
+ dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j+1)*G%dyBu(I,J)
+ endif
+ enddo
+ end select
+
+ ! Project thicknesses across OBC points with a no-gradient condition.
+ do i=max(Is_q,OBC%segment(n)%HI%isd), min(Ie_q+1,OBC%segment(n)%HI%ied)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
+ hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j,k)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
+ hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j+1,k)
+ endif
+ enddo
+
+ if (CS%Coriolis_En_Dis) then
+ do i=max(Isq,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
+ vh_center(i,J) = (G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k) * h(i,j,k)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
+ vh_center(i,J) = (G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k) * h(i,j+1,k)
+ endif
+ enddo
endif
- enddo ; endif
+ elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then
+ select case (OBC%vorticity_config)
+ case (OBC_VORTICITY_ZERO)
+ do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
+ dvdx(I,J) = 0. ; dudy(I,J) = 0.
+ enddo
+ case (OBC_VORTICITY_FREESLIP)
+ do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
+ dvdx(I,J) = 0.
+ enddo
+ case (OBC_VORTICITY_COMPUTED)
+ do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
+ if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
+ dvdx(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%dyCv(i,J)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
+ dvdx(I,J) = 2.0*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dyCv(i+1,J)
+ endif
+ enddo
+ case (OBC_VORTICITY_SPECIFIED)
+ do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
+ if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
+ dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i,J)*G%dxBu(I,J)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
+ dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i+1,J)*G%dxBu(I,J)
+ endif
+ enddo
+ end select
+
+ ! Project thicknesses across OBC points with a no-gradient condition.
+ do j=max(Js_q,OBC%segment(n)%HI%jsd), min(Je_q+1,OBC%segment(n)%HI%jed)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
+ hArea_u(I,j) = 0.5*(Area_h(i,j) + Area_h(i+1,j)) * h(i,j,k)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
+ hArea_u(I,j) = 0.5*(Area_h(i,j) + Area_h(i+1,j)) * h(i+1,j,k)
+ endif
+ enddo
- ! Project thicknesses across OBC points with a no-gradient condition.
- do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied)
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j,k)
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
- hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j+1,k)
+ if (CS%Coriolis_En_Dis) then
+ do j=max(Jsq,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
+ uh_center(I,j) = (G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k) * h(i,j,k)
+ else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
+ uh_center(I,j) = (G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k) * h(i+1,j,k)
+ endif
+ enddo
endif
- enddo
+ endif
+ enddo
+ endif
- if (CS%Coriolis_En_Dis) then
- do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied)
+ if (associated(OBC)) then
+ do n=1,OBC%number_of_segments
+ if (.not. OBC%segment(n)%on_pe) cycle
+ ! Now project thicknesses across cell-corner points in the OBCs. The two
+ ! projections have to occur in sequence and can not be combined easily.
+ I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
+ if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then
+ do I = max(Is_q,OBC%segment(n)%HI%IsdB), min(Ie_q,OBC%segment(n)%HI%IedB)
if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- vh_center(i,J) = (G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k) * h(i,j,k)
+ if (Area_h(i,j) + Area_h(i+1,j) > 0.0) then
+ hArea_u(I,j+1) = hArea_u(I,j) * ((Area_h(i,j+1) + Area_h(i+1,j+1)) / &
+ (Area_h(i,j) + Area_h(i+1,j)))
+ else ; hArea_u(I,j+1) = 0.0 ; endif
else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
- vh_center(i,J) = (G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k) * h(i,j+1,k)
+ if (Area_h(i,j+1) + Area_h(i+1,j+1) > 0.0) then
+ hArea_u(I,j) = hArea_u(I,j+1) * ((Area_h(i,j) + Area_h(i+1,j)) / &
+ (Area_h(i,j+1) + Area_h(i+1,j+1)))
+ else ; hArea_u(I,j) = 0.0 ; endif
endif
enddo
- endif
- elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then
- if (OBC%zero_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
- dvdx(I,J) = 0. ; dudy(I,J) = 0.
- enddo ; endif
- if (OBC%freeslip_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
- dvdx(I,J) = 0.
- enddo ; endif
- if (OBC%computed_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- dvdx(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%dyCv(i,J)
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
- dvdx(I,J) = 2.0*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dyCv(i+1,J)
- endif
- enddo ; endif
- if (OBC%specified_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i,J)*G%dxBu(I,J)
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
- dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i+1,J)*G%dxBu(I,J)
- endif
- enddo ; endif
-
- ! Project thicknesses across OBC points with a no-gradient condition.
- do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed)
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- hArea_u(I,j) = 0.5*(Area_h(i,j) + Area_h(i+1,j)) * h(i,j,k)
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
- hArea_u(I,j) = 0.5*(Area_h(i,j) + Area_h(i+1,j)) * h(i+1,j,k)
- endif
- enddo
- if (CS%Coriolis_En_Dis) then
- do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed)
+ elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then
+ do J = max(Js_q,OBC%segment(n)%HI%JsdB), min(Je_q,OBC%segment(n)%HI%JedB)
if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- uh_center(I,j) = (G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k) * h(i,j,k)
+ if (Area_h(i,j) + Area_h(i,j+1) > 0.0) then
+ hArea_v(i+1,J) = hArea_v(i,J) * ((Area_h(i+1,j) + Area_h(i+1,j+1)) / &
+ (Area_h(i,j) + Area_h(i,j+1)))
+ else ; hArea_v(i+1,J) = 0.0 ; endif
else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
- uh_center(I,j) = (G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k) * h(i+1,j,k)
+ hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j+1,k)
+ if (Area_h(i+1,j) + Area_h(i+1,j+1) > 0.0) then
+ hArea_v(i,J) = hArea_v(i+1,J) * ((Area_h(i,j) + Area_h(i,j+1)) / &
+ (Area_h(i+1,j) + Area_h(i+1,j+1)))
+ else ; hArea_v(i,J) = 0.0 ; endif
endif
enddo
endif
- endif
- enddo ; endif
+ enddo
- if (associated(OBC)) then ; do n=1,OBC%number_of_segments
- if (.not. OBC%segment(n)%on_pe) cycle
- ! Now project thicknesses across cell-corner points in the OBCs. The two
- ! projections have to occur in sequence and can not be combined easily.
- I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
- if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then
- do I = max(Isq-1,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB)
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- if (Area_h(i,j) + Area_h(i+1,j) > 0.0) then
- hArea_u(I,j+1) = hArea_u(I,j) * ((Area_h(i,j+1) + Area_h(i+1,j+1)) / &
- (Area_h(i,j) + Area_h(i+1,j)))
- else ; hArea_u(I,j+1) = 0.0 ; endif
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_S)
- if (Area_h(i,j+1) + Area_h(i+1,j+1) > 0.0) then
- hArea_u(I,j) = hArea_u(I,j+1) * ((Area_h(i,j) + Area_h(i+1,j)) / &
- (Area_h(i,j+1) + Area_h(i+1,j+1)))
- else ; hArea_u(I,j) = 0.0 ; endif
- endif
- enddo
- elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then
- do J = max(Jsq-1,OBC%segment(n)%HI%JsdB), min(Jeq+1,OBC%segment(n)%HI%JedB)
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- if (Area_h(i,j) + Area_h(i,j+1) > 0.0) then
- hArea_v(i+1,J) = hArea_v(i,J) * ((Area_h(i+1,j) + Area_h(i+1,j+1)) / &
- (Area_h(i,j) + Area_h(i,j+1)))
- else ; hArea_v(i+1,J) = 0.0 ; endif
- else ! (OBC%segment(n)%direction == OBC_DIRECTION_W)
- hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j+1,k)
- if (Area_h(i+1,j) + Area_h(i+1,j+1) > 0.0) then
- hArea_v(i,J) = hArea_v(i+1,J) * ((Area_h(i,j) + Area_h(i,j+1)) / &
- (Area_h(i+1,j) + Area_h(i+1,j+1)))
- else ; hArea_v(i,J) = 0.0 ; endif
- endif
- enddo
- endif
- enddo ; endif
+ !$omp target update to(dvdx, dudy)
+ !$omp target update to(hArea_u, hArea_v)
+ !$omp target update to(uh_center, vh_center)
+ endif
if (CS%no_slip) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
rel_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J)
- enddo; enddo
+ enddo
+
if (Stokes_VF) then
if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Jsq-1:Jeq+1, I=Isq-1:Ieq+1)
stk_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvSdx(I,J) - duSdy(I,J)) * G%IareaBu(I,J)
- enddo; enddo
+ enddo
endif
endif
else
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
rel_vort(I,J) = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J)
- enddo; enddo
+ enddo
+
if (Stokes_VF) then
if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Jsq-1:Jeq+1, I=Isq-1:Ieq+1)
stk_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvSdx(I,J) - duSdy(I,J)) * G%IareaBu(I,J)
- enddo; enddo
+ enddo
endif
endif
endif
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
abs_vort(I,J) = G%CoriolisBu(I,J) + rel_vort(I,J)
- enddo ; enddo
+ enddo
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J))
Ih_q(I,J) = Area_q(I,J) / (hArea_q + vol_neglect)
q(I,J) = abs_vort(I,J) * Ih_q(I,J)
- enddo; enddo
+ enddo
+
+ ! NOTE: `h_q` is only used by WENO and was pulled out of the above loop to
+ ! improve GPU performance, but it may need to be moved back.
+ if (use_weno) then
+ do concurrent (J=Js_q:Je_q, I=Is_q:Ie_q)
+ hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J))
+ h_q(I,J) = hArea_q / max(Area_q(I,J), area_neglect)
+ enddo
+ endif
if (Stokes_VF) then
if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
qS(I,J) = stk_vort(I,J) * Ih_q(I,J)
- enddo; enddo
+ enddo
endif
endif
if (CS%id_rv > 0) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Jsq-1:Jeq+1, I=Isq-1:Ieq+1)
RV(I,J,k) = rel_vort(I,J)
- enddo ; enddo
+ enddo
endif
if (CS%id_PV > 0) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Jsq-1:Jeq+1, I=Isq-1:Ieq+1)
PV(I,J,k) = q(I,J)
- enddo ; enddo
+ enddo
endif
if (associated(AD%rv_x_v) .or. associated(AD%rv_x_u)) then
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (J=Jsq-1:Jeq+1, I=Isq-1:Ieq+1)
q2(I,J) = rel_vort(I,J) * Ih_q(I,J)
- enddo ; enddo
+ enddo
endif
! a, b, c, and d are combinations of neighboring potential
@@ -521,25 +640,24 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
! scheme. All are defined at u grid points.
if (CS%Coriolis_Scheme == ARAKAWA_HSU90) then
- do j=Jsq,Jeq+1
- do I=is-1,Ieq
- a(I,j) = (q(I,J) + (q(I+1,J) + q(I,J-1))) * C1_12
- d(I,j) = ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) * C1_12
- enddo
- do I=Isq,Ieq
- b(I,j) = (q(I,J) + (q(I-1,J) + q(I,J-1))) * C1_12
- c(I,j) = ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) * C1_12
- enddo
+ do concurrent (j=Jsq:Jeq+1, I=is-1:Ieq)
+ a(I,j) = (q(I,J) + (q(I+1,J) + q(I,J-1))) * C1_12
+ d(I,j) = ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) * C1_12
+ enddo
+
+ do concurrent (j=Jsq:Jeq+1, I=Isq:Ieq)
+ b(I,j) = (q(I,J) + (q(I-1,J) + q(I,J-1))) * C1_12
+ c(I,j) = ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) * C1_12
enddo
elseif (CS%Coriolis_Scheme == ARAKAWA_LAMB81) then
- do j=Jsq,Jeq+1 ; do I=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, I=Isq:Ieq+1)
a(I-1,j) = (2.0*(q(I,J) + q(I-1,J-1)) + (q(I-1,J) + q(I,J-1))) * C1_24
d(I-1,j) = ((q(I,j) + q(I-1,J-1)) + 2.0*(q(I-1,J) + q(I,J-1))) * C1_24
b(I,j) = ((q(I,J) + q(I-1,J-1)) + 2.0*(q(I-1,J) + q(I,J-1))) * C1_24
c(I,j) = (2.0*(q(I,J) + q(I-1,J-1)) + (q(I-1,J) + q(I,J-1))) * C1_24
ep_u(i,j) = ((q(I,J) - q(I-1,J-1)) + (q(I-1,J) - q(I,J-1))) * C1_24
ep_v(i,j) = (-(q(I,J) - q(I-1,J-1)) + (q(I-1,J) - q(I,J-1))) * C1_24
- enddo ; enddo
+ enddo
elseif (CS%Coriolis_Scheme == AL_BLEND) then
Fe_m2 = CS%F_eff_max_blend - 2.0
rat_lin = 1.5 * Fe_m2 / max(CS%wt_lin_blend, 1.0e-16)
@@ -547,7 +665,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
! This allows the code to always give Sadourny Energy
if (CS%F_eff_max_blend <= 2.0) then ; Fe_m2 = -1. ; rat_lin = -1.0 ; endif
- do j=Jsq,Jeq+1 ; do I=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, I=Isq:Ieq+1)
min_Ihq = MIN(Ih_q(I-1,J-1), Ih_q(I,J-1), Ih_q(I-1,J), Ih_q(I,J))
max_Ihq = MAX(Ih_q(I-1,J-1), Ih_q(I,J-1), Ih_q(I-1,J), Ih_q(I,J))
rat_m1 = 1.0e15
@@ -584,14 +702,15 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
2.0 * (q(I,J) + q(I-1,J-1)) ) * C1_24
ep_u(i,j) = AL_wt * ((q(I,J) - q(I-1,J-1)) + (q(I-1,J) - q(I,J-1))) * C1_24
ep_v(i,j) = AL_wt * (-(q(I,J) - q(I-1,J-1)) + (q(I-1,J) - q(I,J-1))) * C1_24
- enddo ; enddo
+ enddo
endif
+ ! .and. SADOURNEY75_ENERGY ??
if (CS%Coriolis_En_Dis) then
! c1 = 1.0-1.5*RANGE ; c2 = 1.0-RANGE ; c3 = 2.0 ; slope = 0.5
c1 = 1.0-1.5*0.5 ; c2 = 1.0-0.5 ; c3 = 2.0 ; slope = 0.5
- do j=Jsq,Jeq+1 ; do I=is-1,ie
+ do concurrent (j=Jsq:Jeq+1, I=is-1:ie)
uhc = uh_center(I,j)
uhm = uh(I,j,k)
! This sometimes matters with some types of open boundary conditions.
@@ -611,8 +730,9 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
else
uh_max(I,j) = uhm ; uh_min(I,j) = uhc
endif
- enddo ; enddo
- do J=js-1,je ; do i=Isq,Ieq+1
+ enddo
+
+ do concurrent (J=js-1:je, i=Isq:Ieq+1)
vhc = vh_center(i,J)
vhm = vh(i,J,k)
! This sometimes matters with some types of open boundary conditions.
@@ -632,11 +752,12 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
else
vh_max(i,J) = vhm ; vh_min(i,J) = vhc
endif
- enddo ; enddo
+ enddo
endif
! Calculate KE and the gradient of KE
- call gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS)
+ call gradKE(u(:,:,k), v(:,:,k), h(:,:,k), KE, KEx, KEy, G, GV, US, CS)
+ ! TODO: Can KE be removed from this function?
! Calculate the tendencies of zonal velocity due to the Coriolis
! force and momentum advection. On a Cartesian grid, this is
@@ -644,7 +765,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
if (CS%Coriolis_Scheme == SADOURNY75_ENERGY) then
if (CS%Coriolis_En_Dis) then
! Energy dissipating biased scheme, Hallberg 200x
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
if (q(I,J)*u(I,j,k) == 0.0) then
temp1 = q(I,J) * ( (vh_max(i,j)+vh_max(i+1,j)) &
+ (vh_min(i,j)+vh_min(i+1,j)) )*0.5
@@ -662,33 +783,33 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
temp2 = q(I,J-1) * (vh_min(i,j-1)+vh_min(i+1,j-1))
endif
CAu(I,j,k) = 0.25 * G%IdxCu(I,j) * (temp1 + temp2)
- enddo ; enddo
+ enddo
else
! Energy conserving scheme, Sadourny 1975
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
CAu(I,j,k) = 0.25 * &
((q(I,J) * (vh(i+1,J,k) + vh(i,J,k))) + &
(q(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j)
- enddo ; enddo
+ enddo
endif
elseif (CS%Coriolis_Scheme == SADOURNY75_ENSTRO) then
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
CAu(I,j,k) = 0.125 * (G%IdxCu(I,j) * (q(I,J) + q(I,J-1))) * &
((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k)))
- enddo ; enddo
+ enddo
elseif ((CS%Coriolis_Scheme == ARAKAWA_HSU90) .or. &
(CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. &
(CS%Coriolis_Scheme == AL_BLEND)) then
! (Global) Energy and (Local) Enstrophy conserving, Arakawa & Hsu 1990
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
CAu(I,j,k) = (((a(I,j) * vh(i+1,J,k)) + (c(I,j) * vh(i,J-1,k))) + &
((b(I,j) * vh(i,J,k)) + (d(I,j) * vh(i+1,J-1,k)))) * G%IdxCu(I,j)
- enddo ; enddo
+ enddo
elseif (CS%Coriolis_Scheme == ROBUST_ENSTRO) then
! An enstrophy conserving scheme robust to vanishing layers
! Note: Heffs are in lieu of h_at_v that should be returned by the
! continuity solver. AJA
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
Heff1 = abs(vh(i,J,k) * G%IdxCv(i,J)) / (eps_vel+abs(v(i,J,k)))
Heff1 = max(Heff1, min(h(i,j,k),h(i,j+1,k)))
Heff1 = min(Heff1, max(h(i,j,k),h(i,j+1,k)))
@@ -711,28 +832,144 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
- ((abs_vort(I,J)-abs_vort(I,J-1))*abs(VHeff)) )
CAu(I,j,k) = (QVHeff / ( h_tiny + ((Heff1+Heff4) + (Heff2+Heff3)) ) ) * G%IdxCu(I,j)
endif
+ enddo
+ elseif (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) then
+ !$omp target update from(u, vh, abs_vort, h_q, q)
+ do j=js,je ; do I=Isq,Ieq
+ v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k)))
+ ! check whether there is masked land points in the stencil
+ third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * &
+ G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2))
+
+ fifth_order = third_order * G%mask2dCu(I,j-3) * G%mask2dCu(I,j+3)
+ seventh_order = fifth_order * G%mask2dCu(I,j-4) * G%mask2dCu(I,j+4)
+
+
+ ! compute the masking to make sure that inland values are not used
+ if (seventh_order == 1) then
+ ! all values are valid, we use seventh order reconstruction
+ u_q8(:) = (u(I,j-4:j+3,k) + u(I,j-3:j+4,k)) * 0.5
+ call weno_seven_h_weight_reconstruction(abs_vort(I,J-4:J+3), &
+ h_q(I,J-4:J+3), &
+ u_q8, &
+ GV%H_subroundoff, v_u, q_u, cs%weno_velocity_smooth)
+ CAu(I,j,k) = (q_u * v_u)
+
+ elseif (fifth_order == 1) then
+ ! all values are valid, we use fifth order reconstruction
+ u_q6(:) = (u(I,j-3:j+2,k) + u(I,j-2:j+3,k)) * 0.5
+ call weno_five_h_weight_reconstruction(abs_vort(I,J-3:J+2), &
+ h_q(I,J-3:J+2), &
+ u_q6, &
+ GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth)
+ CAu(I,j,k) = (q_u * v_u)
+
+ elseif (third_order == 1) then
+ ! only the middle values are valid, we use third order reconstruction
+ u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5
+ call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), &
+ h_q(I,J-2:J+1), &
+ u_q4, &
+ GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth)
+ CAu(I,j,k) = (q_u * v_u)
+ else ! Upwind first order
+ if (v_u>0.) then
+ q_u = q(I,J-1)
+ else
+ q_u = q(I,J)
+ endif
+ CAu(I,j,k) = (q_u * v_u)
+
+ endif
+ enddo ; enddo
+ !$omp target update to(CAu)
+ elseif (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) then
+ !$omp target update from(u, vh, abs_vort, h_q, q)
+ do j=js,je ; do I=Isq,Ieq
+ v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k)))
+ third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * &
+ G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2))
+
+ fifth_order = third_order * G%mask2dCu(I,j-3) * G%mask2dCu(I,j+3)
+
+ if (fifth_order == 1) then
+ ! all values are valid, we use fifth order reconstruction
+ u_q6(:) = (u(I,j-3:j+2,k) + u(I,j-2:j+3,k)) * 0.5
+ call weno_five_h_weight_reconstruction(abs_vort(I,J-3:J+2), &
+ h_q(I,J-3:J+2), &
+ u_q6, &
+ GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth)
+ CAu(I,j,k) = (q_u * v_u)
+
+ elseif (third_order == 1) then
+ ! only the middle values are valid, we use third order reconstruction
+ u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5
+ call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), &
+ h_q(I,J-2:J+1), &
+ u_q4, &
+ GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth)
+ CAu(I,j,k) = (q_u * v_u)
+
+ else ! Upwind first order
+ if (v_u>0.) then
+ q_u = q(I,J-1)
+ else
+ q_u = q(I,J)
+ endif
+ CAu(I,j,k) = (q_u * v_u)
+ endif
+ enddo ; enddo
+ elseif (CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO) then
+ !$omp target update from(u, vh, abs_vort, h_q, q)
+ do j=js,je ; do I=Isq,Ieq
+ v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k)))
+ third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * &
+ G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2))
+
+
+ if (third_order == 1) then
+ ! only the middle values are valid, we use third order reconstruction
+ u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5
+ call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), &
+ h_q(I,J-2:J+1), &
+ u_q4, &
+ GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth)
+ CAu(I,j,k) = (q_u * v_u)
+
+ else ! Upwind first order
+ if (v_u>0.) then
+ q_u = q(I,J-1)
+ else
+ q_u = q(I,J)
+ endif
+ CAu(I,j,k) = (q_u * v_u)
+ endif
enddo ; enddo
+ !$omp target update to(CAu)
endif
+
! Add in the additional terms with Arakawa & Lamb.
if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. &
- (CS%Coriolis_Scheme == AL_BLEND)) then ; do j=js,je ; do I=Isq,Ieq
- CAu(I,j,k) = CAu(I,j,k) + &
- ((ep_u(i,j)*uh(I-1,j,k)) - (ep_u(i+1,j)*uh(I+1,j,k))) * G%IdxCu(I,j)
- enddo ; enddo ; endif
+ (CS%Coriolis_Scheme == AL_BLEND)) then
+ do concurrent (j=js:je, I=Isq:Ieq)
+ CAu(I,j,k) = CAu(I,j,k) + &
+ ((ep_u(i,j)*uh(I-1,j,k)) - (ep_u(i+1,j)*uh(I+1,j,k))) * G%IdxCu(I,j)
+ enddo
+ endif
if (Stokes_VF) then
if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then
! Computing the diagnostic Stokes contribution to CAu
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
CAuS(I,j,k) = 0.25 * &
((qS(I,J) * (vh(i+1,J,k) + vh(i,J,k))) + &
(qS(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j)
- enddo ; enddo
+ enddo
endif
endif
if (CS%bound_Coriolis) then
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
fv1 = abs_vort(I,J) * v(i+1,J,k)
fv2 = abs_vort(I,J) * v(i,J,k)
fv3 = abs_vort(I,J-1) * v(i+1,J-1,k)
@@ -743,18 +980,18 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
CAu(I,j,k) = min(CAu(I,j,k), max_fv)
CAu(I,j,k) = max(CAu(I,j,k), min_fv)
- enddo ; enddo
+ enddo
endif
! Term - d(KE)/dx.
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
CAu(I,j,k) = CAu(I,j,k) - KEx(I,j)
- enddo ; enddo
+ enddo
if (associated(AD%gradKEu)) then
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
AD%gradKEu(I,j,k) = -KEx(I,j)
- enddo ; enddo
+ enddo
endif
! Calculate the tendencies of meridional velocity due to the Coriolis
@@ -763,7 +1000,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
if (CS%Coriolis_Scheme == SADOURNY75_ENERGY) then
if (CS%Coriolis_En_Dis) then
! Energy dissipating biased scheme, Hallberg 200x
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
if (q(I-1,J)*v(i,J,k) == 0.0) then
temp1 = q(I-1,J) * ( (uh_max(i-1,j)+uh_max(i-1,j+1)) &
+ (uh_min(i-1,j)+uh_min(i-1,j+1)) )*0.5
@@ -781,35 +1018,35 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
temp2 = q(I,J) * (uh_min(i,j)+uh_min(i,j+1))
endif
CAv(i,J,k) = -0.25 * G%IdyCv(i,J) * (temp1 + temp2)
- enddo ; enddo
+ enddo
else
! Energy conserving scheme, Sadourny 1975
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
CAv(i,J,k) = - 0.25* &
((q(I-1,J)*(uh(I-1,j,k) + uh(I-1,j+1,k))) + &
(q(I,J)*(uh(I,j,k) + uh(I,j+1,k)))) * G%IdyCv(i,J)
- enddo ; enddo
+ enddo
endif
elseif (CS%Coriolis_Scheme == SADOURNY75_ENSTRO) then
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
CAv(i,J,k) = -0.125 * (G%IdyCv(i,J) * (q(I-1,J) + q(I,J))) * &
((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k)))
- enddo ; enddo
+ enddo
elseif ((CS%Coriolis_Scheme == ARAKAWA_HSU90) .or. &
(CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. &
(CS%Coriolis_Scheme == AL_BLEND)) then
! (Global) Energy and (Local) Enstrophy conserving, Arakawa & Hsu 1990
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
CAv(i,J,k) = - (((a(I-1,j) * uh(I-1,j,k)) + &
(c(I,j+1) * uh(I,j+1,k))) &
+ ((b(I,j) * uh(I,j,k)) + &
(d(I-1,j+1) * uh(I-1,j+1,k)))) * G%IdyCv(i,J)
- enddo ; enddo
+ enddo
elseif (CS%Coriolis_Scheme == ROBUST_ENSTRO) then
! An enstrophy conserving scheme robust to vanishing layers
! Note: Heffs are in lieu of h_at_u that should be returned by the
! continuity solver. AJA
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
Heff1 = abs(uh(I,j,k) * G%IdyCu(I,j)) / (eps_vel+abs(u(I,j,k)))
Heff1 = max(Heff1, min(h(i,j,k),h(i+1,j,k)))
Heff1 = min(Heff1, max(h(i,j,k),h(i+1,j,k)))
@@ -835,28 +1072,151 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
CAv(i,J,k) = - QUHeff / &
(h_tiny + ((Heff1+Heff4) +(Heff2+Heff3)) ) * G%IdyCv(i,J)
endif
+ enddo
+ elseif (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) then
+ !$omp target update from(v, uh, abs_vort, h_q, q)
+ do J=Jsq,Jeq ; do i=is,ie
+ u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k)))
+
+ ! check whether there is any masked land values within the stencils
+ third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * &
+ G%mask2dCv(i+2,J))
+ fifth_order = third_order * G%mask2dCv(i-3,J) * G%mask2dCv(i+3,J)
+ seventh_order = fifth_order * G%mask2dCv(i-4,J) * G%mask2dCv(i+4,J)
+
+
+
+ ! compute the masking to make sure that inland values are not used
+ if (seventh_order == 1) then
+ v_q8(:) = (v(i-4:i+3,J,k) + v(i-3:i+4,J,k)) * 0.5
+ ! all values are valid, we use seventh order reconstruction
+ call weno_seven_h_weight_reconstruction(abs_vort(I-4:I+3,J), &
+ h_q(I-4:I+3,J), &
+ v_q8, &
+ GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth)
+ CAv(i,J,k) = - (q_v * u_v)
+
+ elseif (fifth_order == 1) then
+ v_q6(:) = (v(i-3:i+2,J,k) + v(i-2:i+3,J,k)) * 0.5
+ ! all values are valid, we use fifth order reconstruction
+ call weno_five_h_weight_reconstruction(abs_vort(I-3:I+2,J), &
+ h_q(I-3:I+2,J), &
+ v_q6, &
+ GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth)
+ CAv(i,J,k) = - (q_v * u_v)
+
+ elseif (third_order == 1) then
+ v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5
+! ! only the middle values are valid, we use third order reconstruction
+ call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), &
+ h_q(I-2:I+1,J), &
+ v_q4, &
+ GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth)
+ CAv(i,J,k) = - (q_v * u_v)
+ else ! Upwind first order!
+ if (u_v>0.) then
+ q_v = q(I-1,J)
+ else
+ q_v = q(I,J)
+ endif
+ CAv(i,J,k) = - (q_v * u_v)
+ endif
+
+ enddo ; enddo
+ !$omp target update to(CAv)
+ elseif (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) then
+ !$omp target update from(v, uh, abs_vort, h_q, q)
+ do J=Jsq,Jeq ; do i=is,ie
+ u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k)))
+
+ third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * &
+ G%mask2dCv(i+2,J))
+ fifth_order = third_order * G%mask2dCv(i-3,J) * G%mask2dCv(i+3,J)
+
+
+ ! compute the masking to make sure that inland values are not used
+ if (fifth_order == 1) then
+ v_q6(:) = (v(i-3:i+2,J,k) + v(i-2:i+3,J,k)) * 0.5
+ ! all values are valid, we use fifth order reconstruction
+ call weno_five_h_weight_reconstruction(abs_vort(I-3:I+2,J), &
+ h_q(I-3:I+2,J), &
+ v_q6, &
+ GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth)
+ CAv(i,J,k) = - (q_v * u_v)
+
+ elseif (third_order == 1) then
+ v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5
+! ! only the middle values are valid, we use third order reconstruction
+ call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), &
+ h_q(I-2:I+1,J), &
+ v_q4, &
+ GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth)
+ CAv(i,J,k) = - (q_v * u_v)
+
+ else
+ if (u_v>0.) then
+ q_v = q(I-1,J)
+ else
+ q_v = q(I,J)
+ endif
+ CAv(i,J,k) = - (q_v * u_v)
+ endif
+
+ enddo ; enddo
+ !$omp target update to(CAv)
+ elseif (CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO) then
+ !$omp target update from(v, uh, abs_vort, h_q, q)
+ do J=Jsq,Jeq ; do i=is,ie
+ u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k)))
+
+ third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * &
+ G%mask2dCv(i+2,J))
+
+
+ ! compute the masking to make sure that inland values are not used
+ if (third_order == 1) then
+ v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5
+! ! only the middle values are valid, we use third order reconstruction
+ call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), &
+ h_q(I-2:I+1,J), &
+ v_q4, &
+ GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth)
+ CAv(i,J,k) = - (q_v * u_v)
+
+ else
+ if (u_v>0.) then
+ q_v = q(I-1,J)
+ else
+ q_v = q(I,J)
+ endif
+ CAv(i,J,k) = - (q_v * u_v)
+ endif
+
enddo ; enddo
+ !$omp target update to(CAv)
endif
! Add in the additonal terms with Arakawa & Lamb.
if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. &
- (CS%Coriolis_Scheme == AL_BLEND)) then ; do J=Jsq,Jeq ; do i=is,ie
- CAv(i,J,k) = CAv(i,J,k) + &
- ((ep_v(i,j)*vh(i,J-1,k)) - (ep_v(i,j+1)*vh(i,J+1,k))) * G%IdyCv(i,J)
- enddo ; enddo ; endif
+ (CS%Coriolis_Scheme == AL_BLEND)) then
+ do concurrent (J=Jsq:Jeq, i=is:ie)
+ CAv(i,J,k) = CAv(i,J,k) + &
+ ((ep_v(i,j)*vh(i,J-1,k)) - (ep_v(i,j+1)*vh(i,J+1,k))) * G%IdyCv(i,J)
+ enddo
+ endif
if (Stokes_VF) then
if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then
! Computing the diagnostic Stokes contribution to CAv
- do J=Jsq,Jeq ; do i=is,ie
- CAvS(I,j,k) = 0.25 * &
+ do concurrent (J=Jsq:Jeq, i=is:ie)
+ CAvS(i,J,k) = 0.25 * &
((qS(I,J) * (uh(I,j+1,k) + uh(I,j,k))) + &
- (qS(I,J-1) * (uh(I-1,j,k) + uh(I-1,j+1,k)))) * G%IdyCv(i,J)
- enddo; enddo
+ (qS(I-1,J) * (uh(I-1,j,k) + uh(I-1,j+1,k)))) * G%IdyCv(i,J)
+ enddo
endif
endif
if (CS%bound_Coriolis) then
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
fu1 = -abs_vort(I,J) * u(I,j+1,k)
fu2 = -abs_vort(I,J) * u(I,j,k)
fu3 = -abs_vort(I-1,J) * u(I-1,j+1,k)
@@ -867,62 +1227,88 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
CAv(I,j,k) = min(CAv(I,j,k), max_fu)
CAv(I,j,k) = max(CAv(I,j,k), min_fu)
- enddo ; enddo
+ enddo
endif
! Term - d(KE)/dy.
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
CAv(i,J,k) = CAv(i,J,k) - KEy(i,J)
- enddo ; enddo
+ enddo
if (associated(AD%gradKEv)) then
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
AD%gradKEv(i,J,k) = -KEy(i,J)
- enddo ; enddo
+ enddo
endif
if (associated(AD%rv_x_u) .or. associated(AD%rv_x_v)) then
! Calculate the Coriolis-like acceleration due to relative vorticity.
if (CS%Coriolis_Scheme == SADOURNY75_ENERGY) then
if (associated(AD%rv_x_u)) then
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
AD%rv_x_u(i,J,k) = - 0.25* &
((q2(I-1,j)*(uh(I-1,j,k) + uh(I-1,j+1,k))) + &
(q2(I,j)*(uh(I,j,k) + uh(I,j+1,k)))) * G%IdyCv(i,J)
- enddo ; enddo
+ enddo
endif
if (associated(AD%rv_x_v)) then
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
AD%rv_x_v(I,j,k) = 0.25 * &
((q2(I,j) * (vh(i+1,J,k) + vh(i,J,k))) + &
(q2(I,j-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j)
- enddo ; enddo
+ enddo
endif
else
if (associated(AD%rv_x_u)) then
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
AD%rv_x_u(i,J,k) = -G%IdyCv(i,J) * C1_12 * &
(((((q2(I,J) + q2(I-1,J-1)) + q2(I-1,J)) * uh(I-1,j,k)) + &
(((q2(I-1,J) + q2(I,J+1)) + q2(I,J)) * uh(I,j+1,k))) + &
((((q2(I-1,J) + q2(I,J-1)) + q2(I,J)) * uh(I,j,k))+ &
(((q2(I,J) + q2(I-1,J+1)) + q2(I-1,J)) * uh(I-1,j+1,k))))
- enddo ; enddo
+ enddo
endif
if (associated(AD%rv_x_v)) then
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
AD%rv_x_v(I,j,k) = G%IdxCu(I,j) * C1_12 * &
(((((q2(I+1,J) + q2(I,J-1)) + q2(I,J)) * vh(i+1,J,k)) + &
(((q2(I-1,J-1) + q2(I,J)) + q2(I,J-1)) * vh(i,J-1,k))) + &
((((q2(I-1,J) + q2(I,J-1)) + q2(I,J)) * vh(i,J,k)) + &
(((q2(I+1,J-1) + q2(I,J)) + q2(I,J-1)) * vh(i+1,J-1,k))))
- enddo ; enddo
+ enddo
endif
endif
endif
-
enddo ! k-loop.
+ !$omp target exit data map(delete: Area_h, Area_q)
+ !$omp target exit data map(delete: dvdx, dudy)
+ !$omp target exit data map(delete: hArea_u, hArea_v)
+ !$omp target exit data map(delete: rel_vort, abs_vort, q, Ih_q)
+ !$omp target exit data map(delete: h_q) if (use_weno)
+ !$omp target exit data map(delete: a, b, c, d, ep_u, ep_v)
+ !$omp target exit data map(delete: KE, KEx, KEy)
+ !$omp target exit data map(delete: dvSdx, duSdy, stk_vort, qS) if (Stokes_VF)
+ !$omp target exit data map(delete: uh_center, vh_center) if (CS%Coriolis_En_Dis)
+ !$omp target exit data map(delete: uh_min, vh_min) if (CS%Coriolis_En_Dis)
+ !$omp target exit data map(delete: uh_max, vh_max) if (CS%Coriolis_En_Dis)
+ !$omp target exit data map(delete: q2) &
+ !$omp if(associated(AD%rv_x_u) .or. associated(AD%rv_x_v))
+
+ ! TODO: Move outside function
+ !$omp target exit data map(delete: pbv, pbv%por_face_areaU, pbv%por_face_areaV) &
+ !$omp if (CS%Coriolis_En_Dis)
+
+ ! Diagnostics
+ !$omp target exit data map(from: RV) if (CS%id_RV > 0)
+ !$omp target exit data map(from: PV) if (CS%id_RV > 0)
+ !$omp target exit data map(from: AD%gradKEu) if (associated(AD%gradKEu))
+ !$omp target exit data map(from: AD%gradKEv) if (associated(AD%gradKEv))
+ !$omp target exit data map(from: AD%rv_x_u) if (associated(AD%rv_x_u))
+ !$omp target exit data map(from: AD%rv_x_u) if (associated(AD%rv_x_u))
+ !$omp target exit data map(from: CAuS, CAvS) if (Stokes_VF)
+
! Here the various Coriolis-related derived quantities are offered for averaging.
if (query_averaging_enabled(CS%diag)) then
if (CS%id_rv > 0) call post_data(CS%id_rv, RV, CS%diag)
@@ -961,94 +1347,652 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav
if (CS%id_intz_rvxv_2d > 0) call post_product_sum_u(CS%id_intz_rvxv_2d, AD%rv_x_v, AD%diag_hu, G, nz, CS%diag)
if (CS%id_intz_rvxu_2d > 0) call post_product_sum_v(CS%id_intz_rvxu_2d, AD%rv_x_u, AD%diag_hv, G, nz, CS%diag)
endif
-
end subroutine CorAdCalc
-!> Calculates the acceleration due to the gradient of kinetic energy.
-subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS)
- type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
- type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure
- real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]
- real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]
- real, dimension(SZI_(G) ,SZJ_(G) ), intent(out) :: KE !< Kinetic energy per unit mass [L2 T-2 ~> m2 s-2]
- real, dimension(SZIB_(G),SZJ_(G) ), intent(out) :: KEx !< Zonal acceleration due to kinetic
- !! energy gradient [L T-2 ~> m s-2]
- real, dimension(SZI_(G) ,SZJB_(G)), intent(out) :: KEy !< Meridional acceleration due to kinetic
- !! energy gradient [L T-2 ~> m s-2]
- integer, intent(in) :: k !< Layer number to calculate for
- type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv
+!> Calculates the acceleration due to the gradient of kinetic energy in one layer.
+subroutine gradKE(u, v, h, KE, KEx, KEy, G, GV, US, CS)
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure
+ real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]
+ real, dimension(SZI_(G),SZJB_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]
+ real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]
+ real, dimension(SZI_(G),SZJ_(G)), intent(out) :: KE !< Kinetic energy per unit mass [L2 T-2 ~> m2 s-2]
+ real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: KEx !< Zonal acceleration due to kinetic
+ !! energy gradient [L T-2 ~> m s-2]
+ real, dimension(SZI_(G),SZJB_(G)), intent(out) :: KEy !< Meridional acceleration due to kinetic
+ !! energy gradient [L T-2 ~> m s-2]
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv
! Local variables
real :: um, up, vm, vp ! Temporary variables [L T-1 ~> m s-1].
real :: um2, up2, vm2, vp2 ! Temporary variables [L2 T-2 ~> m2 s-2].
real :: um2a, up2a, vm2a, vp2a ! Temporary variables [L4 T-2 ~> m4 s-2].
+ real :: third_order_u, third_order_v ! Product of mask values to determine the boundary
integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n
+ real, parameter :: C1_12 = 1.0/12.0 ! The ratio of 1/12 [nondim]
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
-
! Calculate KE (Kinetic energy for use in the -grad(KE) acceleration term).
if (CS%KE_Scheme == KE_ARAKAWA) then
! The following calculation of Kinetic energy includes the metric terms
! identified in Arakawa & Lamb 1982 as important for KE conservation. It
! also includes the possibility of partially-blocked tracer cell faces.
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- KE(i,j) = ( ( (G%areaCu( I ,j)*(u( I ,j,k)*u( I ,j,k))) + &
- (G%areaCu(I-1,j)*(u(I-1,j,k)*u(I-1,j,k))) ) + &
- ( (G%areaCv(i, J )*(v(i, J ,k)*v(i, J ,k))) + &
- (G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k))) ) )*0.25*G%IareaT(i,j)
- enddo ; enddo
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ KE(i,j) = ( ( (G%areaCu( I ,j)*(u( I ,j)*u( I ,j))) + &
+ (G%areaCu(I-1,j)*(u(I-1,j)*u(I-1,j))) ) + &
+ ( (G%areaCv(i, J )*(v(i, J )*v(i, J ))) + &
+ (G%areaCv(i,J-1)*(v(i,J-1)*v(i,J-1))) ) )*0.25*G%IareaT(i,j)
+ enddo
elseif (CS%KE_Scheme == KE_SIMPLE_GUDONOV) then
! The following discretization of KE is based on the one-dimensional Gudonov
! scheme which does not take into account any geometric factors
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- up = 0.5*( u(I-1,j,k) + ABS( u(I-1,j,k) ) ) ; up2 = up*up
- um = 0.5*( u( I ,j,k) - ABS( u( I ,j,k) ) ) ; um2 = um*um
- vp = 0.5*( v(i,J-1,k) + ABS( v(i,J-1,k) ) ) ; vp2 = vp*vp
- vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2 = vm*vm
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ up = 0.5*( u(I-1,j) + ABS( u(I-1,j) ) ) ; up2 = up*up
+ um = 0.5*( u( I ,j) - ABS( u( I ,j) ) ) ; um2 = um*um
+ vp = 0.5*( v(i,J-1) + ABS( v(i,J-1) ) ) ; vp2 = vp*vp
+ vm = 0.5*( v(i, J ) - ABS( v(i, J ) ) ) ; vm2 = vm*vm
KE(i,j) = ( max(up2,um2) + max(vp2,vm2) ) *0.5
- enddo ; enddo
+ enddo
elseif (CS%KE_Scheme == KE_GUDONOV) then
! The following discretization of KE is based on the one-dimensional Gudonov
! scheme but has been adapted to take horizontal grid factors into account
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- up = 0.5*( u(I-1,j,k) + ABS( u(I-1,j,k) ) ) ; up2a = up*up*G%areaCu(I-1,j)
- um = 0.5*( u( I ,j,k) - ABS( u( I ,j,k) ) ) ; um2a = um*um*G%areaCu( I ,j)
- vp = 0.5*( v(i,J-1,k) + ABS( v(i,J-1,k) ) ) ; vp2a = vp*vp*G%areaCv(i,J-1)
- vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2a = vm*vm*G%areaCv(i, J )
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ up = 0.5*( u(I-1,j) + ABS( u(I-1,j) ) ) ; up2a = up*up*G%areaCu(I-1,j)
+ um = 0.5*( u( I ,j) - ABS( u( I ,j) ) ) ; um2a = um*um*G%areaCu( I ,j)
+ vp = 0.5*( v(i,J-1) + ABS( v(i,J-1) ) ) ; vp2a = vp*vp*G%areaCv(i,J-1)
+ vm = 0.5*( v(i, J ) - ABS( v(i, J ) ) ) ; vm2a = vm*vm*G%areaCv(i, J )
KE(i,j) = ( max(um2a,up2a) + max(vm2a,vp2a) )*0.5*G%IareaT(i,j)
- enddo ; enddo
+ enddo
+ elseif (CS%KE_Scheme == KE_UP3) then
+ ! The following discretization of KE is based on the one-dimensional third-order
+ ! upwind scheme which does not take horizontal grid factors into account
+
+ ! TODO: GPU data tansfers?
+ if (CS%KE_use_limiter) then
+ do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ ! compute the masking to make sure that inland values are not used
+ third_order_u = (G%mask2dCu(I-2,j) * G%mask2dCu(I-1,j)* &
+ G%mask2dCu(I,j) * G%mask2dCu(I+1,j))
+
+ if (third_order_u == 1) then
+ up = (7.0 * (u(I-1,j) + u(I,j)) - (u(I-2,j) + u(I+1,j))) * C1_12
+ call UP3_Koren_limiter_reconstruction(u(I-2:I+1,j), up, um)
+ else
+ up = (u(I-1,j) + u(I,j))*0.5
+ if (up>0.) then
+ um = u(I-1,j)
+ elseif (up<0.) then
+ um = u(I,j)
+ else
+ um = up
+ endif
+ endif
+
+ third_order_v = (G%mask2dCv(i,J-2) * G%mask2dCv(i,J-1)* &
+ G%mask2dCv(i,J) * G%mask2dCv(i,J+1))
+ if (third_order_v ==1) then
+ vp = (7.0 * (v(i,J-1) + v(i,J)) - (v(i,J-2) + v(i,J+1))) * C1_12
+ call UP3_Koren_limiter_reconstruction(v(i,J-2:J+1), vp, vm)
+ else
+ vp = (v(i,J-1) + v(i,J))*0.5
+ if (vp>0.) then
+ vm = v(i,J-1)
+ elseif (vp<0.) then
+ vm = v(i,J)
+ else
+ vm = vp
+ endif
+ endif
+
+ KE(i,j) = ( (um*um) + (vm*vm) )*0.5
+ enddo ; enddo
+ else
+ do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ ! compute the masking to make sure that inland values are not used
+ third_order_u = (G%mask2dCu(I-2,j) * G%mask2dCu(I-1,j)* &
+ G%mask2dCu(I,j) * G%mask2dCu(I+1,j))
+
+ if (third_order_u == 1) then
+ up = (7.0 * (u(I-1,j) + u(I,j)) - (u(I-2,j) + u(I+1,j))) * C1_12
+ call UP3_reconstruction(u(I-2:I+1,j), up, um)
+ else
+ up = (u(I-1,j) + u(I,j))*0.5
+ if (up>0.) then
+ um = u(I-1,j)
+ elseif (up<0.) then
+ um = u(I,j)
+ else
+ um = up
+ endif
+ endif
+
+ third_order_v = (G%mask2dCv(i,J-2) * G%mask2dCv(i,J-1)* &
+ G%mask2dCv(i,J) * G%mask2dCv(i,J+1))
+ if (third_order_v ==1) then
+ vp = (7.0 * (v(i,J-1) + v(i,J)) - (v(i,J-2) + v(i,J+1))) * C1_12
+ call UP3_reconstruction(v(i,J-2:J+1), vp, vm)
+ else
+ vp = (v(i,J-1) + v(i,J))*0.5
+ if (vp>0.) then
+ vm = v(i,J-1)
+ elseif (vp<0.) then
+ vm = v(i,J)
+ else
+ vm = vp
+ endif
+ endif
+
+ KE(i,j) = ( (um*um) + (vm*vm) )*0.5
+ enddo ; enddo
+ endif
endif
! Term - d(KE)/dx.
- do j=js,je ; do I=Isq,Ieq
- KEx(I,j) = (KE(i+1,j) - KE(i,j)) * G%IdxCu(I,j)
- enddo ; enddo
+ do concurrent (j=js:je, I=Isq:Ieq)
+ KEx(I,j) = (KE(i+1,j) - KE(i,j)) * G%IdxCu_OBCmask(I,j)
+ enddo
! Term - d(KE)/dy.
- do J=Jsq,Jeq ; do i=is,ie
- KEy(i,J) = (KE(i,j+1) - KE(i,j)) * G%IdyCv(i,J)
- enddo ; enddo
+ do concurrent (J=Jsq:Jeq, i=is:ie)
+ KEy(i,J) = (KE(i,j+1) - KE(i,j)) * G%IdyCv_OBCmask(i,J)
+ enddo
+end subroutine gradKE
- if (associated(OBC)) then
- do n=1,OBC%number_of_segments
- if (OBC%segment(n)%is_N_or_S) then
- do i=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied
- KEy(i,OBC%segment(n)%HI%JsdB) = 0.
- enddo
- elseif (OBC%segment(n)%is_E_or_W) then
- do j=OBC%segment(n)%HI%jsd,OBC%segment(n)%HI%jed
- KEx(OBC%segment(n)%HI%IsdB,j) = 0.
- enddo
+!> Reconstruct the scalar (e.g., pv, vorticity) onto point i-1/2 using a third-order upwind scheme
+subroutine UP3_reconstruction(q4,u,qr)
+ real, intent(in) :: q4(4) !< Tracer values on points i-2, i-1, i, i+1 [A ~> a]
+ real, intent(in) :: u !< Velocity or thickness flux on point i-1/2
+ !! [l t-1 ~> m s-1] or [l2 t-1 ~> m2 s-1]
+ real, intent(inout) :: qr !< Reconstruction of tracer q at point i-1/2 [A ~> a]
+ real, parameter :: C1_6 = 1.0/6.0 ! The ratio of 1/6 [nondim]
+
+ if (u>0.) then
+ qr = ((2.*q4(3) + 5.*q4(2)) - q4(1)) * C1_6
+ else
+ qr = ((2.*q4(2) + 5.*q4(3)) - q4(4)) * C1_6
+ endif
+
+end subroutine UP3_reconstruction
+
+
+!> Reconstruct the scalar (e.g., PV, vorticity) onto point i-1/2
+!! using a third-order upwind scheme with the Koren flux limiter
+subroutine UP3_Koren_limiter_reconstruction(q4,u,qr)
+ real, intent(in) :: q4(4) !< Tracer values on points i-2, i-1, i, i+1 [A ~> a]
+ real, intent(in) :: u !< Velocity or thickness flux on point i-1/2
+ !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1]
+ real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a]
+ real :: theta ! Ratio of gradient [nondim]
+ real :: psi ! Limiter function [nondim]
+ real, parameter :: C1_3 = 1.0/3.0 ! The ratio of 1/3 [nondim]
+ real, parameter :: C1_6 = 1.0/6.0 ! The ratio of 1/6 [nondim]
+
+ if (u>0.) then
+ if (q4(3) == q4(2)) then
+ qr = q4(2)
+ else
+ theta = (q4(2) - q4(1))/(q4(3) - q4(2))
+ psi = max(0., min(1., C1_3 + C1_6*theta, theta)) ! limiter introduced by Koren (1993)
+ qr = q4(2) + psi*(q4(3) - q4(2))
+ endif
+ else
+ if (q4(3) == q4(2)) then
+ qr = q4(3)
+ else
+ theta = (q4(4) - q4(3))/(q4(3) - q4(2))
+ psi = max(0., min(1., C1_3 + C1_6*theta, theta))
+ qr = q4(3) + psi*(q4(2) - q4(3))
+ endif
+ endif
+
+end subroutine UP3_Koren_limiter_reconstruction
+
+!> Compute the factor for the WENO weights
+function fac_fn(tau, b) result(fac)
+ real, intent(in) :: tau !< Difference of the smoothness indicator [A ~> a]
+ real, intent(in) :: b !< The smoothness indicator [A ~> a]
+ real :: fac !< The factor for the weight [nondim]
+
+ fac = 1.0e40 ; if (abs(b) > 1.0e-20*tau) fac = (1 + tau / b)**2
+
+end function fac_fn
+
+
+!> Reconstruct the tracer (e.g., PV, vorticity) onto the point i-1/2 using a third-order WENO scheme
+!! This reconstruction is thickness-weighted
+subroutine weno_three_h_weight_reconstruction(q4, h4, u4, &
+ h_tiny, u, qr, velocity_smoothing)
+ real, intent(in) :: q4(4) !< Tracer value times thickness on points i-2, i-1, i, i+1 [A ~> a]
+ real, intent(in) :: h4(4) !< Thickness values on points i-2, i-1, i, i+1 [L ~> m]
+ real, optional, intent(in) :: u4(4) !< Velocity values on points i-2, i-1, i, i+1
+ !![L T-1 ~> m s-1]
+ real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m]
+ real, intent(in) :: u !< Velocity or thickness flux on point i-1/2
+ !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1]
+ real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a]
+ logical, intent(in) :: velocity_smoothing !< If true, use velocity to compute smoothness indicator
+ real :: vr ! Reconstruction of hq [A ~> a]
+ real :: hr ! Reconstruction of h [L ~> m]
+ real :: c0, c1 ! Intermediate reconstruction of q [A ~> a]
+ real :: d0, d1 ! Intermediate reconstruction of h [L ~> m]
+ real :: b0, b1 ! Smoothness indicator [A ~> a]
+ real :: tau ! Difference of smoothness indicator [A ~> a]
+ real :: w0, w1 ! Weights [nondim]
+ real :: s ! Temporary variables [nondim]
+ real, parameter :: C2_3 = 2.0/3.0 ! The ratio of 2/3 [nondim]
+ real, parameter :: C1_3 = 1.0/3.0 ! The ratio of 1/3 [nondim]
+
+ if (u>0.) then
+ call weno_three_reconstruction_0(q4(2:3), c0) ! Reconstruction in the second upwind stencil
+ call weno_three_reconstruction_1(q4(1:2), c1) ! Reconstruction in the first upwind stencil
+
+ call weno_three_reconstruction_0(h4(2:3), d0)
+ call weno_three_reconstruction_1(h4(1:2), d1)
+ if (velocity_smoothing) then
+ call weno_three_weight(u4(2:3), b0) ! Smoothness indicator the second upwind stencil
+ call weno_three_weight(u4(1:2), b1) ! Smoothness indicator the first upwind stencil
+ else
+ call weno_three_weight(q4(2:3), b0) ! Smoothness indicator the second upwind stencil
+ call weno_three_weight(q4(1:2), b1) ! Smoothness indicator the first upwind stencil
endif
- enddo
+ else
+ call weno_three_reconstruction_0(q4(3:2:-1), c0) ! Reconstruction in the second upwind stencil
+ call weno_three_reconstruction_1(q4(4:3:-1), c1) ! Reconstruction in the first upwind stencil
+
+ call weno_three_reconstruction_0(h4(3:2:-1), d0)
+ call weno_three_reconstruction_1(h4(4:3:-1), d1)
+ if (velocity_smoothing) then
+ call weno_three_weight(u4(3:2:-1), b0) ! Smoothness indicator the second upwind stencil
+ call weno_three_weight(u4(4:3:-1), b1) ! Smoothness indicator the first upwind stencil
+ else
+ call weno_three_weight(q4(3:2:-1), b0) ! Smoothness indicator the second upwind stencil
+ call weno_three_weight(q4(4:3:-1), b1) ! Smoothness indicator the first upwind stencil
+ endif
+ endif
+
+ tau = abs(b0-b1)
+ w0 = C2_3 * fac_fn(tau, b0)
+ w1 = C1_3 * fac_fn(tau, b1)
+
+ s = 1. / (w0 + w1)
+ w0 = w0 * s ! Weights of stencils
+ w1 = w1 * s
+
+ vr = (w0 * c0) + (w1 * c1)
+ hr = (w0 * d0) + (w1 * d1)
+! vr = min(max(q4(3), q4(2)), vr) ; vr = max(min(q4(3), q4(2)), vr) !Impose a monotonicity limiter
+ hr = min(max(h4(3), h4(2)), hr) ; hr = max(min(h4(3), h4(2)), hr) ! A monotonicity limiter
+
+ qr = vr / max(hr, h_tiny)
+
+end subroutine weno_three_h_weight_reconstruction
+
+!> Compute the smoothness indicator for the two-point stencil of the third-order WENO scheme
+subroutine weno_three_weight(q2, w0)
+ real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a]
+ real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2]
+
+ w0 = (q2(1) - q2(2))**2
+
+end subroutine weno_three_weight
+
+!> Reconstruction in the second upwind stencil of the third-order WENO scheme
+subroutine weno_three_reconstruction_0(q2, w0)
+ real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a]
+ real, intent(inout) :: w0 !< Reconstruction of the quantity [A2 ~> a2]
+
+ w0 = (q2(1) + q2(2)) * 0.5
+
+end subroutine weno_three_reconstruction_0
+
+!> Reconstruction in the first upwind stencil for third-order WENO scheme
+subroutine weno_three_reconstruction_1(q2, w0)
+ real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a]
+ real, intent(inout) :: w0 !< Reconstruction of the quantity [A ~> a]
+
+ w0 = (- q2(1) + 3 * q2(2)) * 0.5
+
+end subroutine weno_three_reconstruction_1
+
+
+!> Reconstruct the tracer (e.g., PV, vorticity) onto point i-1/2 using a fifth-order WENO scheme
+!! The reconstruction is weighted by the thickness
+subroutine weno_five_h_weight_reconstruction(q6, h6, u6, &
+ h_tiny, u, qr, velocity_smoothing)
+ real, intent(in) :: q6(6)
+ !< Tracer values on points i-3, i-2, i-1, i, i+1, i+2 [A ~> a]
+ real, intent(in) :: h6(6)
+ !< Thickness values on points i-3, i-2, i-1, i, i+1, i+2 [L ~> m]
+ real, optional, intent(in) :: u6(6)
+ !< Velocity values on points i-3, i-2, i-1, i, i+1, i+2 [L T-1 ~> m s-1]
+ real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m]
+ real, intent(in) :: u !< Velocity or thickness flux on point i-1/2
+ !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1]
+ logical, intent(in) :: velocity_smoothing !< If ture, use velocity to compute the smoothness indicator
+ real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a]
+ real :: vr ! Reconstruction of hq [A ~> a]
+ real :: hr ! Reconstruction of h [L ~> m]
+ real :: c0, c1, c2 ! Intermediate reconstruction of hq[A ~> a]
+ real :: d0, d1, d2 ! Intermediate reconstruction of h [L ~> m]
+ real :: b0, b1, b2 ! Smoothness indicator [A ~> a]
+ real :: tau ! Difference of smoothness indicators [A ~> a]
+ real :: w0, w1, w2 ! Weights [nondim]
+ real :: s ! Temporary variables [nondim]
+ real, parameter :: C3_10 = 3.0/10.0 ! The ratio of 3/10 [nondim]
+ real, parameter :: C3_5 = 3.0/5.0 ! The ratio of 3/5 [nondim]
+ real, parameter :: C1_10 = 1.0/10.0 ! The ratio of 1/10 [nondim]
+
+ if (u>0.) then
+ call weno_five_reconstruction_0(q6(3:5), c0) ! Reconstruction in the third upwind stencil
+ call weno_five_reconstruction_1(q6(2:4), c1) ! Reconstruction in the second upwind stencil
+ call weno_five_reconstruction_2(q6(1:3), c2) ! Reconstruction in the first upwind stencil
+
+ call weno_five_reconstruction_0(h6(3:5), d0)
+ call weno_five_reconstruction_1(h6(2:4), d1)
+ call weno_five_reconstruction_2(h6(1:3), d2)
+ if (velocity_smoothing) then
+ call weno_five_weight_0(u6(3:5), b0) ! Smoothness indicator of the third upwind stencil
+ call weno_five_weight_1(u6(2:4), b1) ! Smoothness indicator of the second upwind stencil
+ call weno_five_weight_2(u6(1:3), b2) ! Smoothness indicator of the first upwind stencil
+ else
+ call weno_five_weight_0(q6(3:5), b0)
+ call weno_five_weight_1(q6(2:4), b1)
+ call weno_five_weight_2(q6(1:3), b2)
+ endif
+ else
+ call weno_five_reconstruction_0(q6(4:2:-1), c0) ! Reconstruction in the third upwind stencil
+ call weno_five_reconstruction_1(q6(5:3:-1), c1) ! Reconstruction in the second upwind stencil
+ call weno_five_reconstruction_2(q6(6:4:-1), c2) ! Reconstruction in the first upwind stencil
+
+ call weno_five_reconstruction_0(h6(4:2:-1), d0)
+ call weno_five_reconstruction_1(h6(5:3:-1), d1)
+ call weno_five_reconstruction_2(h6(6:4:-1), d2)
+ if (velocity_smoothing) then
+ call weno_five_weight_0(u6(4:2:-1), b0) ! Smoothness indicator of the third upwind stencil
+ call weno_five_weight_1(u6(5:3:-1), b1) ! Smoothness indicator of the second upwind stencil
+ call weno_five_weight_2(u6(6:4:-1), b2) ! Smoothness indicator of the first upwind stencil
+ else
+ call weno_five_weight_0(q6(4:2:-1), b0)
+ call weno_five_weight_1(q6(5:3:-1), b1)
+ call weno_five_weight_2(q6(6:4:-1), b2)
+ endif
+ endif
+
+ tau = abs(b0 - b2)
+ w0 = C3_10 * fac_fn(tau, b0)
+ w1 = C3_5 * fac_fn(tau, b1)
+ w2 = C1_10 * fac_fn(tau, b2)
+
+ s = 1. / ((w0 + w1) + w2)
+ w0 = w0 * s ! Weights of stencils
+ w1 = w1 * s
+ w2 = w2 * s
+
+ vr = ((w0 * c0) + (w1 * c1)) + (w2 * c2)
+ hr = ((w0 * d0) + (w1 * d1)) + (w2 * d2)
+! vr = min(max(q6(3), q6(4)), vr) ; vr = max(min(q6(3), q6(4)), vr) !Impose a monotonicity limiter
+ hr = min(max(h6(3), h6(4)), hr) ; hr = max(min(h6(3), h6(4)), hr) !Impose a monotonicity limiter
+
+ qr = vr / max(hr, h_tiny)
+
+end subroutine weno_five_h_weight_reconstruction
+
+!> Compute the smoothness indicator for the third upwind stencil of the fifth-order WENO scheme
+subroutine weno_five_weight_0(q3, w0)
+ real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a]
+ real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2]
+
+ w0 = (q3(1) * ((10 * q3(1) - 31 * q3(2)) + 11 * q3(3))) + &
+ ((q3(2) * (25 * q3(2) - 19 * q3(3))) + 4 * (q3(3) * q3(3)))
+
+end subroutine weno_five_weight_0
+
+!> Compute the smoothness indicator for the second upwind stencil of the fifth-order WENO scheme
+subroutine weno_five_weight_1(q3, w1)
+ real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a]
+ real, intent(inout) :: w1 !< Smoothness indicator for this stencil [A2 ~> a2]
+
+ w1 = (q3(1) * ((4 * q3(1) - 13 * q3(2)) + 5 * q3(3))) + &
+ ((q3(2) * (13 * q3(2) - 13 * q3(3))) + 4 * (q3(3) * q3(3)))
+
+end subroutine weno_five_weight_1
+
+!> Compute the smoothness indicator for the first upwind stencil of the fifth-order WENO scheme
+subroutine weno_five_weight_2(q3, w2)
+ real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a]
+ real, intent(inout) :: w2 !< Smoothness indicator for this stencil [A2 ~> a2]
+
+ w2 = (q3(1) * ((4 * q3(1) - 19 * q3(2)) + 11 * q3(3))) + &
+ ((q3(2) * (25 * q3(2) - 31 * q3(3))) + 10 * (q3(3) * q3(3)))
+
+end subroutine weno_five_weight_2
+
+!> Reconstruction in the third upwind stencil of the fifth-order WENO scheme
+subroutine weno_five_reconstruction_0(q3, p0)
+ real, intent(in) :: q3(3) !< Tracer values on three points [A ~> a]
+ real, intent(inout) :: p0 !< Reconstruction of the quantity [A ~> a]
+ real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim]
+
+ p0 = ((2*q3(1) + 5*q3(2)) - q3(3)) * C1_6
+
+end subroutine weno_five_reconstruction_0
+
+!> Reconstruction in the second upwind stencil of the fifth-order WENO scheme
+subroutine weno_five_reconstruction_1(q3, p1)
+ real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a]
+ real, intent(inout) :: p1 !< Reconstruction of the quantity [A ~> a]
+ real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim]
+
+ p1 = ((-q3(1) + 5*q3(2)) + 2*q3(3)) * C1_6
+
+end subroutine weno_five_reconstruction_1
+
+!> Reconstruction in the first upwind stencil of the fifth-order WENO scheme
+subroutine weno_five_reconstruction_2(q3, p2)
+ real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a]
+ real, intent(inout) :: p2 !< Reconstruction of the quantity [A ~> a]
+ real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim]
+
+ p2 = ((2*q3(1) - 7*q3(2)) + 11*q3(3)) * C1_6
+
+end subroutine weno_five_reconstruction_2
+
+
+!> Reconstruct the tracer (e.g., PV, vorticity) onto point i-1/2 using a seventh-order WENO scheme
+!! This reconstruction computes a thickness weighted average of PV
+subroutine weno_seven_h_weight_reconstruction(q8, h8, u8, &
+ h_tiny, u, qr, velocity_smoothing)
+ real, intent(in) :: q8(8)
+ !< Tracer values on points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3
+ real, intent(in) :: h8(8)
+ !< Thickness on the same tracer points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3 [L ~> m]
+ real, optional, intent(in) :: u8(8)
+ !< Velocity values on points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3 [L T-1 ~> m s-1]
+ real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m]
+ real, intent(in) :: u !< Velocity or thickness flux on point i-1/2
+ !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1]
+ logical, intent(in) :: velocity_smoothing !< If true, use velocity to compute the smoothness indicator
+ real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a]
+ real :: vr ! Reconstruction of hq [A ~> a]
+ real :: hr ! Reconstruction of h [L ~> m]
+ real :: c0, c1, c2, c3 ! Intermediate reconstruction of hq [A ~> a]
+ real :: d0, d1, d2, d3 ! Intermediate reconstruction of h [L ~> m]
+ real :: b0, b1, b2, b3 ! Smoothness indicator [A ~> a]
+ real :: tau ! Difference of smoothness indicators [A ~> a]
+ real :: w0, w1, w2, w3 ! Weights [nondim]
+ real :: s ! Temporary variables [nondim]
+ real, parameter :: C4_35 = 4.0/35.0 ! The ratio of 4/35 [nondim]
+ real, parameter :: C18_35 = 18.0/35.0 ! The ratio of 18/35 [nondim]
+ real, parameter :: C12_35 = 12.0/35.0 ! The ratio of 12/35 [nondim]
+ real, parameter :: C1_35 = 1.0/35.0 ! The ratio of 1/35 [nondim]
+
+ if (u>0.) then
+ call weno_seven_reconstruction_0(q8(4:7), c0) ! Reconstruction in the fourth upwind stencil
+ call weno_seven_reconstruction_1(q8(3:6), c1) ! Reconstruction in the third upwind stencil
+ call weno_seven_reconstruction_2(q8(2:5), c2) ! Reconstruction in the second upwind stencil
+ call weno_seven_reconstruction_3(q8(1:4), c3) ! Reconstruction in the first upwind stencil
+
+ call weno_seven_reconstruction_0(h8(4:7), d0) ! Reconstruction in the fourth upwind stencil
+ call weno_seven_reconstruction_1(h8(3:6), d1) ! Reconstruction in the third upwind stencil
+ call weno_seven_reconstruction_2(h8(2:5), d2) ! Reconstruction in the second upwind stencil
+ call weno_seven_reconstruction_3(h8(1:4), d3) ! Reconstruction in the first upwind stencil
+ if (velocity_smoothing) then
+ call weno_seven_weight_0(u8(4:7), b0) ! Smoothness indicator of the fourth upwind stencil
+ call weno_seven_weight_1(u8(3:6), b1) ! Smoothness indicator of the third upwind stencil
+ call weno_seven_weight_2(u8(2:5), b2) ! Smoothness indicator of the second upwind stencil
+ call weno_seven_weight_3(u8(1:4), b3) ! Smoothness indicator of the first upwind stencil
+ else
+ call weno_seven_weight_0(q8(4:7), b0)
+ call weno_seven_weight_1(q8(3:6), b1)
+ call weno_seven_weight_2(q8(2:5), b2)
+ call weno_seven_weight_3(q8(1:4), b3)
+ endif
+ else
+ call weno_seven_reconstruction_0(q8(5:2:-1), c0) ! Reconstruction in the fourth upwind stencil
+ call weno_seven_reconstruction_1(q8(6:3:-1), c1) ! Reconstruction in the third upwind stencil
+ call weno_seven_reconstruction_2(q8(7:4:-1), c2) ! Reconstruction in the second upwind stencil
+ call weno_seven_reconstruction_3(q8(8:5:-1), c3) ! Reconstruction in the first upwind stencil
+
+ call weno_seven_reconstruction_0(h8(5:2:-1), d0)
+ call weno_seven_reconstruction_1(h8(6:3:-1), d1)
+ call weno_seven_reconstruction_2(h8(7:4:-1), d2)
+ call weno_seven_reconstruction_3(h8(8:5:-1), d3)
+ if (velocity_smoothing) then
+ call weno_seven_weight_0(u8(5:2:-1), b0) ! Smoothness indicator of the fourth upwind stencil
+ call weno_seven_weight_1(u8(6:3:-1), b1) ! Smoothness indicator of the third upwind stencil
+ call weno_seven_weight_2(u8(7:4:-1), b2) ! Smoothness indicator of the second upwind stencil
+ call weno_seven_weight_3(u8(8:5:-1), b3) ! Smoothness indicator of the first upwind stencil
+ else
+ call weno_seven_weight_0(q8(5:2:-1), b0)
+ call weno_seven_weight_1(q8(6:3:-1), b1)
+ call weno_seven_weight_2(q8(7:4:-1), b2)
+ call weno_seven_weight_3(q8(8:5:-1), b3)
+ endif
endif
-end subroutine gradKE
+ tau = abs((b0 - b3) + 3 * (b1 - b2))
+ w0 = C4_35 * fac_fn(tau, b0)
+ w1 = C18_35 * fac_fn(tau, b1)
+ w2 = C12_35 * fac_fn(tau, b2)
+ w3 = C1_35 * fac_fn(tau, b3)
+
+ s = 1. / ((w0 + w1) + (w2 + w3))
+ w0 = w0 * s ! Weights of the stencils
+ w1 = w1 * s
+ w2 = w2 * s
+ w3 = w3 * s
+
+ vr = ((w0 * c0) + (w1 * c1)) + ((w2 * c2) + (w3 * c3))
+ hr = ((w0 * d0) + (w1 * d1)) + ((w2 * d2) + (w3 * d3))
+
+! vr = min(max(q4, q5), vr) ; vr = max(min(q4, q5), vr)
+ hr = min(max(h8(4), h8(5)), hr) ; hr = max(min(h8(4), h8(5)), hr) ! Impose a monotonicity limiter
+
+ qr = vr / max(hr, h_tiny)
+
+end subroutine weno_seven_h_weight_reconstruction
+
+!> Compute the smoothness indicator for the fourth upwind stencil of the seventh-order WENO scheme
+subroutine weno_seven_weight_0(q4, w0)
+ real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a]
+ real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2]
+
+ ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn
+ w0 = ((q4(1) * ((2.107 * q4(1) - 9.402 * q4(2)) + (7.042 * q4(3) - 1.854 * q4(4)))) + &
+ (q4(2) * ((11.003 * q4(2) - 17.246 * q4(3)) + 4.642 * q4(4)))) + &
+ ((q4(3) * (7.043 * q4(3) - 3.882 * q4(4))) + 0.547 * (q4(4) * q4(4)))
+
+end subroutine weno_seven_weight_0
+
+!> Compute the smoothness indicator for the third upwind stencil of the seventh-order WENO scheme
+subroutine weno_seven_weight_1(q4, w1)
+ real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a]
+ real, intent(inout) :: w1 !< Smoothness indicator for this stencil [A2 ~> a2]
+
+ ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn
+ w1 = ((q4(1) * ((0.547 * q4(1) - 2.522 * q4(2)) + (1.922 * q4(3) - 0.494 * q4(4)))) + &
+ (q4(2) * ((3.443 * q4(2) - 5.966 * q4(3)) + 1.602 * q4(4)))) + &
+ ((q4(3) * (2.843 * q4(3) - 1.642 * q4(4))) + 0.267 * (q4(4) * q4(4)))
+
+end subroutine weno_seven_weight_1
+
+!> Compute the smoothness indicator for the second upwind stencil of the seventh-order WENO scheme
+subroutine weno_seven_weight_2(q4, w2)
+ real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a]
+ real, intent(inout) :: w2 !< Smoothness indicator for this stencil [A2 ~> a2]
+
+ ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn
+ w2 = ((q4(1) * ((0.267 * q4(1) - 1.642 * q4(2)) + (1.602 * q4(3) - 0.494 * q4(4)))) + &
+ (q4(2) * ((2.843 * q4(2) - 5.966 * q4(3)) + 1.922 * q4(4)))) + &
+ ((q4(3) * (3.443 * q4(3) - 2.522 * q4(4))) + 0.547 * (q4(4) * q4(4)))
+
+end subroutine weno_seven_weight_2
+
+!> Compute smoothness indicator for the first upwind stencil of the seventh-order WENO scheme
+subroutine weno_seven_weight_3(q4, w3)
+ real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a]
+ real, intent(inout) :: w3 !< Smoothness indicator for this stencil [A2 ~> a2]
+
+ ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn
+ w3 = ((q4(1) * ((0.547 * q4(1) - 3.882 * q4(2)) + (4.642 * q4(3) - 1.854 * q4(4)))) + &
+ (q4(2) * ((7.043 * q4(2) - 17.246 * q4(3)) + 7.042 * q4(4)))) + &
+ ((q4(3) * (11.003 * q4(3) - 9.402 * q4(4))) + 2.107 * (q4(4) * q4(4)))
+
+end subroutine weno_seven_weight_3
+
+!> Reconstruction in the fourth upwind stencil for seventh-order WENO scheme
+subroutine weno_seven_reconstruction_0(q4, p0)
+ real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a]
+ real, intent(inout) :: p0 !< Reconstruction of the quantity [A ~> a]
+ real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim]
+
+ p0 = (((6 * q4(1) + 26 * q4(2)) - 10 * q4(3)) + 2 * q4(4)) * C1_24
+
+end subroutine weno_seven_reconstruction_0
+
+!> Reconstruction in the third upwind stencil for seventh-order WENO scheme
+subroutine weno_seven_reconstruction_1(q4, p1)
+ real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a]
+ real, intent(inout) :: p1 !< Reconstruction of the quantity [A ~> a]
+ real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim]
+
+ p1 = (14 * (q4(2) + q4(3)) - 2 * (q4(1) + q4(4))) * C1_24
+
+end subroutine weno_seven_reconstruction_1
+
+!> Reconstruction in the second upwind stencil for seventh-order WENO scheme
+subroutine weno_seven_reconstruction_2(q4, p2)
+ real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a]
+ real, intent(inout) :: p2 !< Reconstruction of the quantity [A ~> a]
+ real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim]
+
+ p2 = (((2 * q4(1) - 10 * q4(2)) + 26 * q4(3)) + 6 * q4(4)) * C1_24
+
+end subroutine weno_seven_reconstruction_2
+
+!> Reconstruction in the first upwind stencil for seventh-order WENO scheme
+subroutine weno_seven_reconstruction_3(q4, p3)
+ real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a]
+ real, intent(inout) :: p3 !< Reconstruction of the quantity [A ~> a]
+ real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim]
+
+ p3 = (((-6 * q4(1) + 26 * q4(2)) - 46 * q4(3)) + 50 * q4(4)) * C1_24
+
+end subroutine weno_seven_reconstruction_3
+
+function CoriolisAdv_stencil(CS) result(stencil)
+ type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv
+ integer :: stencil !< The halo stencil size for the Coriolis advection scheme
+
+ stencil = 2
+ if (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) stencil = 4
+ if (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) stencil = 3
+
+end function CoriolisAdv_stencil
+
!> Initializes the control structure for MOM_CoriolisAdv
subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS)
@@ -1066,6 +2010,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS)
character(len=40) :: mdl = "MOM_CoriolisAdv" ! This module's name.
character(len=20) :: tmpstr
character(len=400) :: mesg
+ logical :: use_weno
integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke
@@ -1100,7 +2045,10 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS)
"\t SADOURNY75_ENSTRO - Sadourny, 1975; enstrophy cons. \n"//&
"\t ARAKAWA_LAMB81 - Arakawa & Lamb, 1981; En. + Enst.\n"//&
"\t ARAKAWA_LAMB_BLEND - A blend of Arakawa & Lamb with \n"//&
- "\t Arakawa & Hsu and Sadourny energy", &
+ "\t Arakawa & Hsu and Sadourny energy \n"//&
+ "\t WENOVI5TH_PV_ENSTRO - 5th-order WENO PV enstrophy \n"//&
+ "\t WENOVI3RD_PV_ENSTRO - 3rd-order WENO PV enstrophy \n"//&
+ "\t WENOVI7TH_PV_ENSTRO - 7th-order WENO PV enstrophy \n", &
default=SADOURNY75_ENERGY_STRING)
tmpstr = uppercase(tmpstr)
select case (tmpstr)
@@ -1117,11 +2065,28 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS)
case (ROBUST_ENSTRO_STRING)
CS%Coriolis_Scheme = ROBUST_ENSTRO
CS%Coriolis_En_Dis = .false.
+ case (WENOVI7TH_PV_ENSTRO_STRING)
+ CS%Coriolis_Scheme = wenovi7th_PV_ENSTRO
+ case (WENOVI5TH_PV_ENSTRO_STRING)
+ CS%Coriolis_Scheme = wenovi5th_PV_ENSTRO
+ case (WENOVI3RD_PV_ENSTRO_STRING)
+ CS%Coriolis_Scheme = wenovi3rd_PV_ENSTRO
case default
call MOM_mesg('CoriolisAdv_init: Coriolis_Scheme ="'//trim(tmpstr)//'"', 0)
call MOM_error(FATAL, "CoriolisAdv_init: Unrecognized setting "// &
"#define CORIOLIS_SCHEME "//trim(tmpstr)//" found in input file.")
end select
+
+ use_weno = CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO &
+ .or. CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO &
+ .or. CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO
+
+ if (use_weno) then
+ call get_param(param_file, mdl, "WENO_VELOCITY_SMOOTH", CS%weno_velocity_smooth, &
+ "If true, use velocity to compute weighting for WENO. ", &
+ default=.false.)
+ endif
+
if (CS%Coriolis_Scheme == AL_BLEND) then
call get_param(param_file, mdl, "CORIOLIS_BLEND_WT_LIN", CS%wt_lin_blend, &
"A weighting value for the ratio of inverse thicknesses, "//&
@@ -1162,19 +2127,26 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS)
call get_param(param_file, mdl, "KE_SCHEME", tmpstr, &
"KE_SCHEME selects the discretization for acceleration "//&
"due to the kinetic energy gradient. Valid values are: \n"//&
- "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV", &
+ "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV, KE_UP3", &
default=KE_ARAKAWA_STRING)
tmpstr = uppercase(tmpstr)
select case (tmpstr)
case (KE_ARAKAWA_STRING); CS%KE_Scheme = KE_ARAKAWA
case (KE_SIMPLE_GUDONOV_STRING); CS%KE_Scheme = KE_SIMPLE_GUDONOV
case (KE_GUDONOV_STRING); CS%KE_Scheme = KE_GUDONOV
+ case (KE_UP3_STRING); CS%KE_Scheme = KE_UP3
case default
call MOM_mesg('CoriolisAdv_init: KE_Scheme ="'//trim(tmpstr)//'"', 0)
call MOM_error(FATAL, "CoriolisAdv_init: "// &
"#define KE_SCHEME "//trim(tmpstr)//" in input file is invalid.")
end select
+ if (CS%KE_Scheme == KE_UP3) then
+ call get_param(param_file, mdl, "KE_USE_LIMITER", CS%KE_use_limiter, &
+ "If true, use Koren limiter for KE_UP3 scheme", &
+ default=.True.)
+ endif
+
! Set PV_Adv_Scheme (selects discretization of PV advection)
call get_param(param_file, mdl, "PV_ADV_SCHEME", tmpstr, &
"PV_ADV_SCHEME selects the discretization for PV "//&
diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90
index 191ee439c9..4aa8b436a3 100644
--- a/src/core/MOM_PressureForce.F90
+++ b/src/core/MOM_PressureForce.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A thin wrapper for Boussinesq/non-Boussinesq forms of the pressure force calculation.
module MOM_PressureForce
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl, time_type
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
@@ -106,12 +108,14 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL_CS
"described in Adcroft et al., O. Mod. (2008).", default=.true.)
if (CS%Analytic_FV_PGF) then
+ !$omp target enter data map(alloc: CS%PressureForce_FV)
call PressureForce_FV_init(Time, G, GV, US, param_file, diag, &
CS%PressureForce_FV, ADp, SAL_CSp, tides_CSp)
else
call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, &
CS%PressureForce_Mont, SAL_CSp, tides_CSp)
endif
+ !$omp target update to(CS)
end subroutine PressureForce_init
!> \namespace mom_pressureforce
diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90
index aaabab3500..1dcb872597 100644
--- a/src/core/MOM_PressureForce_FV.F90
+++ b/src/core/MOM_PressureForce_FV.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Finite volume pressure gradient (integrated by quadrature or analytically)
module MOM_PressureForce_FV
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum, uvchksum
use MOM_diag_mediator, only : post_data, register_diag_field
use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type
@@ -22,7 +24,7 @@ module MOM_PressureForce_FV
use MOM_density_integrals, only : int_spec_vol_dp_generic_plm
use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm
use MOM_density_integrals, only : diagnose_mass_weight_Z, diagnose_mass_weight_p
-use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS
+use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, TS_PLM_WLS_edge_values, ALE_CS
implicit none ; private
@@ -184,8 +186,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, AD
inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2].
real, dimension(SZI_(G),SZJ_(G)) :: &
T_top, & ! Temperature of top layer used with correction_intxpa [C ~> degC]
- S_top, & ! Salinity of top layer used with correction_intxpa [S ~> ppt]
- SpV_top ! Specific volume anomaly of top layer used with correction_intxpa [R-1 ~> m3 kg-1]
+ S_top ! Salinity of top layer used with correction_intxpa [S ~> ppt]
real, dimension(SZIB_(G),SZJ_(G)) :: &
intx_za_cor ! Correction for curvature in intx_za [L2 T-2 ~> m2 s-2]
real, dimension(SZI_(G),SZJB_(G)) :: &
@@ -197,8 +198,6 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, AD
T_int_W, T_int_E, & ! Temperatures on the reference interface to the east and west of a u-point [C ~> degC]
S_int_W, S_int_E, & ! Salinities on the reference interface to the east and west of a u-point [S ~> ppt]
p_int_W, p_int_E, & ! Pressures on the reference interface to the east and west of a u-point [R L2 T-2 ~> Pa]
- SpV_x_W, SpV_x_E, & ! Specific volume anomalies on the reference interface to the east and west
- ! of a u-point [R-1 ~> m3 kg-1]
intx_za_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface
! from the value that would be obtained from assuming that pressure varies
! linearly with depth along that interface [R L2 T-2 ~> Pa].
@@ -208,8 +207,6 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, AD
T_int_S, T_int_N, & ! Temperatures on the reference interface to the north and south of a v-point [C ~> degC]
S_int_S, S_int_N, & ! Salinities on the reference interface to the north and south of a v-point [S ~> ppt]
p_int_S, p_int_N, & ! Pressures on the reference interface to the north and south of a v-point [R L2 T-2 ~> Pa]
- SpV_y_S, SpV_y_N, & ! Specific volume anomalies on the reference interface to the north and south
- ! of a v-point [R L2 T-2 ~> Pa]
inty_za_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface
! from the value that would be obtained from assuming that pressure varies
! linearly with depth along that interface [L2 T-2 ~> m2 s-2].
@@ -280,7 +277,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, AD
"MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.")
if (CS%use_stanley_pgf) call MOM_error(FATAL, &
- "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet"//&
+ "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet "//&
"implemented in non-Boussinesq mode.")
use_p_atm = associated(p_atm)
@@ -353,6 +350,8 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, AD
call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap)
elseif ( use_ALE .and. (CS%Recon_Scheme == 2) ) then
call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap)
+ elseif ( use_ALE .and. (CS%Recon_Scheme == 3) ) then
+ call TS_PLM_WLS_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h)
elseif (CS%reset_intxpa_integral) then
do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
T_b(i,j,k) = tv%T(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k)
@@ -365,7 +364,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, AD
! subsequent calculation.
if (use_EOS) then
if ( use_ALE .and. CS%Recon_Scheme > 0 ) then
- if ( CS%Recon_Scheme == 1 ) then
+ if ( CS%Recon_Scheme == 1 .or. CS%Recon_Scheme == 3 ) then
call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k), &
p(:,:,K), p(:,:,K+1), alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, &
tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), &
@@ -436,8 +435,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, AD
else
!$OMP parallel do default(shared)
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- SSH(i,j) = (za(i,j,1) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref &
- - max(-G%bathyT(i,j)-G%Z_ref, 0.0)
+ SSH(i,j) = (za(i,j,1) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref
+ ! Remove above sea level topography at floodable cells
+ SSH(i,j) = SSH(i,j) - max(-G%bathyT(i,j)-G%meanSL(i,j), 0.0)
enddo ; enddo
call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m)
endif
@@ -653,7 +653,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, AD
endif
enddo
seek_x_cor(I,j) = .false.
- endif; enddo; enddo;
+ endif ; enddo ; enddo
else
! There are still points where a correction is needed, so use the top interface.
do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then
@@ -1013,8 +1013,6 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
T_int_W, T_int_E, & ! Temperatures on the reference interface to the east and west of a u-point [C ~> degC]
S_int_W, S_int_E, & ! Salinities on the reference interface to the east and west of a u-point [S ~> ppt]
p_int_W, p_int_E, & ! Pressures on the reference interface to the east and west of a u-point [R L2 T-2 ~> Pa]
- rho_x_W, rho_x_E, & ! Density anomalies on the reference interface to the east and west
- ! of a u-point [R ~> kg m-3]
intx_pa_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface
! from the value that would be obtained from assuming that pressure varies
! linearly with depth along that interface [R L2 T-2 ~> Pa].
@@ -1024,8 +1022,6 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
T_int_S, T_int_N, & ! Temperatures on the reference interface to the north and south of a v-point [C ~> degC]
S_int_S, S_int_N, & ! Salinities on the reference interface to the north and south of a v-point [S ~> ppt]
p_int_S, p_int_N, & ! Pressures on the reference interface to the north and south of a v-point [R L2 T-2 ~> Pa]
- rho_y_S, rho_y_N, & ! Density anomalies on the reference interface to the north and south
- ! of a v-point [R ~> kg m-3]
inty_pa_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface
! from the value that would be obtained from assuming that pressure varies
! linearly with depth along that interface [R L2 T-2 ~> Pa].
@@ -1066,12 +1062,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: &
p_stanley ! Pressure [R L2 T-2 ~> Pa] estimated with Rho_0
real :: zeros(SZI_(G)) ! An array of zero values that can be used as an argument [various]
- real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3].
+ real :: rho_in_situ(SZI_(G),SZJ_(G)) ! The in situ density [R ~> kg m-3].
real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate
! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar).
real :: p_surf_EOS(SZI_(G)) ! The pressure at the ocean surface determined from the surface height,
! consistent with what is used in the density integral routines [R L2 T-2 ~> Pa]
- real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa].
+ real :: p0(SZI_(G), SZJ_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa].
real :: dz_geo_sfc ! The change in surface geopotential height between adjacent cells [L2 T-2 ~> m2 s-2]
real :: GxRho0 ! The gravitational acceleration times mean ocean density [R L2 Z-1 T-2 ~> Pa m-1]
real :: GxRho_ref ! The gravitational acceleration times reference density [R L2 Z-1 T-2 ~> Pa m-1]
@@ -1104,8 +1100,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points
integer, dimension(2) :: EOSdom_u ! The i-computational domain for the equation of state at u-velocity points
integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points
+ integer :: EOSdom2d(2,2) ! The 2D compute domain for the equation of state
integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb
- integer :: i, j, k, m, k2
+ integer :: i, j, k, m
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
nkmb=GV%nk_rho_varies
@@ -1114,12 +1111,16 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
EOSdom_u(1) = Isq - (G%IsdB-1) ; EOSdom_u(2) = Ieq - (G%IsdB-1)
EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1)
+ EOSdom2d(1,:) = EOSdom(:)
+ EOSdom2d(2,:) = [Jsq - (G%isd - 1), (je + 1) - (G%jsd - 1)]
+
+ ! TODO: This would be done outside of the function!
+
if (.not.CS%initialized) call MOM_error(FATAL, &
"MOM_PressureForce_FV_Bouss: Module must be initialized before it is used.")
use_p_atm = associated(p_atm)
use_EOS = associated(tv%eqn_of_state)
- do i=Isq,Ieq+1 ; p0(i) = 0.0 ; enddo
use_ALE = .false.
if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS
@@ -1147,9 +1148,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
MassWt_u(:,:,:) = 0.0 ; MassWt_v(:,:,:) = 0.0
endif
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ !$omp target enter data map(alloc: e)
+
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
e(i,j,nz+1) = -G%bathyT(i,j)
- enddo ; enddo
+ enddo
! The following two if-blocks are used to recover old answers for self-attraction and loading
! (SAL) and tides only. The old algorithm moves interface heights before density calculations,
@@ -1158,10 +1161,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
! Calculate and add SAL geopotential anomaly to interface height (old answers)
if (CS%calculate_SAL .and. CS%tides_answer_date<=20250131) then
+ !$omp target update from(e(:,:,nz+1))
+
!$OMP parallel do default(shared)
do j=Jsq,Jeq+1
do i=Isq,Ieq+1
- SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0)
+ SSH(i,j) = min(-G%bathyT(i,j) - G%meanSL(i,j), 0.0)
enddo
do k=1,nz ; do i=Isq,Ieq+1
SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z
@@ -1175,10 +1180,14 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j)
enddo ; enddo
endif
+
+ !$omp target update to(e(:,:,nz+1))
endif
! Calculate and add tidal geopotential anomaly to interface height (old answers)
if (CS%tides .and. CS%tides_answer_date<=20250131) then
+ !$omp target update from(e(:,:,nz+1))
+
if (CS%tides_answer_date>20230630) then ! answers_date between [20230701, 20250131]
call calc_tidal_forcing(CS%Time, e_tidal_eq, e_tidal_sal, G, US, CS%tides_CSp)
!$OMP parallel do default(shared)
@@ -1194,12 +1203,15 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
e(i,j,nz+1) = e(i,j,nz+1) - e_sal_and_tide(i,j)
enddo ; enddo
endif
+
+ !$omp target update to(e(:,:,nz+1))
endif
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1
- e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z
- enddo ; enddo ; enddo
+ do k=nz,1,-1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z
+ enddo
+ enddo
if (use_EOS) then
if (nkmb>0) then
@@ -1240,52 +1252,66 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap)
elseif ( use_ALE .and. (CS%Recon_Scheme == 2) ) then
call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap)
+ elseif ( use_ALE .and. (CS%Recon_Scheme == 3) ) then
+ call TS_PLM_WLS_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h)
elseif (CS%reset_intxpa_integral) then
do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
T_b(i,j,k) = tv%T(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k)
enddo ; enddo ; enddo
endif
+ !$omp target enter data map(alloc: pa)
+
! Set the surface boundary conditions on pressure anomaly and its horizontal
! integrals, assuming that the surface pressure anomaly varies linearly
! in x and y.
if (use_p_atm) then
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
pa(i,j,1) = GxRho_ref * (e(i,j,1) - G%Z_ref) + p_atm(i,j)
- enddo ; enddo
+ enddo
else
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
pa(i,j,1) = GxRho_ref * (e(i,j,1) - G%Z_ref)
- enddo ; enddo
+ enddo
endif
- if (CS%use_SSH_in_Z0p .and. use_p_atm) then
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- Z_0p(i,j) = e(i,j,1) + p_atm(i,j) * I_g_rho
- enddo ; enddo
- elseif (CS%use_SSH_in_Z0p) then
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- Z_0p(i,j) = e(i,j,1)
- enddo ; enddo
- else
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- Z_0p(i,j) = G%Z_ref
- enddo ; enddo
+ if (use_EOS) then
+ !$omp target enter data map(alloc: Z_0p)
+ if (CS%use_SSH_in_Z0p .and. use_p_atm) then
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ Z_0p(i,j) = e(i,j,1) + p_atm(i,j) * I_g_rho
+ enddo
+ elseif (CS%use_SSH_in_Z0p) then
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ Z_0p(i,j) = e(i,j,1)
+ enddo
+ else
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ Z_0p(i,j) = G%meanSL(i,j)
+ enddo
+ endif
+ !$omp target update from(Z_0p)
endif
- do k=1,nz
- ! Calculate 4 integrals through the layer that are required in the
- ! subsequent calculation.
- if (use_EOS) then
- ! The following routine computes the integrals that are needed to
- ! calculate the pressure gradient force. Linear profiles for T and S are
- ! assumed when regridding is activated. Otherwise, the previous version
- ! is used, whereby densities within each layer are constant no matter
- ! where the layers are located.
+ ! Calculate 4 integrals through the layer that are required in the
+ ! subsequent calculation.
+ !$omp target enter data map(alloc: dpa, intx_dpa, inty_dpa, intz_dpa)
+
+ if (use_EOS) then
+ !$omp target update from(e) if( (use_ALE .and. CS%Recon_Scheme > 0) .or. &
+ !$omp (CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0))
+ ! transfer tv_tmp%* only if int_density_dz is called
+ !$omp target enter data map(to: tv_tmp, tv_tmp%T, tv_tmp%S) &
+ !$omp if(.not.(use_ALE .and. CS%Recon_Scheme > 0))
+
+ ! The following routine computes the integrals that are needed to
+ ! calculate the pressure gradient force. Linear profiles for T and S are
+ ! assumed when regridding is activated. Otherwise, the previous version
+ ! is used, whereby densities within each layer are constant no matter
+ ! where the layers are located.
+ do k=1,nz
if ( use_ALE .and. CS%Recon_Scheme > 0 ) then
- if ( CS%Recon_Scheme == 1 ) then
+ if ( CS%Recon_Scheme == 1 .or. CS%Recon_Scheme == 3 ) then
call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, &
rho_ref, rho0_int_density, GV%g_Earth, dz_neglect, G%bathyT, &
G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), &
@@ -1301,6 +1327,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
MassWghtInterp=CS%MassWghtInterp, Z_0p=Z_0p, &
MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, h_nv=dz_nonvanished)
endif
+ ! defensive update - not sure if it works
+ !$omp target update to(dpa, intx_dpa, inty_dpa, intz_dpa)
else
call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), &
rho_ref, rho0_int_density, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), &
@@ -1309,39 +1337,42 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, h_nv=dz_nonvanished)
endif
if (GV%Z_to_H /= 1.0) then
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
intz_dpa(i,j,k) = intz_dpa(i,j,k)*GV%Z_to_H
- enddo ; enddo
+ enddo
endif
if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) &
call diagnose_mass_weight_Z(e(:,:,K), e(:,:,K+1), G%bathyT, e(:,:,1), dz_neglect, CS%MassWghtInterp, &
G%HI, MassWt_u(:,:,k), MassWt_v(:,:,k), &
MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, h_nv=CS%h_nonvanished)
- else
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ enddo
+ !$omp target exit data map(release: tv_tmp, tv_tmp%T, tv_tmp%S) &
+ !$omp if(.not.(use_ALE .and. CS%Recon_Scheme > 0))
+ else
+ !$omp target data map(alloc: dz_geo)
+ do k=1,nz
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
dz_geo(i,j) = GV%g_Earth * GV%H_to_Z*h(i,j,k)
dpa(i,j,k) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j)
intz_dpa(i,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k)
- enddo ; enddo
- !$OMP parallel do default(shared)
- do j=js,je ; do I=Isq,Ieq
+ enddo
+ do concurrent (j=js:je, I=Isq:Ieq)
intx_dpa(I,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j))
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=Jsq,Jeq ; do i=is,ie
+ enddo
+ do concurrent (J=Jsq:Jeq, i=is:ie)
inty_dpa(i,J,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1))
- enddo ; enddo
- endif
- enddo
+ enddo
+ enddo
+ !$omp end target data
+ endif
! Set the pressure anomalies at the interfaces.
- do k=1,nz
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- pa(i,j,K+1) = pa(i,j,K) + dpa(i,j,k)
- enddo ; enddo
+ do concurrent (j=Jsq:Jeq+1)
+ do k=1,nz
+ do concurrent (i=Isq:Ieq+1)
+ pa(i,j,K+1) = pa(i,j,K) + dpa(i,j,k)
+ enddo
+ enddo
enddo
! Calculate and add SAL geopotential anomaly to interface height (new answers)
@@ -1355,7 +1386,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
else
!$OMP parallel do default(shared)
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- SSH(i,j) = e(i,j,1) - max(-G%bathyT(i,j) - G%Z_ref, 0.0) ! Remove topography above sea level
+ SSH(i,j) = e(i,j,1) - G%Z_ref
+ ! Remove above sea level topography at floodable cells
+ SSH(i,j) = SSH(i,j) - max(-G%bathyT(i,j)-G%meanSL(i,j), 0.0)
enddo ; enddo
call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m)
endif
@@ -1393,7 +1426,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
endif
endif
+ !$omp target enter data map(alloc: intx_pa, inty_pa)
+
if (CS%correction_intxpa) then
+ ! TODO needs to be moved to GPU
+
! Determine surface density for use in the pressure gradient corrections
!$OMP parallel do default(shared) private(p_surf_EOS)
do j=Jsq,Jeq+1
@@ -1529,38 +1566,39 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%RL2_T2_to_Pa)
endif
+ ! TODO until moved to GPU
+ !$omp target update to(intx_pa, inty_pa)
else
! Set the surface boundary conditions on the horizontally integrated pressure anomaly,
! assuming that the surface pressure anomaly varies linearly in x and y.
! If there is an ice-shelf or icebergs, this linear variation would need to be applied
! to an interior interface.
- !$OMP parallel do default(shared)
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1))
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=Jsq,Jeq ; do i=is,ie
+ enddo
+ do concurrent (J=Jsq:Jeq, i=is:ie)
inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1))
- enddo ; enddo
+ enddo
endif
do k=1,nz
- !$OMP parallel do default(shared)
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
intx_pa(I,j,K+1) = intx_pa(I,j,K) + intx_dpa(I,j,k)
- enddo ; enddo
+ enddo
enddo
do k=1,nz
- !$OMP parallel do default(shared)
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
inty_pa(i,J,K+1) = inty_pa(i,J,K) + inty_dpa(i,J,k)
- enddo ; enddo
+ enddo
enddo
if (CS%reset_intxpa_integral) then
! Having stored the pressure gradient info, we can work out where the first nonvanished layers is
! reset intxpa there, then adjust intxpa throughout the water column.
+ ! TODO temporarily move back to CPU
+ !$omp target update from(intx_pa, inty_pa)
+
! Zero out the 2-d arrays that will be set from various reference interfaces.
T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0
T_int_E(:,:) = 0.0 ; S_int_E(:,:) = 0.0 ; p_int_E(:,:) = 0.0
@@ -1788,124 +1826,163 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp,
do K=1,nz+1 ; do J=Jsq,Jeq ; do i=is,ie
inty_pa(i,J,K) = inty_pa(i,J,K) + inty_pa_cor_ri(i,J)
enddo ; enddo ; enddo
+
+ ! TODO temporarily move back to CPU
+ !$omp target update to(intx_pa, inty_pa)
endif ! intx_pa and inty_pa have now been reset to reflect the properties of an unimpeded interface.
- ! Compute pressure gradient in x direction
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=js,je ; do I=Isq,Ieq
+ ! NOTE: None of these `enter data` statements should be here. They are only
+ ! temporarily being used to set up the data regions below.
+ ! Eventually, they should be set up *outside* of the function.
+
+ !$omp target enter data if(use_EOS) &
+ !$omp map(to: tv_tmp, tv_tmp%T, tv_tmp%S, tv, EOSdom2d)
+
+ ! NOTE: e_sal condition could be sharpened, but this is close enough.
+ !$omp target enter data map(to: e_tidal_eq, e_tidal_sal, e_sal_and_tide) if (CS%tides)
+ !$omp target enter data map(to: e_sal) if (CS%calculate_SAL)
+
+ !$omp target data map(to: h)
+
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
PFu(I,j,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - &
(pa(i+1,j,K)*h(i+1,j,k) + intz_dpa(i+1,j,k))) + &
((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j,K) - &
(e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j,k) * GV%Z_to_H)) * &
((2.0*I_Rho0*G%IdxCu(I,j)) / &
((h(i,j,k) + h(i+1,j,k)) + h_neglect))
- enddo ; enddo ; enddo
+ enddo
! Compute pressure gradient in y direction
- !$OMP parallel do default(shared)
- do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie)
PFv(i,J,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - &
(pa(i,j+1,K)*h(i,j+1,k) + intz_dpa(i,j+1,k))) + &
((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J,K) - &
(e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J,k) * GV%Z_to_H)) * &
((2.0*I_Rho0*G%IdyCv(i,J)) / &
((h(i,j,k) + h(i,j+1,k)) + h_neglect))
- enddo ; enddo ; enddo
+ enddo
- ! Calculate SAL geopotential anomaly and add its gradient to pressure gradient force
- if (CS%calculate_SAL .and. CS%tides_answer_date>20230630 .and. CS%bq_sal_tides) then
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js,je ; do I=Isq,Ieq
- PFu(I,j,k) = PFu(I,j,k) + (e_sal(i+1,j) - e_sal(i,j)) * GV%g_Earth * G%IdxCu(I,j)
- enddo ; enddo
- do J=Jsq,Jeq ; do i=is,ie
- PFv(i,J,k) = PFv(i,J,k) + (e_sal(i,j+1) - e_sal(i,j)) * GV%g_Earth * G%IdyCv(i,J)
- enddo ; enddo
- enddo
- endif
+ !$omp end target data
- ! Calculate tidal geopotential anomaly and add its gradient to pressure gradient force
- if (CS%tides .and. CS%tides_answer_date>20230630 .and. CS%bq_sal_tides) then
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js,je ; do I=Isq,Ieq
- PFu(I,j,k) = PFu(I,j,k) + ((e_tidal_eq(i+1,j) + e_tidal_sal(i+1,j)) &
- - (e_tidal_eq(i,j) + e_tidal_sal(i,j))) * GV%g_Earth * G%IdxCu(I,j)
- enddo ; enddo
- do J=Jsq,Jeq ; do i=is,ie
- PFv(i,J,k) = PFv(i,J,k) + ((e_tidal_eq(i,j+1) + e_tidal_sal(i,j+1)) &
- - (e_tidal_eq(i,j) + e_tidal_sal(i,j))) * GV%g_Earth * G%IdyCv(i,J)
- enddo ; enddo
- enddo
+ if (CS%tides_answer_date>20230630 .and. CS%bq_sal_tides) then
+ ! Calculate SAL geopotential anomaly and add its gradient to pressure
+ ! gradient force
+ if (CS%calculate_SAL) then
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
+ PFu(I,j,k) = PFu(I,j,k) + (e_sal(i+1,j) - e_sal(i,j)) * GV%g_Earth * G%IdxCu(I,j)
+ enddo
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie)
+ PFv(i,J,k) = PFv(i,J,k) + (e_sal(i,j+1) - e_sal(i,j)) * GV%g_Earth * G%IdyCv(i,J)
+ enddo
+ endif
+
+ ! Calculate tidal geopotential anomaly and add its gradient to pressure
+ ! gradient force
+ if (CS%tides) then
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
+ PFu(I,j,k) = PFu(I,j,k) + ((e_tidal_eq(i+1,j) + e_tidal_sal(i+1,j)) &
+ - (e_tidal_eq(i,j) + e_tidal_sal(i,j))) * GV%g_Earth * G%IdxCu(I,j)
+ enddo
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie)
+ PFv(i,J,k) = PFv(i,J,k) + ((e_tidal_eq(i,j+1) + e_tidal_sal(i,j+1)) &
+ - (e_tidal_eq(i,j) + e_tidal_sal(i,j))) * GV%g_Earth * G%IdyCv(i,J)
+ enddo
+ endif
endif
if (CS%GFS_scale < 1.0) then
! Adjust the Montgomery potential to make this a reduced gravity model.
+ !$omp target data map(alloc: dM)
+
if (use_EOS) then
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1
- if (use_p_atm) then
- call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, &
- tv%eqn_of_state, EOSdom)
- else
- call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, &
- tv%eqn_of_state, EOSdom)
- endif
- do i=Isq,Ieq+1
- dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref)
- enddo
- enddo
- else
- !$OMP parallel do default(shared)
+ !$omp target data map(alloc: rho_in_situ)
+
+ if (use_p_atm) then
+ call calculate_density(tv_tmp%T(:,:,1), tv_tmp%S(:,:,1), p_atm, rho_in_situ, &
+ tv%eqn_of_state, EOSdom2d)
+ else
+ !$omp target data map(alloc: p0)
+
+ !$omp target
+ !$omp parallel loop collapse(2)
+ do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ p0(i,j) = 0.
+ enddo ; enddo
+ !$omp end target
+
+ call calculate_density(tv_tmp%T(:,:,1), tv_tmp%S(:,:,1), p0, rho_in_situ, &
+ tv%eqn_of_state, EOSdom2d)
+ !$omp end target data
+ endif
+
+ !$omp target
+ !$omp parallel loop collapse(2)
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref)
+ dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i,j)) * (e(i,j,1) - G%Z_ref)
enddo ; enddo
+ !$omp end target
+
+ !$omp end target data
+ else
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref)
+ enddo
endif
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js,je ; do I=Isq,Ieq
- PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j)
- enddo ; enddo
- do J=Jsq,Jeq ; do i=is,ie
- PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J)
- enddo ; enddo
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
+ PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j)
enddo
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie)
+ PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J)
+ enddo
+
+ !$omp end target data
endif
if (present(pbce)) then
call set_pbce_Bouss(e, tv_tmp, G, GV, US, rho0_set_pbce, CS%GFS_scale, pbce)
endif
+ !$omp target exit data if (use_EOS) &
+ !$omp map(delete:tv_tmp, tv_tmp%T, tv_tmp%S, tv, tv%eqn_of_state, EOSdom2d)
+
+ !$omp target exit data map(delete: Z_0p) if (use_EOS)
+
+ !$omp target exit data &
+ !$omp map(delete: pa, dpa) &
+ !$omp map(delete: intx_pa, inty_pa, intx_dpa, inty_dpa, intz_dpa)
+
if (present(eta)) then
! eta is the sea surface height relative to a time-invariant geoid, for comparison with
! what is used for eta in btstep. See how e was calculated about 200 lines above.
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
eta(i,j) = e(i,j,1)*GV%Z_to_H
- enddo ; enddo
+ enddo
+
if (CS%tides .and. (.not.CS%bq_sal_tides)) then
if (CS%tides_answer_date>20230630) then
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
eta(i,j) = eta(i,j) + (e_tidal_eq(i,j)+e_tidal_sal(i,j))*GV%Z_to_H
- enddo ; enddo
+ enddo
else
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
eta(i,j) = eta(i,j) + e_sal_and_tide(i,j)*GV%Z_to_H
- enddo ; enddo
+ enddo
endif
endif
+
if (CS%calculate_SAL .and. (CS%tides_answer_date>20230630) .and. (.not.CS%bq_sal_tides)) then
- !$OMP parallel do default(shared)
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H
- enddo ; enddo
+ enddo
endif
endif
+ !$omp target exit data map(delete: e)
+ !$omp target exit data map(delete: e_tidal_eq, e_tidal_sal, e_sal_and_tide) if (CS%tides)
+ !$omp target exit data map(delete: e_sal) if (CS%calculate_SAL)
+
if (CS%use_stanley_pgf) then
! Calculated diagnostics related to the Stanley parameterization
zeros(:) = 0.0
@@ -2038,7 +2115,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL
logical :: useMassWghtInterp ! If true, use near-bottom mass weighting for T and S
logical :: MassWghtInterpTop ! If true, use near-surface mass weighting for T and S under ice shelves
logical :: MassWghtInterp_NonBous_bug ! If true, use a buggy mass weighting when non-Boussinesq
- logical :: MassWghtInterpVanOnly ! If true, turn of mass weighting unless one side is vanished
+ 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,23 +2143,28 @@ 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)
- if (CS%tides) &
+ if (CS%tides) then
+ call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
+ "This sets the default value for the various _ANSWER_DATE parameters.", &
+ default=99991231)
call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tides_answer_date, "The vintage of "//&
- "self-attraction and loading (SAL) and tidal forcing calculations. Setting "//&
- "dates before 20230701 recovers old answers (Boussinesq and non-Boussinesq "//&
- "modes) when SAL is part of the tidal forcing calculation. The answer "//&
- "difference is only at bit level and due to a reordered summation. Setting "//&
- "dates before 20250201 recovers answers (Boussinesq mode) that interface "//&
- "heights are modified before pressure force integrals are calculated.", &
- default=20230630, do_not_log=(.not.CS%tides))
+ "self-attraction and loading (SAL) and tidal forcing calculations. Setting "//&
+ "dates before 20230701 recovers old answers (Boussinesq and non-Boussinesq "//&
+ "modes) when SAL is part of the tidal forcing calculation. The answer "//&
+ "difference is only at bit level and due to a reordered summation. Setting "//&
+ "dates before 20250201 recovers answers (Boussinesq mode) that interface "//&
+ "heights are modified before pressure force integrals are calculated.", &
+ default=default_answer_date, do_not_log=(.not.CS%tides))
+ endif
call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, &
"If true, calculate self-attraction and loading.", default=CS%tides)
if (CS%calculate_SAL) &
@@ -2124,7 +2207,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL
"If true and MASS_WEIGHT_IN_PRESSURE_GRADIENT is true, use mass weighting when "//&
"interpolating T/S for integrals near the top of the water column in FV "//&
"pressure gradient calculations. ", &
- default=.false.) !### Change Default to MASS_WEIGHT_IN_PRESSURE_GRADIENT?
+ default=useMassWghtInterp)
call get_param(param_file, mdl, "MASS_WEIGHT_IN_PGF_NONBOUS_BUG", MassWghtInterp_NonBous_bug, &
"If true, use a masking bug in non-Boussinesq calculations with mass weighting "//&
"when interpolating T/S for integrals near the bathymetry in FV pressure "//&
@@ -2176,7 +2259,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL
"integrals within the FV pressure gradient calculation.\n"//&
" 0: PCM or no reconstruction.\n"//&
" 1: PLM reconstruction.\n"//&
- " 2: PPM reconstruction.", default=1)
+ " 2: PPM reconstruction.\n"//&
+ " 3: PLM with least squares slope.", default=1)
call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, &
"If true, the reconstruction of T & S for pressure in "//&
"boundary cells is extrapolated, rather than using PCM "//&
@@ -2236,6 +2320,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL
CS%GFS_scale = 1.0
if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth
+ !$omp target update to (CS)
+
call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale, units="nondim")
end subroutine PressureForce_FV_init
diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90
index 1529af9d83..ae5d6f0890 100644
--- a/src/core/MOM_PressureForce_Montgomery.F90
+++ b/src/core/MOM_PressureForce_Montgomery.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides the Montgomery potential form of pressure gradient
module MOM_PressureForce_Mont
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_density_integrals, only : int_specific_vol_dp
use MOM_diag_mediator, only : post_data, register_diag_field
use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type
@@ -197,7 +199,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb
! of self-attraction and loading.
!$OMP parallel do default(shared)
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
- SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0)
+ SSH(i,j) = min(-G%bathyT(i,j) - G%meanSL(i,j), 0.0)
enddo ; enddo
if (use_EOS) then
!$OMP parallel do default(shared)
@@ -476,7 +478,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce,
! barotropic tides.
!$OMP parallel do default(shared)
do j=Jsq,Jeq+1
- do i=Isq,Ieq+1 ; SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) ; enddo
+ do i=Isq,Ieq+1 ; SSH(i,j) = min(-G%bathyT(i,j) - G%meanSL(i,j), 0.0) ; enddo
do k=1,nz ; do i=Isq,Ieq+1
SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z
enddo ; enddo
@@ -664,87 +666,101 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star)
optional, intent(in) :: rho_star !< The layer densities (maybe compressibility
!! compensated), times g/rho_0 [L2 Z-1 T-2 ~> m s-2].
- ! Local variables
- real :: Ihtot(SZI_(G)) ! The inverse of the sum of the layer thicknesses [H-1 ~> m-1 or m2 kg-1].
- real :: press(SZI_(G)) ! Interface pressure [R L2 T-2 ~> Pa].
- real :: T_int(SZI_(G)) ! Interface temperature [C ~> degC]
- real :: S_int(SZI_(G)) ! Interface salinity [S ~> ppt]
- real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1]
- real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1].
- real :: rho_in_situ(SZI_(G)) ! In-situ density at the top of a layer [R ~> kg m-3].
+ real :: Ihtot(SZI_(G),SZJ_(G)) ! The inverse of the sum of the layer thicknesses [H-1 ~> m-1 or m2 kg-1].
+ real :: press(SZI_(G),SZJ_(G)) ! Interface pressure [R L2 T-2 ~> Pa].
+ real :: T_int(SZI_(G),SZJ_(G)) ! Interface temperature [C ~> degC]
+ real :: S_int(SZI_(G),SZJ_(G)) ! Interface salinity [S ~> ppt]
+ real :: dR_dT(SZI_(G),SZJ_(G)) ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1]
+ real :: dR_dS(SZI_(G),SZJ_(G)) ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1].
+ real :: rho_in_situ(SZI_(G),SZJ_(G)) ! In-situ density at the top of a layer [R ~> kg m-3].
real :: G_Rho0 ! A scaled version of g_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]
real :: Rho0xG ! g_Earth * Rho0 [R L2 Z-1 T-2 ~> kg s-2 m-2]
logical :: use_EOS ! If true, density is calculated from T & S using
! an equation of state.
- real :: dz_neglect ! A vertical distance that is so small it is usually lost
+ real :: dz_neglect ! A vertical distance that is so small it is usually lost
! in roundoff and can be neglected [Z ~> m].
- integer, dimension(2) :: EOSdom ! The computational domain for the equation of state
+ integer :: EOSdom(2,2) ! The computational domain for the equation of state
integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k
+ !$omp target data map(alloc: Ihtot)
+
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke
- EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1)
- Rho0xG = Rho0 * GV%g_Earth
- G_Rho0 = GV%g_Earth / GV%Rho0
use_EOS = associated(tv%eqn_of_state)
dz_neglect = GV%dZ_subroundoff
if (use_EOS) then
if (present(rho_star)) then
- !$OMP parallel do default(shared) private(Ihtot)
- do j=Jsq,Jeq+1
- do i=Isq,Ieq+1
- Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect)
+ do concurrent (j=Jsq:Jeq+1)
+ do concurrent (i=Isq:Ieq+1)
+ Ihtot(i,j) = GV%H_to_Z / ((e(i,j,1) - e(i,j,nz+1)) + dz_neglect)
pbce(i,j,1) = GFS_scale * rho_star(i,j,1) * GV%H_to_Z
enddo
- do k=2,nz ; do i=Isq,Ieq+1
- pbce(i,j,k) = pbce(i,j,k-1) + (rho_star(i,j,k)-rho_star(i,j,k-1)) * &
- ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i))
- enddo ; enddo
- enddo ! end of j loop
- else
- !$OMP parallel do default(shared) private(Ihtot,press,rho_in_situ,T_int,S_int,dR_dT,dR_dS)
- do j=Jsq,Jeq+1
- do i=Isq,Ieq+1
- Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect)
- press(i) = -Rho0xG*(e(i,j,1) - G%Z_ref)
- enddo
- call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, &
- tv%eqn_of_state, EOSdom)
- do i=Isq,Ieq+1
- pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z
- enddo
+
do k=2,nz
- do i=Isq,Ieq+1
- press(i) = -Rho0xG*(e(i,j,K) - G%Z_ref)
- T_int(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k))
- S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k))
- enddo
- call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, &
- tv%eqn_of_state, EOSdom)
- do i=Isq,Ieq+1
- pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * &
- ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * &
- (dR_dT(i)*(tv%T(i,j,k)-tv%T(i,j,k-1)) + &
- dR_dS(i)*(tv%S(i,j,k)-tv%S(i,j,k-1)))
+ do concurrent (i=Isq:Ieq+1)
+ pbce(i,j,k) = pbce(i,j,k-1) + (rho_star(i,j,k) - rho_star(i,j,k-1)) &
+ * ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i,j))
enddo
enddo
- enddo ! end of j loop
+ enddo
+ else
+ !$omp target data &
+ !$omp map(alloc: EOSdom, press, T_int, S_int, rho_in_situ) &
+ !$omp map(alloc: dR_dT, dR_dS)
+
+ Rho0xG = Rho0 * GV%g_Earth
+ G_Rho0 = GV%g_Earth / GV%Rho0
+
+ EOSdom(1,:) = [Isq - (G%isd-1), G%iec+1 - (G%isd-1)]
+ EOSdom(2,:) = [Jsq - (G%jsd-1), G%jec+1 - (G%jsd-1)]
+
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ Ihtot(i,j) = GV%H_to_Z / ((e(i,j,1) - e(i,j,nz+1)) + dz_neglect)
+ press(i,j) = -Rho0xG * (e(i,j,1) - G%meanSL(i,j))
+ enddo
+
+ call calculate_density(tv%T(:,:,1), tv%S(:,:,1), press, rho_in_situ, &
+ tv%eqn_of_state, EOSdom)
+
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ pbce(i,j,1) = G_Rho0 * (GFS_scale * rho_in_situ(i,j)) * GV%H_to_Z
+ enddo
+
+ do k=2,nz
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ press(i,j) = -Rho0xG * (e(i,j,K) - G%meanSL(i,j))
+ T_int(i,j) = 0.5 * (tv%T(i,j,k-1) + tv%T(i,j,k))
+ S_int(i,j) = 0.5 * (tv%S(i,j,k-1) + tv%S(i,j,k))
+ enddo
+
+ call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, &
+ tv%eqn_of_state, EOSdom)
+
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * &
+ ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i,j)) * &
+ (dR_dT(i,j) * (tv%T(i,j,k) - tv%T(i,j,k-1)) + &
+ dR_dS(i,j) * (tv%S(i,j,k) - tv%S(i,j,k-1)))
+ enddo
+ enddo
+ !$omp end target data
endif
- else ! not use_EOS
- !$OMP parallel do default(shared) private(Ihtot)
- do j=Jsq,Jeq+1
- do i=Isq,Ieq+1
- Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect)
+ else
+ do concurrent (j=Jsq:Jeq+1)
+ do concurrent (i=Isq:Ieq+1)
+ Ihtot(i,j) = 1.0 / ((e(i,j,1) - e(i,j,nz+1)) + dz_neglect)
pbce(i,j,1) = GV%g_prime(1) * GV%H_to_Z
enddo
- do k=2,nz ; do i=Isq,Ieq+1
- pbce(i,j,k) = pbce(i,j,k-1) + &
- (GV%g_prime(K)*GV%H_to_Z) * ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i))
- enddo ; enddo
- enddo ! end of j loop
- endif ! use_EOS
-
+ do k=2,nz
+ do concurrent (i=Isq:Ieq+1)
+ pbce(i,j,k) = pbce(i,j,k-1) + (GV%g_prime(K) * GV%H_to_Z) &
+ * ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i,j))
+ enddo
+ enddo
+ enddo
+ endif
+ !$omp end target data
end subroutine Set_pbce_Bouss
!> Determines the partial derivative of the acceleration due
@@ -890,7 +906,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, SAL_CS
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%R_to_kg_m3)
call get_param(param_file, mdl, "TIDES", CS%tides, &
diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90
index f8bc982d18..5a0b8a1502 100644
--- a/src/core/MOM_barotropic.F90
+++ b/src/core/MOM_barotropic.F90
@@ -1,11 +1,16 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+#include "do_concurrent_compat.h"
+
!> Barotropic solver
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_debugging, only : hchksum, uvchksum, Bchksum
use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field
use MOM_diag_mediator, only : diag_ctrl, enable_averaging, enable_averages
use MOM_domains, only : min_across_PEs, clone_MOM_domain, deallocate_MOM_domain
@@ -16,7 +21,7 @@ module MOM_barotropic
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
use MOM_forcing_type, only : mech_forcing
use MOM_grid, only : ocean_grid_type
-use MOM_harmonic_analysis, only : HA_accum_FtSSH, harmonic_analysis_CS
+use MOM_harmonic_analysis, only : HA_accum, harmonic_analysis_CS
use MOM_hor_index, only : hor_index_type
use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher, NORTH_FACE, EAST_FACE
use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, open_boundary_query
@@ -137,7 +142,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_) :: &
@@ -158,8 +163,12 @@ module MOM_barotropic
real, allocatable, dimension(:,:) :: &
D_u_Cor, & !< A simply averaged depth at u points recast as a thickness [H ~> m or kg m-2]
D_v_Cor, & !< A simply averaged depth at v points recast as a thickness [H ~> m or kg m-2]
- q_D !< f / D at PV points [Z-1 T-1 ~> m-1 s-1].
-
+ q_D !< f / D at PV points [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1]
+ real, allocatable, dimension(:,:,:) :: &
+ q_wt !< The area weights for the thicknesses around a corner point to be used when
+ !! calculating PV for use in the Coriolis term, taking OBCs into account [L2 ~> m2].
+ !! The order of the 4 values at a point is the order in which the neighboring
+ !! tracer points occur in memory, i.e. SW, SE, NW then NE.
real, allocatable :: frhatu1(:,:,:) !< Predictor step values of frhatu stored for diagnostics [nondim]
real, allocatable :: frhatv1(:,:,:) !< Predictor step values of frhatv stored for diagnostics [nondim]
real, allocatable :: IareaT_OBCmask(:,:) !< If non-zero, work on given points [L-2 ~> m-2].
@@ -208,6 +217,12 @@ module MOM_barotropic
!! equation. Otherwise the transports are the sum of the transports
!! based on a series of instantaneous velocities and the BT_CONT_TYPE
!! for transports. This is only valid if a BT_CONT_TYPE is used.
+ logical :: bt_adjust_src_for_filter !< If true, increases the rate at which BT mass sources are
+ !! applied so that they are all used up before the steps within the
+ !! filtering period start. This avoids the mass sink driving the SSH
+ !! below the bottom during the period of filtering.
+ logical :: bt_limit_integral_transport !< If true, limit the time-integrated transports by the
+ !! initial volume accounting for sinks of mass.
logical :: integral_OBCs !< This is true if integral_bt_cont is true and there are open boundary
!! conditions being applied somewhere in the global domain.
logical :: Nonlinear_continuity !< If true, the barotropic continuity equation
@@ -253,6 +268,10 @@ module MOM_barotropic
!! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT
logical :: strong_drag !< If true, use a stronger estimate of the retarding
!! effects of strong bottom drag.
+ logical :: rescale_strong_drag !< If true, reduce the barotropic contribution to the layer
+ !! accelerations to account for the difference between the forces that
+ !! can be counteracted by the stronger drag with BT_STRONG_DRAG and the
+ !! average of the layer viscous remnants after a baroclinic timestep.
logical :: linear_wave_drag !< If true, apply a linear drag to the barotropic
!! velocities, using rates set by lin_drag_u & _v
!! divided by the depth of the ocean.
@@ -265,12 +284,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
@@ -301,6 +326,11 @@ module MOM_barotropic
logical :: wt_uv_bug = .true. !< If true, recover a bug that wt_[uv] that is not normalized.
logical :: exterior_OBC_bug = .true. !< If true, recover a bug with boundary conditions
!! inside the domain.
+ logical :: interior_OBC_PV !< If true, use only interior ocean points at OBCs to specify the PV
+ !! used in the barotropic Coriolis anomalies. Otherwise the
+ !! calculation relies on bathymetry and eta being projected outward
+ !! across OBCs. Unfortunately, this option does change answers near
+ !! convex (peninsula-type) pairs of OBC segments.
type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock.
type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate
!! the timing of diagnostic output.
@@ -333,14 +363,15 @@ module MOM_barotropic
!>@{ Diagnostic IDs
integer :: id_PFu_bt = -1, id_PFv_bt = -1, id_Coru_bt = -1, id_Corv_bt = -1
- integer :: id_LDu_bt = -1, id_LDv_bt = -1
+ integer :: id_LDu_bt = -1, id_LDv_bt = -1, id_eta_cor = -1
integer :: id_ubtforce = -1, id_vbtforce = -1, id_uaccel = -1, id_vaccel = -1
- integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_eta_cor = -1
+ integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_bt_rem_u = -1, id_bt_rem_v = -1
integer :: id_ubt = -1, id_vbt = -1, id_eta_bt = -1, id_ubtav = -1, id_vbtav = -1
integer :: id_ubt_st = -1, id_vbt_st = -1, id_eta_st = -1
integer :: id_ubtdt = -1, id_vbtdt = -1
integer :: id_ubt_hifreq = -1, id_vbt_hifreq = -1, id_eta_hifreq = -1
integer :: id_uhbt_hifreq = -1, id_vhbt_hifreq = -1, id_eta_pred_hifreq = -1
+ integer :: id_etaPF_hifreq = -1, id_etaPF_anom = -1
integer :: id_gtotn = -1, id_gtots = -1, id_gtote = -1, id_gtotw = -1
integer :: id_uhbt = -1, id_frhatu = -1, id_vhbt = -1, id_frhatv = -1
integer :: id_frhatu1 = -1, id_frhatv1 = -1
@@ -351,6 +382,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
@@ -572,13 +604,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
uhbt0, & ! The difference between the sum of the layer zonal thickness
! fluxes and the barotropic thickness flux using the same
! velocity [H L2 T-1 ~> m3 s-1 or kg s-1].
- ubt_prev, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1].
- ubt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1].
- ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1].
- Cor_u, & ! The zonal Coriolis acceleration [L T-2 ~> m s-2].
Cor_ref_u, & ! The zonal barotropic Coriolis acceleration due
! to the reference velocities [L T-2 ~> m s-2].
- PFu, & ! The zonal pressure force acceleration [L T-2 ~> m s-2].
Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points for drag parameterizations
! that introduced directly into the barotropic solver rather than coming in via
! the visc_rem_u arrays from the layered equations [T-1 ~> s-1].
@@ -599,13 +626,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
vhbt0, & ! The difference between the sum of the layer meridional
! thickness fluxes and the barotropic thickness flux using
! the same velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
- vbt_prev, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1].
- vbt_first, & ! The starting value of vbt in a series of barotropic steps [L T-1 ~> m s-1].
- vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1].
- Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2].
Cor_ref_v, & ! The meridional barotropic Coriolis acceleration due
! to the reference velocities [L T-2 ~> m s-2].
- PFv, & ! The meridional pressure force acceleration [L T-2 ~> m s-2].
Rayleigh_v, & ! A Rayleigh drag timescale operating at v-points for drag parameterizations
! that introduced directly into the barotropic solver rather than coming
! in via the visc_rem_v arrays from the layered equations [T-1 ~> s-1].
@@ -634,9 +656,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
real, dimension(SZI_(G),SZJB_(G)) :: Drag_v
! The meridional acceleration due to frequency-dependent drag [L T-2 ~> m s-2]
real, target, dimension(SZIW_(CS),SZJW_(CS)) :: &
- eta, & ! The barotropic free surface height anomaly or column mass
+ eta ! The barotropic free surface height anomaly or column mass
! anomaly [H ~> m or kg m-2]
- eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta.
real, dimension(SZIW_(CS),SZJW_(CS)) :: &
eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2].
eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2].
@@ -666,7 +687,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! End of wide-sized variables.
real :: visc_rem ! A work variable that may equal visc_rem_[uv] [nondim]
- real :: vel_prev ! The previous velocity [L T-1 ~> m s-1].
real :: dtbt ! The barotropic time step [T ~> s].
real :: Idt ! The inverse of dt [T-1 ~> s-1].
real :: det_de ! The partial derivative due to self-attraction and loading
@@ -701,8 +721,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
real :: Htot ! The total thickness [H ~> m or kg m-2].
real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2].
real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2].
- real :: h_neglect ! A thickness that is so small it is usually lost
- ! in roundoff and can be neglected [H ~> m or kg m-2].
+ real :: h_a_neglect ! A cell volume or mass that is so small it is usually lost
+ ! in roundoff and can be neglected [H L2 ~> m3 or kg].
real, allocatable :: wt_vel(:) ! The raw or relative weights of each of the barotropic timesteps
! in determining the average velocities [nondim]
@@ -727,13 +747,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
logical :: apply_OBCs, apply_OBC_flather
type(memory_size_type) :: MS
character(len=200) :: mesg
- integer :: isv, iev, jsv, jev ! The valid array size at the end of a step.
integer :: stencil ! The stencil size of the algorithm, often 1 or 2.
integer :: isvf, ievf, jsvf, jevf, num_cycles
integer :: i, j, k, n
integer :: is, ie, js, je, nz, Isq, Ieq, Jsq, Jeq
integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
- integer :: l_seg
if (.not.CS%module_is_initialized) call MOM_error(FATAL, &
"btstep: Module MOM_barotropic must be initialized before it is used.")
@@ -744,7 +762,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
MS%isdw = CS%isdw ; MS%iedw = CS%iedw ; MS%jsdw = CS%jsdw ; MS%jedw = CS%jedw
- h_neglect = GV%H_subroundoff
+ h_a_neglect = GV%H_subroundoff * (1.0 * US%m_to_L**2)
Idt = 1.0 / dt
accel_underflow = CS%vel_underflow * Idt
@@ -755,9 +773,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)
@@ -852,23 +870,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
!--- end setup for group halo update
+ !$omp target enter data &
+ !$omp map(alloc: ubt_Cor, vbt_Cor, wt_u, wt_v, av_rem_u, av_rem_v, ubt_wtd, vbt_wtd, Coru_avg, &
+ !$omp Corv_avg, LDu_avg, LDv_avg, e_anom, q, ubt, vbt, bt_rem_u, bt_rem_v, BT_force_u, &
+ !$omp BT_force_v, u_accel_bt, v_accel_bt, uhbt, vhbt, uhbt0, vhbt0, &
+ !$omp Cor_ref_u, Cor_ref_v, DCor_u, DCor_v, &
+ !$omp Datu, Datv, f_4_u, f_4_v, eta, eta_sum, eta_wtd, eta_IC, eta_PF, eta_PF_1, &
+ !$omp d_eta_PF, gtot_E, gtot_W, gtot_N, gtot_S, eta_src, dyn_coef_eta, BTCL_u, BTCL_v, &
+ !$omp PFu_avg, PFv_avg)
! Calculate the constant coefficients for the Coriolis force terms in the
! barotropic momentum equations. This has to be done quite early to start
! the halo update that needs to be completed before the next calculations.
if (CS%linearized_BT_PV) then
- !$OMP parallel do default(shared)
- do J=jsvf-2,jevf+1 ; do I=isvf-2,ievf+1
+ do concurrent (J=jsvf-2:jevf+1, I=isvf-2:ievf+1)
q(I,J) = CS%q_D(I,j)
- enddo ; enddo
- !$OMP parallel do default(shared)
- do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1
+ enddo
+ do concurrent (j=jsvf-1:jevf+1, I=isvf-2:ievf+1)
DCor_u(I,j) = CS%D_u_Cor(I,j)
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1
+ enddo
+ do concurrent (J=jsvf-2:jevf+1, i=isvf-1:ievf+1)
DCor_v(i,J) = CS%D_v_Cor(i,J)
- enddo ; enddo
+ enddo
else
q(:,:) = 0.0 ; DCor_u(:,:) = 0.0 ; DCor_v(:,:) = 0.0
if (GV%Boussinesq) then
@@ -877,35 +900,98 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
DCor_u(I,j) = 0.5 * (max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + &
max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) )
enddo ; enddo
+ if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then
+ !$OMP parallel do default(shared)
+ do j = max(js,CS%BT_OBC%js_u_W_obc), min(je,CS%BT_OBC%je_u_W_obc)
+ do I = max(is-1,CS%BT_OBC%Is_u_W_obc), min(ie,CS%BT_OBC%Ie_u_W_obc)
+ if (CS%BT_OBC%u_OBC_type(I,j) < 0) & ! Western boundary condition
+ DCor_u(I,j) = max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0)
+ enddo
+ enddo
+ !$OMP parallel do default(shared)
+ do j = max(js,CS%BT_OBC%js_u_E_obc), min(je,CS%BT_OBC%je_u_E_obc)
+ do I = max(is-1,CS%BT_OBC%Is_u_E_obc), min(ie,CS%BT_OBC%Ie_u_E_obc)
+ if (CS%BT_OBC%u_OBC_type(I,j) > 0) & ! Eastern boundary condition
+ DCor_u(I,j) = max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0)
+ enddo
+ enddo
+ endif
+
!$OMP parallel do default(shared)
do J=js-1,je ; do i=is,ie
DCor_v(i,J) = 0.5 * (max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i+1,j), 0.0) + &
max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) )
enddo ; enddo
+ if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then
+ !$OMP parallel do default(shared)
+ do j = max(js,CS%BT_OBC%js_v_S_obc), min(je,CS%BT_OBC%je_v_S_obc)
+ do I = max(is-1,CS%BT_OBC%Is_v_S_obc), min(ie,CS%BT_OBC%Ie_v_S_obc)
+ if (CS%BT_OBC%v_OBC_type(i,J) < 0) & ! Southern boundary condition
+ DCor_v(i,J) = max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0)
+ enddo
+ enddo
+ !$OMP parallel do default(shared)
+ do j = max(js,CS%BT_OBC%js_v_N_obc), min(je,CS%BT_OBC%je_v_N_obc)
+ do I = max(is-1,CS%BT_OBC%Is_v_N_obc), min(ie,CS%BT_OBC%Ie_v_N_obc)
+ if (CS%BT_OBC%v_OBC_type(i,J) > 0) & ! Northern boundary condition
+ DCor_v(i,J) = max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0)
+ enddo
+ enddo
+ endif
!$OMP parallel do default(shared)
do J=js-1,je ; do I=is-1,ie
q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * &
- ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / &
- (max(((G%areaT(i,j) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0)) + &
- (G%areaT(i+1,j+1) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0))) + &
- ((G%areaT(i+1,j) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0)) + &
- (G%areaT(i,j+1) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0))), h_neglect) )
+ ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / &
+ (max(((CS%q_wt(1,I,J) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0)) + &
+ (CS%q_wt(4,I,J) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0))) + &
+ ((CS%q_wt(2,I,J) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0)) + &
+ (CS%q_wt(3,I,J) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0))), h_a_neglect) )
enddo ; enddo
- else
+ else ! Non-Boussinesq
!$OMP parallel do default(shared)
do j=js,je ; do I=is-1,ie
DCor_u(I,j) = 0.5 * (eta_in(i+1,j) + eta_in(i,j))
enddo ; enddo
+ if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then
+ !$OMP parallel do default(shared)
+ do j = max(js,CS%BT_OBC%js_u_W_obc), min(je,CS%BT_OBC%je_u_W_obc)
+ do I = max(is-1,CS%BT_OBC%Is_u_W_obc), min(ie,CS%BT_OBC%Ie_u_W_obc)
+ if (CS%BT_OBC%u_OBC_type(I,j) < 0) DCor_u(I,j) = eta_in(i+1,j) ! Western boundary condition
+ enddo
+ enddo
+ !$OMP parallel do default(shared)
+ do j = max(js,CS%BT_OBC%js_u_E_obc), min(je,CS%BT_OBC%je_u_E_obc)
+ do I = max(is-1,CS%BT_OBC%Is_u_E_obc), min(ie,CS%BT_OBC%Ie_u_E_obc)
+ if (CS%BT_OBC%u_OBC_type(I,j) > 0) DCor_u(I,j) = eta_in(i,j) ! Eastern boundary condition
+ enddo
+ enddo
+ endif
+
!$OMP parallel do default(shared)
do J=js-1,je ; do i=is,ie
DCor_v(i,J) = 0.5 * (eta_in(i,j+1) + eta_in(i,j))
enddo ; enddo
+ if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then
+ !$OMP parallel do default(shared)
+ do j = max(js,CS%BT_OBC%js_v_S_obc), min(je,CS%BT_OBC%je_v_S_obc)
+ do I = max(is-1,CS%BT_OBC%Is_v_S_obc), min(ie,CS%BT_OBC%Ie_v_S_obc)
+ if (CS%BT_OBC%v_OBC_type(i,J) < 0) DCor_v(i,J) = eta_in(i,j+1) ! Southern boundary condition
+ enddo
+ enddo
+ !$OMP parallel do default(shared)
+ do j = max(js,CS%BT_OBC%js_v_N_obc), min(je,CS%BT_OBC%je_v_N_obc)
+ do I = max(is-1,CS%BT_OBC%Is_v_N_obc), min(ie,CS%BT_OBC%Ie_v_N_obc)
+ if (CS%BT_OBC%v_OBC_type(i,J) > 0) DCor_v(i,J) = eta_in(i,j) ! Northern boundary condition
+ enddo
+ enddo
+ endif
+
!$OMP parallel do default(shared)
do J=js-1,je ; do I=is-1,ie
q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * &
- ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / &
- (max(((G%areaT(i,j) * eta_in(i,j)) + (G%areaT(i+1,j+1) * eta_in(i+1,j+1))) + &
- ((G%areaT(i+1,j) * eta_in(i+1,j)) + (G%areaT(i,j+1) * eta_in(i,j+1))), h_neglect) )
+ ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / &
+ (max(((CS%q_wt(1,I,J) * eta_in(i,j)) + (CS%q_wt(4,I,J) * eta_in(i+1,j+1))) + &
+ ((CS%q_wt(2,I,J) * eta_in(i+1,j)) + (CS%q_wt(3,I,J) * eta_in(i,j+1))), h_a_neglect) )
enddo ; enddo
endif
@@ -915,16 +1001,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! must be done before the [abcd]mer and [abcd]zon are calculated.
if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
if (nonblock_setup) then
+ !$omp target update from(q, DCor_u, DCor_v)
call start_group_pass(CS%pass_q_DCor, CS%BT_Domain, clock=id_clock_pass_pre)
else
- call do_group_pass(CS%pass_q_DCor, CS%BT_Domain, clock=id_clock_pass_pre)
+ call do_group_pass(CS%pass_q_DCor, CS%BT_Domain, clock=id_clock_pass_pre, omp_offload=.true.)
endif
if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
endif
! Zero out various wide-halo arrays.
- !$OMP parallel do default(shared)
- do j=CS%jsdw,CS%jedw ; do i=CS%isdw,CS%iedw
+ do concurrent (j=CS%jsdw:CS%jedw, i=CS%isdw:CS%iedw)
gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0
gtot_N(i,j) = 0.0 ; gtot_S(i,j) = 0.0
eta(i,j) = 0.0
@@ -936,20 +1022,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
eta_IC(i,j) = 0.0
endif
if (CS%dynamic_psurf) dyn_coef_eta(i,j) = 0.0
- enddo ; enddo
+ enddo
! The halo regions of various arrays need to be initialized to
! non-NaNs in case the neighboring domains are not part of the ocean.
! Otherwise a halo update later on fills in the correct values.
- !$OMP parallel do default(shared)
- do j=CS%jsdw,CS%jedw ; do I=CS%isdw-1,CS%iedw
+ do concurrent (j=CS%jsdw:CS%jedw, I=CS%isdw-1:CS%iedw)
Cor_ref_u(I,j) = 0.0 ; BT_force_u(I,j) = 0.0 ; ubt(I,j) = 0.0
Datu(I,j) = 0.0 ; bt_rem_u(I,j) = 0.0 ; uhbt0(I,j) = 0.0
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=CS%jsdw-1,CS%jedw ; do i=CS%isdw,CS%iedw
+ enddo
+ do concurrent (J=CS%jsdw-1:CS%jedw, i=CS%isdw:CS%iedw)
Cor_ref_v(i,J) = 0.0 ; BT_force_v(i,J) = 0.0 ; vbt(i,J) = 0.0
Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0
- enddo ; enddo
+ enddo
if (apply_OBCs) then
SpV_col_avg(:,:) = 0.0
@@ -980,28 +1064,26 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! Copy input arrays into their wide-halo counterparts.
if (interp_eta_PF) then
- !$OMP parallel do default(shared)
- do j=G%jsd,G%jed ; do i=G%isd,G%ied ! Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why?
+ do concurrent (j=G%jsd:G%jed, i=G%isd:G%ied)
+ ! Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why?
eta(i,j) = eta_in(i,j)
eta_PF_1(i,j) = eta_PF_start(i,j)
d_eta_PF(i,j) = eta_PF_in(i,j) - eta_PF_start(i,j)
- enddo ; enddo
+ enddo
else
- !$OMP parallel do default(shared)
- do j=G%jsd,G%jed ; do i=G%isd,G%ied !: Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why?
+ do concurrent (j=G%Jsd:G%Jed, i=G%isd:G%ied)
+ ! Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why?
eta(i,j) = eta_in(i,j)
eta_PF(i,j) = eta_PF_in(i,j)
- enddo ; enddo
+ enddo
endif
if (integral_BT_cont) then
- !$OMP parallel do default(shared)
- do j=G%jsd,G%jed ; do i=G%isd,G%ied
+ do concurrent (j=G%jsd:G%jed, i=G%isd:G%ied)
eta_IC(i,j) = eta_in(i,j)
- enddo ; enddo
+ enddo
endif
- !$OMP parallel do default(shared) private(visc_rem)
- do k=1,nz ; do j=js,je ; do I=is-1,ie
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
! rem needs to be greater than visc_rem_u and 1-Instep/visc_rem_u.
! The 0.5 below is just for safety.
! NOTE: subroundoff is a negligible value used to prevent division by zero.
@@ -1012,89 +1094,102 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
visc_rem = max(visc_rem, 1. - 0.5 * Instep / (visc_rem + subroundoff))
visc_rem = max(visc_rem, 0.)
wt_u(I,j,k) = CS%frhatu(I,j,k) * visc_rem
- enddo ; enddo ; enddo
- !$OMP parallel do default(shared) private(visc_rem)
- do k=1,nz ; do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
! As above, rem must be greater than visc_rem_v and 1-Instep/visc_rem_v.
visc_rem = min(visc_rem_v(I,j,k), 1.)
visc_rem = max(visc_rem, 1. - 0.5 * Instep / (visc_rem + subroundoff))
visc_rem = max(visc_rem, 0.)
wt_v(i,J,k) = CS%frhatv(i,J,k) * visc_rem
- enddo ; enddo ; enddo
+ enddo
if (.not. CS%wt_uv_bug) then
- do j=js,je ; do I=is-1,ie ; Iwt_u_tot(I,j) = wt_u(I,j,1) ; enddo ; enddo
- do k=2,nz ; do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
+ Iwt_u_tot(I,j) = wt_u(I,j,1)
+ enddo
+ do k=2,nz ; do concurrent (j=js:je, I=is-1:ie)
Iwt_u_tot(I,j) = Iwt_u_tot(I,j) + wt_u(I,j,k)
- enddo ; enddo ; enddo
- do j=js,je ; do I=is-1,ie
- if (abs(Iwt_u_tot(I,j)) > 0.0 ) Iwt_u_tot(I,j) = G%mask2dCu(I,j) / Iwt_u_tot(I,j)
enddo ; enddo
- do k=1,nz ; do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie, abs(Iwt_u_tot(I,j)) > 0.0)
+ Iwt_u_tot(I,j) = G%mask2dCu(I,j) / Iwt_u_tot(I,j)
+ enddo
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
wt_u(I,j,k) = wt_u(I,j,k) * Iwt_u_tot(I,j)
- enddo ; enddo ; enddo
+ enddo
- do J=js-1,je ; do i=is,ie ; Iwt_v_tot(i,J) = wt_v(i,J,1) ; enddo ; enddo
- do k=2,nz ; do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
+ Iwt_v_tot(i,J) = wt_v(i,J,1)
+ enddo
+ do k=2,nz ; do concurrent (J=js-1:je, i=is:ie)
Iwt_v_tot(i,J) = Iwt_v_tot(i,J) + wt_v(i,J,k)
- enddo ; enddo ; enddo
- do J=js-1,je ; do i=is,ie
- if (abs(Iwt_v_tot(i,J)) > 0.0 ) Iwt_v_tot(i,J) = G%mask2dCv(i,J) / Iwt_v_tot(i,J)
enddo ; enddo
- do k=1,nz ; do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie, abs(Iwt_v_tot(i,J)) > 0.0)
+ Iwt_v_tot(i,J) = G%mask2dCv(i,J) / Iwt_v_tot(i,J)
+ enddo
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
wt_v(i,J,k) = wt_v(i,J,k) * Iwt_v_tot(i,J)
- enddo ; enddo ; enddo
+ enddo
endif
! Use u_Cor and v_Cor as the reference values for the Coriolis terms,
! including the viscous remnant.
- !$OMP parallel do default(shared)
- do j=js-1,je+1 ; do I=is-1,ie ; ubt_Cor(I,j) = 0.0 ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is-1,ie+1 ; vbt_Cor(i,J) = 0.0 ; enddo ; enddo
- !$OMP parallel do default(shared)
- do j=js,je ; do k=1,nz ; do I=is-1,ie
- ubt_Cor(I,j) = ubt_Cor(I,j) + wt_u(I,j,k) * U_Cor(I,j,k)
- enddo ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do k=1,nz ; do i=is,ie
- vbt_Cor(i,J) = vbt_Cor(i,J) + wt_v(i,J,k) * V_Cor(i,J,k)
- enddo ; enddo ; enddo
+ do concurrent (j=js-1:je+1, I=is-1:ie)
+ ubt_Cor(I,j) = 0.0
+ enddo
+ do concurrent (J=js-1:je, i=is-1:ie+1)
+ vbt_Cor(i,J) = 0.0
+ enddo
+ do concurrent (j=js:je)
+ do k=1,nz
+ do concurrent (I=is-1:ie)
+ ubt_Cor(I,j) = ubt_Cor(I,j) + wt_u(I,j,k) * U_Cor(I,j,k)
+ enddo
+ enddo
+ enddo
+ do concurrent (J=js-1:je)
+ do k=1,nz
+ do concurrent (i=is:ie)
+ vbt_Cor(i,J) = vbt_Cor(i,J) + wt_v(i,J,k) * V_Cor(i,J,k)
+ enddo
+ enddo
+ enddo
! The gtot arrays are the effective layer-weighted reduced gravities for
! accelerations across the various faces, with names for the relative
! locations of the faces to the pressure point. They will have their halos
! updated later on.
- !$OMP parallel do default(shared)
- do j=js,je
- do k=1,nz ; do I=is-1,ie
- gtot_E(i,j) = gtot_E(i,j) + pbce(i,j,k) * wt_u(I,j,k)
- gtot_W(i+1,j) = gtot_W(i+1,j) + pbce(i+1,j,k) * wt_u(I,j,k)
- enddo ; enddo
+ do concurrent (j=js:je)
+ do k=1,nz
+ do concurrent (i=is-1:ie)
+ gtot_E(i,j) = gtot_E(i,j) + pbce(i,j,k) * wt_u(I,j,k)
+ gtot_W(i+1,j) = gtot_W(i+1,j) + pbce(i+1,j,k) * wt_u(I,j,k)
+ enddo
+ enddo
enddo
- !$OMP parallel do default(shared)
- do J=js-1,je
- do k=1,nz ; do i=is,ie
- gtot_N(i,j) = gtot_N(i,j) + pbce(i,j,k) * wt_v(i,J,k)
- gtot_S(i,j+1) = gtot_S(i,j+1) + pbce(i,j+1,k) * wt_v(i,J,k)
- enddo ; enddo
+ do concurrent (J=js-1:je)
+ do k=1,nz
+ do concurrent (i=is:ie)
+ gtot_N(i,j) = gtot_N(i,j) + pbce(i,j,k) * wt_v(i,J,k)
+ gtot_S(i,j+1) = gtot_S(i,j+1) + pbce(i,j+1,k) * wt_v(i,J,k)
+ enddo
+ enddo
enddo
if (CS%BT_OBC%u_OBCs_on_PE) then
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
if (CS%BT_OBC%u_OBC_type(I,j) > 0) & ! Eastern boundary condition
gtot_W(i+1,j) = gtot_W(i,j) ! Perhaps this should be gtot_E(i,j)?
if (CS%BT_OBC%u_OBC_type(I,j) < 0) & ! Western boundary condition
gtot_E(i,j) = gtot_E(i+1,j) ! Perhaps this should be gtot_W(i+1,j)?
- enddo ; enddo
+ enddo
endif
if (CS%BT_OBC%v_OBCs_on_PE) then
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
if (CS%BT_OBC%v_OBC_type(i,J) > 0) & ! Northern boundary condition
gtot_S(i,j+1) = gtot_S(i,j) !### Should this be gtot_N(i,j) to use wt_v at the same point?
if (CS%BT_OBC%v_OBC_type(i,J) < 0) & ! Southern boundary condition
gtot_N(i,j) = gtot_N(i,j+1) ! Perhaps this should be gtot_S(i,j+1)?
- enddo ; enddo
+ enddo
endif
if (CS%calculate_SAL) then
@@ -1111,6 +1206,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (nonblock_setup .and. .not.CS%linearized_BT_PV) then
if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
call complete_group_pass(CS%pass_q_DCor, CS%BT_Domain, clock=id_clock_pass_pre)
+ !$omp target update to(q, DCor_u, DCor_v)
if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
endif
@@ -1131,6 +1227,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! Set up fields related to the open boundary conditions. These calls include halo updates that
! must occur on all PEs when there are open boundary conditions anywhere.
if (apply_OBCs) then
+ !$omp target update from(eta, Datu, Datv, BTCL_u, BTCL_v)
if (nonblock_setup .and. apply_OBC_flather .and. .not.GV%Boussinesq) &
call complete_group_pass(CS%pass_SpV_avg, CS%BT_domain)
@@ -1142,32 +1239,38 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! Determine the difference between the sum of the layer fluxes and the
! barotropic fluxes found from the same input velocities.
if (add_uh0) then
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie ; uhbt(I,j) = 0.0 ; ubt(I,j) = 0.0 ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie ; vhbt(i,J) = 0.0 ; vbt(i,J) = 0.0 ; enddo ; enddo
+ do concurrent (j=js:je, I=is-1:ie)
+ uhbt(I,j) = 0.0 ; ubt(I,j) = 0.0
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
+ vhbt(i,J) = 0.0 ; vbt(i,J) = 0.0
+ enddo
if (CS%visc_rem_u_uh0) then
- !$OMP parallel do default(shared)
- do j=js,je ; do k=1,nz ; do I=is-1,ie
+ do k=1,nz ; do concurrent (j=js:je, I=is-1:ie)
uhbt(I,j) = uhbt(I,j) + uh0(I,j,k)
ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * u_uh0(I,j,k)
- enddo ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do k=1,nz ; do i=is,ie
+ enddo ; enddo
+ do k=1,nz ; do concurrent (J=js-1:je, i=is:ie)
vhbt(i,J) = vhbt(i,J) + vh0(i,J,k)
vbt(i,J) = vbt(i,J) + wt_v(i,J,k) * v_vh0(i,J,k)
- enddo ; enddo ; enddo
+ enddo ; enddo
else
- !$OMP parallel do default(shared)
- do j=js,je ; do k=1,nz ; do I=is-1,ie
- uhbt(I,j) = uhbt(I,j) + uh0(I,j,k)
- ubt(I,j) = ubt(I,j) + CS%frhatu(I,j,k) * u_uh0(I,j,k)
- enddo ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do k=1,nz ; do i=is,ie
- vhbt(i,J) = vhbt(i,J) + vh0(i,J,k)
- vbt(i,J) = vbt(i,J) + CS%frhatv(i,J,k) * v_vh0(i,J,k)
- enddo ; enddo ; enddo
+ do concurrent (j=js:je)
+ do k=1,nz
+ do concurrent (I=is-1:ie)
+ uhbt(I,j) = uhbt(I,j) + uh0(I,j,k)
+ ubt(I,j) = ubt(I,j) + CS%frhatu(I,j,k) * u_uh0(I,j,k)
+ enddo
+ enddo
+ enddo
+ do concurrent (J=js-1:je)
+ do k=1,nz
+ do concurrent (i=is:ie)
+ vhbt(i,J) = vhbt(i,J) + vh0(i,J,k)
+ vbt(i,J) = vbt(i,J) + CS%frhatv(i,J,k) * v_vh0(i,J,k)
+ enddo
+ enddo
+ enddo
endif
if ((use_BT_cont .or. integral_BT_cont) .and. CS%adjust_BT_cont) then
! Use the additional input transports to broaden the fits
@@ -1176,11 +1279,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! Fill in the halo data for ubt, vbt, uhbt, and vhbt.
if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
+ !$omp target update from(ubt, vbt, uhbt, vhbt)
call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie)
call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie)
+ !$omp target update to(ubt, vbt, uhbt, vhbt)
if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
-
+ !$omp target update from(BTCL_u, BTCL_v)
if (integral_BT_cont) then
call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, &
G, US, MS, 1+ievf-ie, dt_baroclinic=dt)
@@ -1188,57 +1293,64 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, &
G, US, MS, 1+ievf-ie)
endif
+ !$omp target update to(BTCL_u, BTCL_v)
endif
if (integral_BT_cont) then
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
uhbt0(I,j) = uhbt(I,j) - find_uhbt(dt*ubt(I,j), BTCL_u(I,j)) * Idt
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
vhbt0(i,J) = vhbt(i,J) - find_vhbt(dt*vbt(i,J), BTCL_v(i,J)) * Idt
- enddo ; enddo
+ enddo
elseif (use_BT_cont) then
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j))
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J))
- enddo ; enddo
+ enddo
else
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
uhbt0(I,j) = uhbt(I,j) - Datu(I,j)*ubt(I,j)
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
vhbt0(i,J) = vhbt(i,J) - Datv(i,J)*vbt(i,J)
- enddo ; enddo
+ enddo
endif
if (CS%BT_OBC%u_OBCs_on_PE) then ! Zero out the reference transport at OBC points
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie ; if (CS%BT_OBC%u_OBC_type(I,j) /= 0) then
+ do concurrent(j=js:je, I=is-1:ie, CS%BT_OBC%u_OBC_type(I,j) /= 0)
uhbt0(I,j) = 0.0
- endif ; enddo ; enddo
+ enddo
endif
if (CS%BT_OBC%v_OBCs_on_PE) then !Zero out the reference transport at OBC points
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie ; if (CS%BT_OBC%v_OBC_type(i,J) /= 0) then
+ do concurrent (J=js-1:je, i=is:ie, CS%BT_OBC%v_OBC_type(i,J) /= 0)
vhbt0(i,J) = 0.0
- endif ; enddo ; enddo
+ enddo
endif
endif
! Calculate the initial barotropic velocities from the layer's velocities.
call btstep_ubt_from_layer(U_in, V_in, wt_u, wt_v, ubt, vbt, G, GV, CS)
- uhbt(:,:) = 0.0 ; vhbt(:,:) = 0.0
- u_accel_bt(:,:) = 0.0 ; v_accel_bt(:,:) = 0.0
+ do concurrent (j=CS%jsdw:CS%jedw, i=CS%isdw-1:CS%iedw)
+ uhbt(i,j) = 0.0 ; u_accel_bt(i,j) = 0.0
+ enddo
+ do concurrent (j=CS%jsdw-1:CS%jedw, i=CS%isdw:CS%iedw)
+ vhbt(i,j) = 0.0 ; v_accel_bt(i,j) = 0.0
+ enddo
- if (apply_OBCs) then
- ubt_first(:,:) = ubt(:,:) ; vbt_first(:,:) = vbt(:,:)
+ if (apply_OBCs .or. (CS%id_ubtdt > 0)) then
+ !$omp target update from(ubt)
+ do j=js,je ; do I=is-1,ie
+ ubt_st(I,j) = ubt(I,j)
+ enddo ; enddo
+ endif
+
+ if (apply_OBCs .or. (CS%id_vbtdt > 0)) then
+ !$omp target update from(vbt)
+ do J=js-1,je ; do i=is,ie
+ vbt_st(i,J) = vbt(i,J)
+ enddo ; enddo
endif
! Here the vertical average accelerations due to the Coriolis, advective,
@@ -1247,8 +1359,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! between the accelerations due to the average of the layer equations and the
! barotropic calculation.
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then
+ do concurrent (j=js:je, I=is-1:ie) ; if (G%OBCmaskCu(I,j) > 0.0) then
if (CS%nonlin_stress) then
if (GV%Boussinesq) then
Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + &
@@ -1272,9 +1383,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
BT_force_u(I,j) = forces%taux(I,j) * GV%RZ_to_H * CS%IDatu(I,j)*visc_rem_u(I,j,1)
else
BT_force_u(I,j) = 0.0
- endif ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then
+ endif ; enddo
+
+ do concurrent (J=js-1:je, i=is:ie) ; if (G%OBCmaskCv(i,J) > 0.0) then
if (CS%nonlin_stress) then
if (GV%Boussinesq) then
Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + &
@@ -1298,56 +1409,59 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
BT_force_v(i,J) = forces%tauy(i,J) * GV%RZ_to_H * CS%IDatv(i,J)*visc_rem_v(i,J,1)
else
BT_force_v(i,J) = 0.0
- endif ; enddo ; enddo
+ endif ; enddo
+
if (associated(taux_bot) .and. associated(tauy_bot)) then
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then
+ do concurrent (j=js:je, I=is-1:ie, G%mask2dCu(I,j) > 0.0)
BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * GV%RZ_to_H * CS%IDatu(I,j)
- endif ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then
+ enddo
+ do concurrent (J=js-1:je, i=is:ie, G%mask2dCv(i,J) > 0.0)
BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * GV%RZ_to_H * CS%IDatv(i,J)
- endif ; enddo ; enddo
+ enddo
endif
! bc_accel_u & bc_accel_v are only available on the potentially
! non-symmetric computational domain.
- !$OMP parallel do default(shared)
- do j=js,je ; do k=1,nz ; do I=Isq,Ieq
- BT_force_u(I,j) = BT_force_u(I,j) + wt_u(I,j,k) * bc_accel_u(I,j,k)
- enddo ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=Jsq,Jeq ; do k=1,nz ; do i=is,ie
- BT_force_v(i,J) = BT_force_v(i,J) + wt_v(i,J,k) * bc_accel_v(i,J,k)
- enddo ; enddo ; enddo
+ do concurrent (j=js:je)
+ do k=1,nz
+ do concurrent (I=Isq:Ieq)
+ BT_force_u(I,j) = BT_force_u(I,j) + wt_u(I,j,k) * bc_accel_u(I,j,k)
+ enddo
+ enddo
+ enddo
+ do concurrent (J=Jsq:Jeq)
+ do k=1,nz
+ do concurrent (i=is:ie)
+ BT_force_v(i,J) = BT_force_v(i,J) + wt_v(i,J,k) * bc_accel_v(i,J,k)
+ enddo
+ enddo
+ enddo
if (CS%gradual_BT_ICs) then
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
BT_force_u(I,j) = BT_force_u(I,j) + (ubt(I,j) - CS%ubt_IC(I,j)) * Idt
ubt(I,j) = CS%ubt_IC(I,j)
if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
BT_force_v(i,J) = BT_force_v(i,J) + (vbt(i,J) - CS%vbt_IC(i,J)) * Idt
vbt(i,J) = CS%vbt_IC(i,J)
if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0
- enddo ; enddo
+ enddo
endif
! Compute instantaneous tidal velocities and apply frequency-dependent drag.
! Note that the filtered velocities are only updated during the current predictor step,
! and are calculated using the barotropic velocity from the previous correction step.
if (CS%use_filter) then
+ !$omp target update from(ubt, vbt)
call Filt_accum(ubt(G%IsdB:G%IedB,G%jsd:G%jed), ufilt, CS%Time, US, CS%Filt_CS_u)
call Filt_accum(vbt(G%isd:G%ied,G%JsdB:G%JedB), vfilt, CS%Time, US, CS%Filt_CS_v)
endif
if (CS%use_filter .and. CS%linear_freq_drag) then
call wave_drag_calc(ufilt, vfilt, Drag_u, Drag_v, G, CS%Drag_CS)
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
Htot = 0.5 * (eta(i,j) + eta(i+1,j))
if (GV%Boussinesq) &
Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j))
@@ -1357,9 +1471,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
else
Drag_u(I,j) = 0.0
endif
- enddo ; enddo
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
Htot = 0.5 * (eta(i,j) + eta(i,j+1))
if (GV%Boussinesq) &
Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i,j+1))
@@ -1369,21 +1482,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
else
Drag_v(i,J) = 0.0
endif
- enddo ; enddo
+ enddo
endif
! Mask out the forcing at OBC points
if (CS%BT_OBC%u_OBCs_on_PE) then
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
BT_force_u(I,j) = CS%OBCmask_u(I,j) * BT_force_u(I,j)
- enddo ; enddo
+ enddo
endif
if (CS%BT_OBC%v_OBCs_on_PE) then
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
BT_force_v(i,J) = CS%OBCmask_v(i,J) * BT_force_v(i,J)
- enddo ; enddo
+ enddo
endif
if ((Isq > is-1) .or. (Jsq > js-1)) then
@@ -1392,6 +1503,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
tmp_u(:,:) = 0.0 ; tmp_v(:,:) = 0.0
+ !$omp target update from(BT_force_u, BT_force_v)
do j=js,je ; do I=Isq,Ieq ; tmp_u(I,j) = BT_force_u(I,j) ; enddo ; enddo
do J=Jsq,Jeq ; do i=is,ie ; tmp_v(i,J) = BT_force_v(i,J) ; enddo ; enddo
if (nonblock_setup) then
@@ -1400,6 +1512,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
call do_group_pass(CS%pass_tmp_uv, G%Domain)
do j=jsd,jed ; do I=IsdB,IedB ; BT_force_u(I,j) = tmp_u(I,j) ; enddo ; enddo
do J=JsdB,JedB ; do i=isd,ied ; BT_force_v(i,J) = tmp_v(i,J) ; enddo ; enddo
+ !$omp target update to(BT_force_u, BT_force_v)
endif
if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
@@ -1408,6 +1521,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (nonblock_setup) then
if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
+ ! ensure correct data on host to be exchanged
+ !$omp target update from(ubt_Cor, vbt_Cor, gtot_E, gtot_W, gtot_N, gtot_S)
call start_group_pass(CS%pass_gtot, CS%BT_Domain)
call start_group_pass(CS%pass_ubt_Cor, G%Domain)
if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
@@ -1425,121 +1540,139 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
call complete_group_pass(CS%pass_tmp_uv, G%Domain)
do j=jsd,jed ; do I=IsdB,IedB ; BT_force_u(I,j) = tmp_u(I,j) ; enddo ; enddo
do J=JsdB,JedB ; do i=isd,ied ; BT_force_v(i,J) = tmp_v(i,J) ; enddo ; enddo
+ !$omp target update to(BT_force_u, BT_force_v)
endif
call complete_group_pass(CS%pass_gtot, CS%BT_Domain)
call complete_group_pass(CS%pass_ubt_Cor, G%Domain)
+ !$omp target update to(Ubt_Cor, vbt_Cor, gtot_E, gtot_W, gtot_N, gtot_S)
else
- call do_group_pass(CS%pass_gtot, CS%BT_Domain)
- call do_group_pass(CS%pass_ubt_Cor, G%Domain)
+ call do_group_pass(CS%pass_gtot, CS%BT_Domain, omp_offload=.true.)
+ call do_group_pass(CS%pass_ubt_Cor, G%Domain, omp_offload=.true.)
endif
+ ! Update MPI-updated values are on GPU
! The various elements of gtot are positive definite but directional, so use
! the polarity arrays to sort out when the directions have shifted.
- do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
+ do concurrent (j=jsvf-1:jevf+1, i=isvf-1:ievf+1)
if (CS%ua_polarity(i,j) < 0.0) call swap(gtot_E(i,j), gtot_W(i,j))
if (CS%va_polarity(i,j) < 0.0) call swap(gtot_N(i,j), gtot_S(i,j))
- enddo ; enddo
+ enddo
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
Cor_ref_u(I,j) = &
(((f_4_u(4,I,j) * vbt_Cor(i+1,j)) + (f_4_u(1,I,j) * vbt_Cor(i ,j-1))) + &
((f_4_u(3,I,j) * vbt_Cor(i ,j)) + (f_4_u(2,I,j) * vbt_Cor(i+1,j-1))))
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
Cor_ref_v(i,J) = -1.0 * &
(((f_4_v(1,i,J) * ubt_Cor(I-1,j)) + (f_4_v(4,i,J) * ubt_Cor(I ,j+1))) + &
((f_4_v(2,i,J) * ubt_Cor(I ,j)) + (f_4_v(3,i,J) * ubt_Cor(I-1,j+1))))
- enddo ; enddo
+ enddo
! Now start new halo updates.
if (nonblock_setup) then
- if (.not.use_BT_cont) &
+ if (.not.use_BT_cont) then
+ !$omp target update from(Datu, Datv)
call start_group_pass(CS%pass_Dat_uv, CS%BT_Domain)
+ endif
! The following halo update is not needed without wide halos. RWH
+ !$omp target update from(BT_force_u, BT_force_v, Cor_ref_u, Cor_ref_v)
+ !$omp target update if(add_uh0) from(uhbt0, vhbt0)
call start_group_pass(CS%pass_force_hbt0_Cor_ref, CS%BT_Domain)
endif
if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
- !$OMP parallel default(shared) private(u_max_cor,uint_cor,v_max_cor,vint_cor,eta_cor_max,Htot)
- !$OMP do
- do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo
- !$OMP do
- do J=js-1,je ; do i=is-1,ie+1 ; av_rem_v(i,J) = 0.0 ; enddo ; enddo
- !$OMP do
- do j=js,je ; do k=1,nz ; do I=is-1,ie
- av_rem_u(I,j) = av_rem_u(I,j) + CS%frhatu(I,j,k) * visc_rem_u(I,j,k)
- enddo ; enddo ; enddo
- !$OMP do
- do J=js-1,je ; do k=1,nz ; do i=is,ie
- av_rem_v(i,J) = av_rem_v(i,J) + CS%frhatv(i,J,k) * visc_rem_v(i,J,k)
- enddo ; enddo ; enddo
+ do concurrent (j=js-1:je+1, I=is-1:ie)
+ av_rem_u(I,j) = 0.0
+ enddo
+ do concurrent (j=js:je)
+ do k=1,nz
+ do concurrent (I=is-1:ie)
+ av_rem_u(I,j) = av_rem_u(I,j) + CS%frhatu(I,j,k) * visc_rem_u(I,j,k)
+ enddo
+ enddo
+ enddo
+ do concurrent (J=js-1:je)
+ do concurrent(i=is-1:ie+1)
+ av_rem_v(i,J) = 0.0
+ enddo
+ do k=1,nz
+ do concurrent (i=is:ie)
+ av_rem_v(i,J) = av_rem_v(i,J) + CS%frhatv(i,J,k) * visc_rem_v(i,J,k)
+ enddo
+ enddo
+ enddo
if (CS%strong_drag) then
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
bt_rem_u(I,j) = G%mask2dCu(I,j) * &
((nstep * av_rem_u(I,j)) / (1.0 + (nstep-1)*av_rem_u(I,j)))
- enddo ; enddo
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
bt_rem_v(i,J) = G%mask2dCv(i,J) * &
((nstep * av_rem_v(i,J)) / (1.0 + (nstep-1)*av_rem_v(i,J)))
- enddo ; enddo
+ enddo
else
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
bt_rem_u(I,j) = 0.0
if (G%mask2dCu(I,j) * av_rem_u(I,j) > 0.0) &
bt_rem_u(I,j) = G%mask2dCu(I,j) * (av_rem_u(I,j)**Instep)
- enddo ; enddo
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
bt_rem_v(i,J) = 0.0
if (G%mask2dCv(i,J) * av_rem_v(i,J) > 0.0) &
bt_rem_v(i,J) = G%mask2dCv(i,J) * (av_rem_v(i,J)**Instep)
- enddo ; enddo
+ enddo
endif
+
if (CS%linear_wave_drag) then
- !$OMP do
- do j=js,je ; do I=is-1,ie ; if (CS%lin_drag_u(I,j) > 0.0) then
+ do concurrent (j=js:je, I=is-1:ie, G%mask2dCu(I,j) * CS%lin_drag_u(I,j) > 0.0)
Htot = 0.5 * (eta(i,j) + eta(i+1,j))
+
if (GV%Boussinesq) &
Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j))
- bt_rem_u(I,j) = bt_rem_u(I,j) * (Htot / (Htot + CS%lin_drag_u(I,j) * dtbt))
- Rayleigh_u(I,j) = CS%lin_drag_u(I,j) / Htot
- endif ; enddo ; enddo
- !$OMP do
- do J=js-1,je ; do i=is,ie ; if (CS%lin_drag_v(i,J) > 0.0) then
+ ! If Htot == 0., linear wave drag is not used and Rayleigh_u = 0.0 (from
+ ! initialization) and bt_rem_u is unmodified.
+ if (Htot > 0.0) then
+ bt_rem_u(I,j) = bt_rem_u(I,j) * (Htot / (Htot + CS%lin_drag_u(I,j) * dtbt))
+ Rayleigh_u(I,j) = CS%lin_drag_u(I,j) / Htot
+ endif
+ enddo
+
+ do concurrent (J=js-1:je, i=is:ie, G%mask2dCv(i,J) * CS%lin_drag_v(i,J) > 0.0)
Htot = 0.5 * (eta(i,j) + eta(i,j+1))
+
if (GV%Boussinesq) &
Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i,j+1))
- bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt))
- Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot
- endif ; enddo ; enddo
+ ! If Htot == 0., linear wave drag is not used and Rayleigh_v = 0.0 (from
+ ! initialization) and bt_rem_v is unmodified.
+ if (Htot > 0.0) then
+ bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt))
+ Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot
+ endif
+ enddo
endif
! Avoid changing the velocities at OBC points due to non-OBC calculations.
if (CS%BT_OBC%u_OBCs_on_PE) then
- !$OMP do
- do j=js,je ; do I=is-1,ie ; if (CS%BT_OBC%u_OBC_type(I,j) /= 0) then
+ do concurrent (j=js:je, I=is-1:ie, CS%BT_OBC%u_OBC_type(I,j) /= 0)
bt_rem_u(I,j) = 1.0
- endif ; enddo ; enddo
+ enddo
endif
if (CS%BT_OBC%v_OBCs_on_PE) then
- !$OMP do
- do J=js-1,je ; do i=is,ie ; if (CS%BT_OBC%v_OBC_type(i,J) /= 0) then
+ do concurrent (J=js-1:je, i=is:ie, CS%BT_OBC%v_OBC_type(i,J) /= 0)
bt_rem_v(i,J) = 1.0
- endif ; enddo ; enddo
+ enddo
endif
! Set the mass source, after first initializing the halos to 0.
- !$OMP do
- do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo
+ do concurrent (j=jsvf-1:jevf+1, i=isvf-1:ievf+1)
+ eta_src(i,j) = 0.0
+ enddo
if (CS%bound_BT_corr) then ; if ((use_BT_Cont.or.integral_BT_cont) .and. CS%BT_cont_bounds) then
- do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then
+ do concurrent (j=js:je, i=is:ie, G%mask2dT(i,j) > 0.0) &
+ DO_LOCALITY(local(uint_cor, vint_cor, u_max_cor, v_max_cor))
if (CS%eta_cor(i,j) > 0.0) then
! Limit the source (outward) correction to be a fraction the mass that
! can be transported out of the cell by velocities with a CFL number of CFL_cor.
@@ -1568,16 +1701,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
CS%eta_cor(i,j) = max(CS%eta_cor(i,j), -max(0.0,Htot))
endif
- endif ; enddo ; enddo
- else ; do j=js,je ; do i=is,ie
- if (abs(CS%eta_cor(i,j)) > dt*CS%eta_cor_bound(i,j)) &
+ enddo
+ else
+ do concurrent (j=js:je, i=is:ie, abs(CS%eta_cor(i,j)) > dt*CS%eta_cor_bound(i,j))
CS%eta_cor(i,j) = sign(dt*CS%eta_cor_bound(i,j), CS%eta_cor(i,j))
- enddo ; enddo ; endif ; endif
- !$OMP do
- do j=js,je ; do i=is,ie
+ enddo
+ endif ; endif
+
+ do concurrent (j=js:je, i=is:ie)
eta_src(i,j) = G%mask2dT(i,j) * (Instep * CS%eta_cor(i,j))
- enddo ; enddo
- !$OMP end parallel
+ enddo
if (CS%dynamic_psurf) then
ice_is_rigid = (associated(forces%rigidity_ice_u) .and. &
@@ -1591,47 +1724,51 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
else
H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin
endif
- !$OMP parallel do default(shared) private(Idt_max2,H_eff_dx2,dyn_coef_max,ice_strength)
- do j=js,je ; do i=is,ie
- ! First determine the maximum stable value for dyn_coef_eta.
-
- ! This estimate of the maximum stable time step is pretty accurate for
- ! gravity waves, but it is a conservative estimate since it ignores the
- ! stabilizing effect of the bottom drag.
- Idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*CS%bebt)) * (G%IareaT(i,j) * &
- (((gtot_E(i,j) * (Datu(I,j)*G%IdxCu(I,j))) + &
- (gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j)))) + &
- ((gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J))) + &
- (gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1))))) + &
- ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
- (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 )
- H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j)**2) + (G%IdyT(i,j)**2)), &
- G%IareaT(i,j) * &
- (((Datu(I,j)*G%IdxCu(I,j)) + (Datu(I-1,j)*G%IdxCu(I-1,j))) + &
- ((Datv(i,J)*G%IdyCv(i,J)) + (Datv(i,J-1)*G%IdyCv(i,J-1))) ) )
- dyn_coef_max = CS%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * Idt_max2) / &
- (dtbt**2 * H_eff_dx2)
-
- ! ice_strength has units of [L2 Z-1 T-2 ~> m s-2]. rigidity_ice_[uv] has units of [L4 Z-1 T-1 ~> m3 s-1].
- ice_strength = ((forces%rigidity_ice_u(I,j) + forces%rigidity_ice_u(I-1,j)) + &
- (forces%rigidity_ice_v(i,J) + forces%rigidity_ice_v(i,J-1))) / &
- (CS%ice_strength_length**2 * dtbt)
-
- ! Units of dyn_coef: [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]
- dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * H_to_Z)
- enddo ; enddo ; endif
+ do concurrent (j=js:je, i=is:ie)
+ ! First determine the maximum stable value for dyn_coef_eta.
+
+ ! This estimate of the maximum stable time step is pretty accurate for
+ ! gravity waves, but it is a conservative estimate since it ignores the
+ ! stabilizing effect of the bottom drag.
+ Idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*CS%bebt)) * (G%IareaT(i,j) * &
+ (((gtot_E(i,j) * (Datu(I,j)*G%IdxCu(I,j))) + &
+ (gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j)))) + &
+ ((gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J))) + &
+ (gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1))))) + &
+ ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
+ (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 )
+ H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j)**2) + (G%IdyT(i,j)**2)), &
+ G%IareaT(i,j) * &
+ (((Datu(I,j)*G%IdxCu(I,j)) + (Datu(I-1,j)*G%IdxCu(I-1,j))) + &
+ ((Datv(i,J)*G%IdyCv(i,J)) + (Datv(i,J-1)*G%IdyCv(i,J-1))) ) )
+ dyn_coef_max = CS%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * Idt_max2) / &
+ (dtbt**2 * H_eff_dx2)
+
+ ! ice_strength has units of [L2 Z-1 T-2 ~> m s-2]. rigidity_ice_[uv] has units of [L4 Z-1 T-1 ~> m3 s-1].
+ ice_strength = ((forces%rigidity_ice_u(I,j) + forces%rigidity_ice_u(I-1,j)) + &
+ (forces%rigidity_ice_v(i,J) + forces%rigidity_ice_v(i,J-1))) / &
+ (CS%ice_strength_length**2 * dtbt)
+
+ ! Units of dyn_coef: [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]
+ dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * H_to_Z)
+ enddo
+ endif
endif
if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
if (nonblock_setup) then
+ !$omp target update from(bt_rem_u, bt_rem_v, eta_src)
+ !$omp target update if(integral_BT_cont) from(eta_IC)
+ !$omp target update if(.not.interp_eta_PF) from(eta_PF)
+ !$omp target update if(interp_eta_PF) from(eta_PF_1, d_eta_PF)
+ !$omp target update if(CS%dynamic_psurf) from(dyn_coef_eta)
call start_group_pass(CS%pass_eta_bt_rem, CS%BT_Domain)
! The following halo update is not needed without wide halos. RWH
else
- call do_group_pass(CS%pass_eta_bt_rem, CS%BT_Domain)
- if (.not.use_BT_cont) &
- call do_group_pass(CS%pass_Dat_uv, CS%BT_Domain)
- call do_group_pass(CS%pass_force_hbt0_Cor_ref, CS%BT_Domain)
+ call do_group_pass(CS%pass_eta_bt_rem, CS%BT_Domain, omp_offload=.true.)
+ if (.not.use_BT_cont) call do_group_pass(CS%pass_Dat_uv, CS%BT_Domain, omp_offload=.true.)
+ call do_group_pass(CS%pass_force_hbt0_Cor_ref, CS%BT_Domain, omp_offload=.true.)
endif
if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
@@ -1641,56 +1778,90 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
- if (.not.use_BT_cont) call complete_group_pass(CS%pass_Dat_uv, CS%BT_Domain)
+ if (.not.use_BT_cont) then
+ call complete_group_pass(CS%pass_Dat_uv, CS%BT_Domain)
+ !$omp target update to(Datu, Datv)
+ endif
call complete_group_pass(CS%pass_force_hbt0_Cor_ref, CS%BT_Domain)
call complete_group_pass(CS%pass_eta_bt_rem, CS%BT_Domain)
+ !$omp target update to(bt_rem_u, bt_rem_v, BT_force_u, BT_force_v, Cor_ref_u, Cor_ref_v, eta_src)
+ !$omp target update if(integral_BT_cont) to(eta_IC)
+ !$omp target update if(.not.interp_eta_PF) to(eta_PF)
+ !$omp target update if(interp_eta_PF) to(eta_PF_1, d_eta_PF)
+ !$omp target update if(CS%dynamic_psurf) to(dyn_coef_eta)
+ !$omp target update if(add_uh0) to(uhbt0, vhbt0)
if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
endif
if (CS%debug) then
+ !$omp target update from(uhbt, vhbt)
call uvchksum("BT [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=0, &
unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m)
+ !$omp target update from(ubt, vbt)
call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, unscale=US%L_T_to_m_s)
+ !$omp target update from(eta)
call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS)
+ !$omp target update from(BT_force_u, BT_force_v)
call uvchksum("BT BT_force_[uv]", BT_force_u, BT_force_v, &
CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2)
if (interp_eta_PF) then
- call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS)
- call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS)
+ call hchksum(eta_PF_1, "BT eta_PF_1", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS)
+ call hchksum(d_eta_PF, "BT d_eta_PF", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS)
else
- call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS)
- call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, unscale=GV%H_to_MKS)
+ !$omp target update from(eta_PF, eta_PF_in)
+ call hchksum(eta_PF, "BT eta_PF", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS)
+ call hchksum(eta_PF_in, "BT eta_PF_in", G%HI, haloshift=0, unscale=GV%H_to_MKS)
endif
+ if (CS%linearized_BT_PV) then
+ !$omp target update from(CS%q_D)
+ call Bchksum(CS%q_D, "BT PV (q_D)", CS%debug_BT_HI, haloshift=0, symmetric=.true., unscale=US%s_to_T/GV%H_to_MKS)
+ else
+ !$omp target update from(q)
+ call Bchksum(q, "BT PV (q)", CS%debug_BT_HI, haloshift=0, symmetric=.true., unscale=US%s_to_T/GV%H_to_MKS)
+ endif
+ !$omp target update from(DCor_u, DCor_v)
+ call uvchksum("BT DCor_[uv]", DCor_u, DCor_v, G%HI, haloshift=0, &
+ symmetric=.true., omit_corners=.true., scalar_pair=.true., unscale=GV%H_to_MKS)
+ !$omp target update from(Cor_ref_u, Cor_ref_v)
call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2)
+ !$omp target update from(uhbt0, vhbt0)
call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, CS%debug_BT_HI, haloshift=0, &
unscale=US%L_to_m**2*US%s_to_T*GV%H_to_m)
if (.not. use_BT_cont) then
call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, unscale=US%L_to_m*GV%H_to_m)
endif
+ !$omp target update from(wt_u, wt_v)
call uvchksum("BT wt_[uv]", wt_u, wt_v, G%HI, haloshift=0, &
symmetric=.true., omit_corners=.true., scalar_pair=.true.)
+ !$omp target update from(CS%frhatu, CS%frhatv)
call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, haloshift=0, &
symmetric=.true., omit_corners=.true., scalar_pair=.true.)
+ !$omp target update from(visc_rem_u, visc_rem_v)
call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, &
symmetric=.true., omit_corners=.true., scalar_pair=.true.)
+ !$omp target update from(bc_accel_u, bc_accel_v)
call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, unscale=US%L_T2_to_m_s2)
+ !$omp target update from(CS%IDatu, CS%IDatv)
call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, &
unscale=GV%m_to_H, scalar_pair=.true.)
call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, &
haloshift=1, scalar_pair=.true.)
- endif
- if (CS%id_ubtdt > 0) then
- do j=js-1,je+1 ; do I=is-1,ie
- ubt_st(I,j) = ubt(I,j)
- enddo ; enddo
- endif
- if (CS%id_vbtdt > 0) then
- do J=js-1,je ; do i=is-1,ie+1
- vbt_st(i,J) = vbt(i,J)
- enddo ; enddo
+ if (apply_OBCs) then
+ call uvchksum("BT_OBC%[uv]bt_outer", CS%BT_OBC%ubt_outer, CS%BT_OBC%vbt_outer, CS%debug_BT_HI, &
+ symmetric=.true., omit_corners=.true., unscale=US%L_T_to_m_s)
+ if (allocated(CS%BT_OBC%SSH_outer_u) .and. allocated(CS%BT_OBC%SSH_outer_v)) &
+ call uvchksum("BT_OBC%SSH_outer[uv]", CS%BT_OBC%SSH_outer_u, CS%BT_OBC%SSH_outer_v, CS%debug_BT_HI, &
+ symmetric=.true., omit_corners=.true., unscale=US%Z_to_m, scalar_pair=.true.)
+ if (allocated(CS%BT_OBC%Cg_u) .and. allocated(CS%BT_OBC%Cg_v)) &
+ call uvchksum("BT_OBC%Cg_[uv]", CS%BT_OBC%Cg_u, CS%BT_OBC%Cg_v, CS%debug_BT_HI, &
+ symmetric=.true., omit_corners=.true., unscale=US%L_T_to_m_s, scalar_pair=.true.)
+ if (allocated(CS%BT_OBC%dZ_u) .and. allocated(CS%BT_OBC%dZ_v)) &
+ call uvchksum("BT_OBC%dZ_[uv]", CS%BT_OBC%dZ_u, CS%BT_OBC%dZ_v, CS%debug_BT_HI, &
+ symmetric=.true., omit_corners=.true., unscale=US%Z_to_m, scalar_pair=.true.)
+ endif
endif
if (query_averaging_enabled(CS%diag)) then
@@ -1709,9 +1880,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
endif
nfilter = ceiling(dt_filt / dtbt)
- if (nstep+nfilter==0 ) call MOM_error(FATAL, &
+ if ( nstep+nfilter<=0 ) call MOM_error(FATAL, &
"btstep: number of barotropic step (nstep+nfilter) is 0")
-
+ if ( CS%bt_limit_integral_transport .and. nstep-nfilter<=0 ) call MOM_error(FATAL, &
+ "btstep: barotropic filter steps too large (nstep-nfilter) is 0")
! Set up the normalized weights for the filtered velocity.
sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0
@@ -1734,6 +1906,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! wt_eta(n) = wt_vel(n)
! The rest should not be changed.
+ enddo
+ ! do sum reduction on CPU to preserve fp summation order (nstep+filter is small)
+ do n=1,nstep+nfilter
sum_wt_vel = sum_wt_vel + wt_vel(n) ; sum_wt_eta = sum_wt_eta + wt_eta(n)
enddo
wt_trans(nstep+nfilter+1) = 0.0 ; wt_accel(nstep+nfilter+1) = 0.0
@@ -1771,6 +1946,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
else
I_sum_wt_vel = 1.0 ; I_sum_wt_eta = 1.0 ; I_sum_wt_accel = 1.0 ; I_sum_wt_trans = 1.0
endif
+ !$omp target enter data map(to: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2)
! March the barotropic solver through all of its time steps.
call btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL_v, eta_IC, &
@@ -1782,97 +1958,102 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
LDv_avg, use_BT_cont, interp_eta_PF, find_etaav, dt, dtbt, nstep, nfilter, &
wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2, ADp, CS%BT_OBC, CS, G, MS, GV, US)
+ !$omp target exit data map(release: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2)
+
if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc)
if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
- if (find_etaav) then ; do j=js,je ; do i=is,ie
+ if (find_etaav) then ; do concurrent (j=js:je, i=is:ie)
etaav(i,j) = eta_sum(i,j) * I_sum_wt_accel
- enddo ; enddo ; endif
- do j=js-1,je+1 ; do i=is-1,ie+1 ; e_anom(i,j) = 0.0 ; enddo ; enddo
+ enddo ; endif
+ do concurrent (j=js-1:je+1, i=is-1:ie+1)
+ e_anom(i,j) = 0.0
+ enddo
if (interp_eta_PF) then
do j=js,je ; do i=is,ie
e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - &
(eta_PF_1(i,j) + 0.5*d_eta_PF(i,j)))
enddo ; enddo
else
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - eta_PF(i,j))
- enddo ; enddo
+ enddo
endif
if (apply_OBCs) then
! This block of code may be unnecessary because e_anom is only used for accelerations that
! are then recalculated at OBC points.
if (CS%BT_OBC%u_OBCs_on_PE) then ! copy back the value for u-points on the boundary.
- !GOMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
if (CS%BT_OBC%u_OBC_type(I,j) > 0) e_anom(i+1,j) = e_anom(i,j) ! OBC_DIRECTION_E
if (CS%BT_OBC%u_OBC_type(I,j) < 0) e_anom(i,j) = e_anom(i+1,j) ! OBC_DIRECTION_W
- enddo ; enddo
+ enddo
endif
if (CS%BT_OBC%v_OBCs_on_PE) then ! copy back the value for v-points on the boundary.
- !GOMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
if (CS%BT_OBC%v_OBC_type(i,J) > 0) e_anom(i,j+1) = e_anom(i,j) ! OBC_DIRECTION_N
if (CS%BT_OBC%v_OBC_type(i,J) < 0) e_anom(i,j) = e_anom(i,j+1) ! OBC_DIRECTION_S
- enddo ; enddo
+ enddo
endif
endif
! Note that it is possible that eta_out and eta_in are the same array.
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
eta_out(i,j) = eta_wtd(i,j) * I_sum_wt_eta
- enddo ; enddo
+ enddo
! Accumulator is updated at the end of every baroclinic time step.
! Harmonic analysis will not be performed of a field that is not registered.
if (associated(CS%HA_CSp) .and. find_etaav) then
- call HA_accum_FtSSH('ubt', ubt, CS%Time, G, CS%HA_CSp)
- call HA_accum_FtSSH('vbt', vbt, CS%Time, G, CS%HA_CSp)
+ call HA_accum('ubt', ubt, CS%Time, G, CS%HA_CSp)
+ call HA_accum('vbt', vbt, CS%Time, G, CS%HA_CSp)
endif
if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post)
if (G%nonblocking_updates) then
+ !$omp target update from(e_anom)
call start_group_pass(CS%pass_e_anom, G%Domain)
else
if (find_etaav) call do_group_pass(CS%pass_etaav, G%Domain)
- call do_group_pass(CS%pass_e_anom, G%Domain)
+ call do_group_pass(CS%pass_e_anom, G%Domain, omp_offload=.true.)
endif
if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post)
if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
! Find or store the weighted time-mean velocities and transports.
if (CS%answer_date < 20190101) then
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
CS%ubtav(I,j) = CS%ubtav(I,j) * I_sum_wt_trans
uhbtav(I,j) = uhbtav(I,j) * I_sum_wt_trans
ubt_wtd(I,j) = ubt_wtd(I,j) * I_sum_wt_vel
- enddo ; enddo
+ enddo
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
CS%vbtav(i,J) = CS%vbtav(i,J) * I_sum_wt_trans
vhbtav(i,J) = vhbtav(i,J) * I_sum_wt_trans
vbt_wtd(i,J) = vbt_wtd(i,J) * I_sum_wt_vel
- enddo ; enddo
+ enddo
endif
if (CS%use_filter .and. CS%linear_freq_drag) then ! Apply frequency-dependent drag
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
u_accel_bt(I,j) = u_accel_bt(I,j) - Drag_u(I,j)
- enddo ; enddo
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
v_accel_bt(i,J) = v_accel_bt(i,J) - Drag_v(i,J)
- enddo ; enddo
+ enddo
- if ((CS%id_LDu_bt > 0) .or. (associated(ADp%bt_lwd_u))) then ; do j=js,je ; do I=is-1,ie
- LDu_avg(I,j) = LDu_avg(I,j) - Drag_u(I,j)
- enddo ; enddo ; endif
- if ((CS%id_LDv_bt > 0) .or. (associated(ADp%bt_lwd_v))) then ; do J=js-1,je ; do i=is,ie
- LDv_avg(i,J) = LDv_avg(i,J) - Drag_v(i,J)
- enddo ; enddo ; endif
+ if ((CS%id_LDu_bt > 0) .or. (associated(ADp%bt_lwd_u))) then
+ do concurrent (j=js:je, I=is-1:ie)
+ LDu_avg(I,j) = LDu_avg(I,j) - Drag_u(I,j)
+ enddo
+ endif
+ if ((CS%id_LDv_bt > 0) .or. (associated(ADp%bt_lwd_v))) then
+ do concurrent (J=js-1:je, i=is:ie)
+ LDv_avg(i,J) = LDv_avg(i,J) - Drag_v(i,J)
+ enddo
+ endif
endif
if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
@@ -1881,12 +2062,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
call complete_group_pass(CS%pass_e_anom, G%Domain)
if (find_etaav) call start_group_pass(CS%pass_etaav, G%Domain)
call start_group_pass(CS%pass_ubta_uhbta, G%DoMain)
+ !$omp target update to(e_anom)
else
- call do_group_pass(CS%pass_ubta_uhbta, G%Domain)
+ call do_group_pass(CS%pass_ubta_uhbta, G%Domain, omp_offload=.true.)
endif
if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post)
if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
+ if (CS%strong_drag .and. CS%rescale_strong_drag) then
+ do j=js,je ; do I=is-1,ie
+ if (G%mask2dCu(I,j) * av_rem_u(I,j) > 0.0) &
+ u_accel_bt(I,j) = u_accel_bt(I,j) * min(bt_rem_u(I,j)**nstep / av_rem_u(I,j), 1.0)
+ enddo ; enddo
+ do J=js-1,je ; do i=is,ie
+ if (G%mask2dCv(i,J) * av_rem_v(i,J) > 0.0) &
+ v_accel_bt(i,J) = v_accel_bt(i,J) * min(bt_rem_v(i,J)**nstep / av_rem_v(i,J), 1.0)
+ enddo ; enddo
+ endif
+
! Now calculate each layer's accelerations.
call btstep_layer_accel(dt, u_accel_bt, v_accel_bt, pbce, gtot_E, gtot_W, gtot_N, gtot_S, &
e_anom, G, GV, CS, accel_layer_u, accel_layer_v)
@@ -1896,13 +2089,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
! symmetric-memory computational domain, not in the wide halo regions.
if (CS%BT_OBC%u_OBCs_on_PE) then ; do j=js,je ; do I=is-1,ie
if (CS%BT_OBC%u_OBC_type(I,j) /= 0) then
- u_accel_bt(I,j) = (ubt_wtd(I,j) - ubt_first(I,j)) / dt
+ u_accel_bt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j)) / dt
do k=1,nz ; accel_layer_u(I,j,k) = u_accel_bt(I,j) ; enddo
endif
enddo ; enddo ; endif
if (CS%BT_OBC%v_OBCs_on_PE) then ; do J=js-1,je ; do i=is,ie
if (CS%BT_OBC%v_OBC_type(i,J) /= 0) then
- v_accel_bt(i,J) = (vbt_wtd(i,J) - vbt_first(i,J)) / dt
+ v_accel_bt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J)) / dt
do k=1,nz ; accel_layer_v(i,J,k) = v_accel_bt(i,J) ; enddo
endif
enddo ; enddo ; endif
@@ -1914,8 +2107,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (query_averaging_enabled(CS%diag)) then
if (CS%gradual_BT_ICs) then
- do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo
- do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo
+ do concurrent (j=js:je, I=is-1:ie)
+ CS%ubt_IC(I,j) = ubt_wtd(I,j)
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
+ CS%vbt_IC(i,J) = vbt_wtd(i,J)
+ enddo
endif
! Calculate various time-averaged barotropic diagnostics.
@@ -1928,76 +2125,80 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (CS%id_LDv_bt > 0) call post_data(CS%id_LDv_bt, LDv_avg, CS%diag)
else ! if (CS%answer_date < 20190101) then
if (CS%id_PFu_bt > 0) then
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
PFu_avg(I,j) = PFu_avg(I,j) * I_sum_wt_accel
- enddo ; enddo
+ enddo
+ !$omp target update from(PFu_avg)
call post_data(CS%id_PFu_bt, PFu_avg, CS%diag)
endif
if (CS%id_PFv_bt > 0) then
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
PFv_avg(i,J) = PFv_avg(i,J) * I_sum_wt_accel
- enddo ; enddo
+ enddo
+ !$omp target update from(PFv_avg)
call post_data(CS%id_PFv_bt, PFv_avg, CS%diag)
endif
if (CS%id_Coru_bt > 0) then
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
Coru_avg(I,j) = Coru_avg(I,j) * I_sum_wt_accel
- enddo ; enddo
+ enddo
+ !$omp target update from(Coru_avg)
call post_data(CS%id_Coru_bt, Coru_avg, CS%diag)
endif
if (CS%id_Corv_bt > 0) then
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
Corv_avg(i,J) = Corv_avg(i,J) * I_sum_wt_accel
- enddo ; enddo
+ enddo
+ !$omp target update from(Corv_avg)
call post_data(CS%id_Corv_bt, Corv_avg, CS%diag)
endif
endif
! Diagnostics for time tendency
if (CS%id_ubtdt > 0) then
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
ubt_dt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j))*Idt
- enddo ; enddo
+ enddo
call post_data(CS%id_ubtdt, ubt_dt(IsdB:IedB,jsd:jed), CS%diag)
endif
if (CS%id_vbtdt > 0) then
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
vbt_dt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J))*Idt
- enddo ; enddo
+ enddo
call post_data(CS%id_vbtdt, vbt_dt(isd:ied,JsdB:JedB), CS%diag)
endif
! Copy decomposed barotropic accelerations to ADp
if (associated(ADp%bt_pgf_u)) then
! Note that CS%IdxCu is 0 at OBC points, so ADp%bt_pgf_u is zeroed out there.
- do k=1,nz ; do j=js,je ; do I=is-1,ie
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
ADp%bt_pgf_u(I,j,k) = PFu_avg(I,j) - &
(((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j)) - &
((pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j))) * CS%IdxCu(I,j)
- enddo ; enddo ; enddo
+ enddo
endif
if (associated(ADp%bt_pgf_v)) then
! Note that CS%IdyCv is 0 at OBC points, so ADp%bt_pgf_v is zeroed out there.
- do k=1,nz ; do J=js-1,je ; do i=is,ie
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
ADp%bt_pgf_v(i,J,k) = PFv_avg(i,J) - &
(((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1)) - &
((pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j))) * CS%IdyCv(i,J)
- enddo ; enddo ; enddo
+ enddo
endif
- if (associated(ADp%bt_cor_u)) then ; do j=js,je ; do I=is-1,ie
+ if (associated(ADp%bt_cor_u)) then ; do concurrent (j=js:je, I=is-1:ie)
ADp%bt_cor_u(I,j) = Coru_avg(I,j)
- enddo ; enddo ; endif
- if (associated(ADp%bt_cor_v)) then ; do J=js-1,je ; do i=is,ie
+ enddo ; endif
+ if (associated(ADp%bt_cor_v)) then ; do concurrent (J=js-1:je, i=is:ie)
ADp%bt_cor_v(i,J) = Corv_avg(i,J)
- enddo ; enddo ; endif
+ enddo ; endif
- if (associated(ADp%bt_lwd_u)) then ; do j=js,je ; do I=is-1,ie
+ if (associated(ADp%bt_lwd_u)) then ; do concurrent (j=js:je, I=is-1:ie)
ADp%bt_lwd_u(I,j) = LDu_avg(I,j)
- enddo ; enddo ; endif
- if (associated(ADp%bt_lwd_v)) then ; do J=js-1,je ; do i=is,ie
+ enddo ; endif
+ if (associated(ADp%bt_lwd_v)) then ; do concurrent (J=js-1:je, i=is:ie)
ADp%bt_lwd_v(i,J) = LDv_avg(i,J)
- enddo ; enddo ; endif
+ enddo ; endif
if (CS%id_ubtforce > 0) call post_data(CS%id_ubtforce, BT_force_u(IsdB:IedB,jsd:jed), CS%diag)
if (CS%id_vbtforce > 0) call post_data(CS%id_vbtforce, BT_force_v(isd:ied,JsdB:JedB), CS%diag)
@@ -2027,6 +2228,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
if (CS%id_frhatu1 > 0) call post_data(CS%id_frhatu1, CS%frhatu1, CS%diag)
if (CS%id_frhatv1 > 0) call post_data(CS%id_frhatv1, CS%frhatv1, CS%diag)
+ if (CS%id_bt_rem_u > 0) call post_data(CS%id_bt_rem_u, bt_rem_u(IsdB:IedB,jsd:jed), CS%diag)
+ if (CS%id_bt_rem_v > 0) call post_data(CS%id_bt_rem_v, bt_rem_v(isd:ied,JsdB:JedB), CS%diag)
+ if (CS%id_etaPF_anom > 0) call post_data(CS%id_etaPF_anom, e_anom(isd:ied,jsd:jed), CS%diag)
+
if (use_BT_cont) then
if (CS%id_BTC_FA_u_EE > 0) call post_data(CS%id_BTC_FA_u_EE, BT_cont%FA_u_EE, CS%diag)
if (CS%id_BTC_FA_u_E0 > 0) call post_data(CS%id_BTC_FA_u_E0, BT_cont%FA_u_E0, CS%diag)
@@ -2098,41 +2303,52 @@ 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(:,:,:)
+ if (CS%id_frhatu1 > 0) then
+ !$omp target update from(CS%frhatu)
+ CS%frhatu1(:,:,:) = CS%frhatu(:,:,:)
+ endif
+ if (CS%id_frhatv1 > 0) then
+ !$omp target update from(CS%frhatv)
+ CS%frhatv1(:,:,:) = CS%frhatv(:,:,:)
+ endif
endif
if (associated(ADp%diag_hfrac_u)) then
- do k=1,nz ; do j=js,je ; do I=is-1,ie
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
ADp%diag_hfrac_u(I,j,k) = CS%frhatu(I,j,k)
- enddo ; enddo ; enddo
+ enddo
endif
if (associated(ADp%diag_hfrac_v)) then
- do k=1,nz ; do J=js-1,je ; do i=is,ie
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
ADp%diag_hfrac_v(i,J,k) = CS%frhatv(i,J,k)
- enddo ; enddo ; enddo
+ enddo
endif
if (use_BT_cont .and. associated(ADp%diag_hu)) then
- do k=1,nz ; do j=js,je ; do I=is-1,ie
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
ADp%diag_hu(I,j,k) = BT_cont%h_u(I,j,k)
- enddo ; enddo ; enddo
+ enddo
endif
if (use_BT_cont .and. associated(ADp%diag_hv)) then
- do k=1,nz ; do J=js-1,je ; do i=is,ie
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
ADp%diag_hv(i,J,k) = BT_cont%h_v(i,J,k)
- enddo ; enddo ; enddo
+ enddo
endif
if (associated(ADp%visc_rem_u)) then
- do k=1,nz ; do j=js,je ; do I=is-1,ie
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
ADp%visc_rem_u(I,j,k) = visc_rem_u(I,j,k)
- enddo ; enddo ; enddo
+ enddo
endif
if (associated(ADp%visc_rem_v)) then
- do k=1,nz ; do J=js-1,je ; do i=is,ie
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
ADp%visc_rem_v(i,J,k) = visc_rem_v(i,J,k)
- enddo ; enddo ; enddo
+ enddo
endif
if (G%nonblocking_updates) then
@@ -2140,6 +2356,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce,
call complete_group_pass(CS%pass_ubta_uhbta, G%Domain)
endif
+ !$omp target exit data &
+ !$omp map(release: ubt_Cor, vbt_Cor, wt_u, wt_v, av_rem_u, av_rem_v, ubt_wtd, vbt_wtd, Coru_avg, &
+ !$omp Corv_avg, LDu_avg, LDv_avg, e_anom, q, ubt, vbt, bt_rem_u, bt_rem_v, BT_force_u, &
+ !$omp BT_force_v, u_accel_bt, v_accel_bt, uhbt, vhbt, uhbt0, vhbt0, &
+ !$omp Cor_ref_u, Cor_ref_v, DCor_u, DCor_v, &
+ !$omp Datu, Datv, f_4_u, f_4_v, eta, eta_sum, eta_wtd, eta_IC, eta_PF, eta_PF_1, &
+ !$omp d_eta_PF, gtot_E, gtot_W, gtot_N, gtot_S, eta_src, dyn_coef_eta, BTCL_u, BTCL_v, &
+ !$omp PFu_avg, PFv_avg)
+
deallocate(wt_vel, wt_eta, wt_trans, wt_accel, wt_accel2)
end subroutine btstep
@@ -2331,9 +2556,9 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL
PFu, & ! The zonal pressure force acceleration [L T-2 ~> m s-2]
Cor_u, & ! The zonal Coriolis acceleration [L T-2 ~> m s-2]
ubt_int, & ! The running time integral of ubt over the time steps [L ~> m]
- uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3]
+ uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3 or kg]
ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m]
- uhbt_int_prev ! Previous value of time-integrated transport stored for integral_BT_cont [L2 H ~> m3]
+ uhbt_int_prev ! Previous value of time-integrated transport stored for integral_BT_cont [H L2 ~> m3 or kg]
real, dimension(SZIW_(CS),SZJBW_(CS)) :: &
vhbt, & ! The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1]
vbt_prev, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]
@@ -2341,13 +2566,16 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL
PFv, & ! The meridional pressure force acceleration [L T-2 ~> m s-2]
Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2]
vbt_int, & ! The running time integral of vbt over the time steps [L ~> m]
- vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3]
+ vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3 or kg]
vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m]
- vhbt_int_prev ! Previous value of time-integrated transport stored for integral_BT_cont [L2 H ~> m3]
+ vhbt_int_prev ! Previous value of time-integrated transport stored for integral_BT_cont [H L2 ~> m3 or kg]
real, target, dimension(SZIW_(CS),SZJW_(CS)) :: &
eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta
real, dimension(SZIW_(CS),SZJW_(CS)) :: &
- p_surf_dyn !< A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2]
+ p_surf_dyn, & !< A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2]
+ cfl_ltd_vol !< The volume available after removing sinks used to limit uhbt_int and vhbt_int [H L2 ~> m3 or kg]
+ real, dimension(SZI_(G),SZJ_(G)) :: &
+ eta_anom_PF ! The eta anomalies used to find the pressure force anomalies [H ~> m or kg m-2]
real :: wt_end ! The weighting of the final value of eta_PF [nondim]
real :: Instep ! The inverse of the number of barotropic time steps to take [nondim]
real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans [nondim]
@@ -2362,6 +2590,9 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL
real :: be_proj ! The fractional amount by which velocities are projected
! when project_velocity is true [nondim]. For now be_proj is set
! to equal bebt, as they have similar roles and meanings.
+ real :: eta_cor_multiplier ! Increases the rate of applying CS%eta_cor so that the mass
+ ! source is all used up by the beginning of the filtering [nondim]
+ real :: eta_acc ! Change due to divergence of mass transport [H ~> m or kg m-2]
logical :: do_hifreq_output ! If true, output occurs every barotropic step.
logical :: do_ave ! If true, diagnostics are enabled on this step.
logical :: evolving_face_areas
@@ -2375,7 +2606,9 @@ 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
+ logical :: submerged(SZIW_(CS),SZJW_(CS)), eta_is_submerged
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
@@ -2383,9 +2616,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)
@@ -2415,52 +2649,89 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL
do_hifreq_output = .false.
if ((CS%id_ubt_hifreq > 0) .or. (CS%id_vbt_hifreq > 0) .or. &
- (CS%id_eta_hifreq > 0) .or. (CS%id_eta_pred_hifreq > 0) .or. &
+ (CS%id_eta_hifreq > 0) .or. (CS%id_eta_pred_hifreq > 0) .or. (CS%id_etaPF_hifreq > 0) .or. &
(CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) &
do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in)
if (do_hifreq_output) then
- time_bt_start = time_end_in - real_to_time(US%T_to_s*dt)
+ time_bt_start = time_end_in - real_to_time(dt, unscale=US%T_to_s)
dtbt_diag = dt/(nstep+nfilter) ! Note that this is not dtbt.
endif
+ !$omp target enter data &
+ !$omp map(alloc: uhbt, vhbt, ubt_prev, vbt_prev, ubt_trans, vbt_trans, PFu, PFv, Cor_u, Cor_v, &
+ !$omp p_surf_dyn, submerged)
+
! Zero out the arrays for various time-averaged quantities.
if (find_etaav) then
- !$OMP do
- do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
+ do concurrent (j=jsvf-1:jevf+1, i=isvf-1:ievf+1)
eta_sum(i,j) = 0.0 ; eta_wtd(i,j) = 0.0
- enddo ; enddo
+ enddo
else
- !$OMP do
- do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
+ do concurrent (j=jsvf-1:jevf+1, i=isvf-1:ievf+1)
eta_wtd(i,j) = 0.0
- enddo ; enddo
+ enddo
endif
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
CS%ubtav(I,j) = 0.0 ; uhbtav(I,j) = 0.0
PFu_avg(I,j) = 0.0 ; Coru_avg(I,j) = 0.0
LDu_avg(I,j) = 0.0 ; ubt_wtd(I,j) = 0.0
- enddo ; enddo
- !$OMP do
- do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf
+ enddo
+ do concurrent (j=jsvf-1:jevf+1, I=isvf-1:ievf)
ubt_trans(I,j) = 0.0
- enddo ; enddo
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
CS%vbtav(i,J) = 0.0 ; vhbtav(i,J) = 0.0
PFv_avg(i,J) = 0.0 ; Corv_avg(i,J) = 0.0
LDv_avg(i,J) = 0.0 ; vbt_wtd(i,J) = 0.0
- enddo ; enddo
- !$OMP do
- do J=jsvf-1,jevf ; do i=isvf-1,ievf+1
+ enddo
+ do concurrent (J=jsvf-1:jevf, i=isvf-1:ievf+1)
vbt_trans(i,J) = 0.0
- enddo ; enddo
+ enddo
+
if (integral_BT_cont) then
- ubt_int(:,:) = 0.0 ; uhbt_int(:,:) = 0.0
- vbt_int(:,:) = 0.0 ; vhbt_int(:,:) = 0.0
+ !$omp target enter data map(alloc: ubt_int, uhbt_int, vbt_int, vhbt_int, cfl_ltd_vol)
+
+ do concurrent (j=CS%jsdw:CS%jedw, I=CS%isdw-1:CS%iedw)
+ ubt_int(I,j) = 0.
+ uhbt_int(I,j) = 0.
+ enddo
+
+ do concurrent (J=CS%jsdw-1:CS%jedw, i=CS%isdw:CS%iedw)
+ vbt_int(i,J) = 0.
+ vhbt_int(i,J) = 0.
+ enddo
+
+ do concurrent (j=CS%jsdw:CS%jedw, i=CS%isdw:CS%iedw)
+ cfl_ltd_vol(i,j) = huge(GV%Z_to_H)
+ enddo
endif
- p_surf_dyn(:,:) = 0.0
+ do concurrent (j=CS%jsdw:CS%jedw, i=CS%isdw:CS%iedw)
+ p_surf_dyn(i,j) = 0.0
+ enddo
+
+ if (CS%bt_limit_integral_transport) then
+ !$omp target update from(eta_IC)
+ ! Issue warnings if there are unphysical values of the initial sea surface height or total water column mass.
+ if (GV%Boussinesq) then
+ do j=js,je ; do i=is,ie
+ if ((eta_IC(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then
+ write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), &
+ -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset
+ call MOM_error(FATAL, "btstep: eta_IC starts below bathyT: "//trim(mesg), all_print=.true.)
+ endif
+ enddo ; enddo
+ else
+ do j=js,je ; do i=is,ie
+ if ((eta_IC(i,j) < 0.0) .and. (G%mask2dT(i,j) > 0.0)) then
+ write(mesg,'(" at ", ES12.4, ES12.4, i7, i7)') &
+ G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset
+ call MOM_error(FATAL, "btstep: negative eta_IC at start of a non-Boussinesq barotropic solver "//&
+ trim(mesg), all_print=.true.)
+ endif
+ enddo ; enddo
+ endif
+ endif
! Set up the group pass used for halo updates within the barotropic time stepping loops.
call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain)
@@ -2480,7 +2751,7 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL
! Update the range of valid points, either by doing a halo update or by marching inward.
if ((iev - stencil < ie) .or. (jev - stencil < je)) then
if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc)
- call do_group_pass(CS%pass_eta_ubt, CS%BT_Domain, clock=id_clock_pass_step)
+ call do_group_pass(CS%pass_eta_ubt, CS%BT_Domain, clock=id_clock_pass_step, omp_offload=.true.)
isv = isvf ; iev = ievf ; jsv = jsvf ; jev = jevf
if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc)
else
@@ -2488,15 +2759,22 @@ 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 concurrent (j=jsv:jev, I=isv-2:iev+1)
+ ubt_prev(I,j) = ubt(I,j)
+ enddo
+
+ do concurrent (J=jsv-2:jev+1, i=isv:iev)
+ vbt_prev(i,J) = vbt(i,J)
+ enddo
+
if (integral_BT_cont) then
- !$OMP parallel do default(shared)
- do j=jsv-1,jev+1 ; do I=isv-2,iev+1
+ do concurrent (j=jsv-1:jev+1, I=isv-2:iev+1)
uhbt_int_prev(I,j) = uhbt_int(I,j)
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=jsv-2,jev+1 ; do i=isv-1,iev+1
+ enddo
+ do concurrent (J=jsv-2:jev+1, i=isv-1:iev+1)
vhbt_int_prev(i,J) = vhbt_int(i,J)
- enddo ; enddo
+ enddo
endif
! Do a predictor step update of eta
@@ -2515,10 +2793,9 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL
if (interp_eta_PF) then
! Interpolate the effective surface pressure in time
wt_end = n*Instep ! This could be (n-0.5)*Instep.
- !$OMP parallel do default(shared)
- do j=jsv-1,jev+1 ; do i=isv-1,iev+1
+ do concurrent (j=jsv-1:jev+1, i=isv-1:iev+1)
eta_PF(i,j) = eta_PF_1(i,j) + wt_end*d_eta_PF(i,j)
- enddo ; enddo
+ enddo
endif
v_first = (MOD(n+G%first_direction,2)==1)
@@ -2543,228 +2820,290 @@ 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
! Determine the transports based on the updated velocities when no OBCs are applied
if (integral_BT_cont) then
- !$OMP do schedule(static)
- do j=jsv,jev ; do I=isv-1,iev
+ if (CS%bt_limit_integral_transport) then
+ ! Calculate the volume that could be used for divergent transport to use for a limter. This applies to
+ ! uhbt_int and vhbt_int at each BT step. It does not allow for temporary flooding during the BT cycling.
+ ! Only the sink is accounted for: if diverent motion occurs at the beginning of the BT cycling but the volume
+ ! was due only to a +ve source being applied gradually, then the instantaneous eta could drop below the bottom.
+ if (GV%Boussinesq) then
+ do concurrent (j=jsv:jev, i=isv:iev)
+ cfl_ltd_vol(i,j) = ( CS%maxCFL_BT_cont * G%areaT(i,j) ) * &
+ max( 0., ( GV%Z_to_H*G%bathyT(i,j) + eta_IC(i,j) ) + nstep * min( 0., eta_src(i,j) ) )
+ enddo
+ else
+ do concurrent (j=jsv:jev, i=isv:iev)
+ cfl_ltd_vol(i,j) = ( CS%maxCFL_BT_cont * G%areaT(i,j) ) * &
+ max( 0., eta_IC(i,j) + nstep * min( 0., eta_src(i,j) ) )
+ enddo
+ endif
+ endif
+
+ do concurrent (j=jsv:jev, I=isv-1:iev)
ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*ubt_prev(I,j)
ubt_int_prev(I,j) = ubt_int(I,j) ! Store the previous integrated velocity so it can be reset by at OBC points
ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j)
uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j)
+ uhbt_int(I,j) = max( -cfl_ltd_vol(i+1,j), min( uhbt_int(I,j), cfl_ltd_vol(i,j) ) )
! Estimate the mass flux within a single timestep to take the filtered average.
uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt
- enddo ; enddo
- !$OMP end do nowait
- !$OMP do schedule(static)
- do J=jsv-1,jev ; do i=isv,iev
+ enddo
+ do concurrent (J=jsv-1:jev, i=isv:iev)
vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vbt_prev(i,J)
vbt_int_prev(i,J) = vbt_int(i,J) ! Store the previous integrated velocity so it can be reset by at OBC points
vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J)
vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J)
+ vhbt_int(i,J) = max( -cfl_ltd_vol(i,j+1), min( vhbt_int(i,J), cfl_ltd_vol(i,j) ) )
! Estimate the mass flux within a single timestep to take the filtered average.
vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt
- enddo ; enddo
+ enddo
elseif (use_BT_cont) then
- !$OMP do schedule(static)
- do j=jsv,jev ; do I=isv-1,iev
+ do concurrent (j=jsv:jev, I=isv-1:iev)
ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*ubt_prev(I,j)
uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j)
- enddo ; enddo
- !$OMP end do nowait
- !$OMP do schedule(static)
- do J=jsv-1,jev ; do i=isv,iev
+ enddo
+ do concurrent (J=jsv-1:jev, i=isv:iev)
vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vbt_prev(i,J)
vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J)
- enddo ; enddo
+ enddo
else
- !$OMP do schedule(static)
- do j=jsv,jev ; do I=isv-1,iev
+ do concurrent (j=jsv:jev, I=isv-1:iev)
ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*ubt_prev(I,j)
uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j)
- enddo ; enddo
- !$OMP end do nowait
- !$OMP do schedule(static)
- do J=jsv-1,jev ; do i=isv,iev
+ enddo
+ do concurrent (J=jsv-1:jev, i=isv:iev)
vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vbt_prev(i,J)
vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J)
- enddo ; enddo
+ enddo
endif
! This might need to be moved outside of the OMP do loop directives.
if (CS%debug_bt) then
- write(mesg,'("BT vel update ",I4)') n
- call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%L_T_to_m_s*US%s_to_T)
- call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%L_T_to_m_s*US%s_to_T)
- call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%L_T_to_m_s*US%s_to_T)
- call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, &
- haloshift=iev-ie, scalar_pair=.true.)
- call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%L_T_to_m_s)
- call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%L_T_to_m_s)
- call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m)
- if (integral_BT_cont) &
- call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%L_to_m**2*GV%H_to_m)
+ write(mesg,'("BT vel update ",I0)') n
+ debug_halo = 0 ; if (CS%debug_wide_halos) debug_halo = iev - ie
+ !$omp target update from(PFu, PFv)
+ 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)
+ !$omp target update from(Cor_u, Cor_v)
+ 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)
+ !$omp target update from(BT_force_u, BT_force_v)
+ 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)
+ !$omp target update from(BT_rem_u, BT_rem_v)
+ 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.)
+ !$omp target update from(ubt, vbt)
+ call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=debug_halo, &
+ symmetric=.true., unscale=US%L_T_to_m_s)
+ !$omp target update from(ubt_trans, vbt_trans)
+ 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)
+ !$omp target update from(uhbt, vhbt)
+ 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) then
+ !$omp target update from(uhbt_int, vhbt_int)
+ 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
endif
! Apply open boundary condition considerations to revise the updated velocities and transports.
if (CS%BT_OBC%u_OBCs_on_PE) then
- !$OMP single
+ !$omp target update from(ubt, uhbt, ubt_trans, eta, SpV_col_avg, ubt_prev, Datu, BTCL_u, uhbt0)
call apply_u_velocity_OBCs(ubt, uhbt, ubt_trans, eta, SpV_col_avg, ubt_prev, BT_OBC, &
G, MS, GV, US, CS, iev-ie, dtbt, CS%bebt, use_BT_cont, integral_BT_cont, n*dtbt, &
Datu, BTCL_u, uhbt0, ubt_int, ubt_int_prev, uhbt_int, uhbt_int_prev)
- !$OMP end single
+ !$omp target update to(ubt, uhbt, ubt_trans)
endif
if (CS%BT_OBC%v_OBCs_on_PE) then
- !$OMP single
+ !$omp target update from(vbt, vhbt, vbt_trans, eta, SpV_col_avg, vbt_prev, Datv, BTCL_v, vhbt0)
call apply_v_velocity_OBCs(vbt, vhbt, vbt_trans, eta, SpV_col_avg, vbt_prev, BT_OBC, &
G, MS, GV, US, CS, iev-ie, dtbt, CS%bebt, use_BT_cont, integral_BT_cont, n*dtbt, &
Datv, BTCL_v, vhbt0, vbt_int, vbt_int_prev, vhbt_int, vhbt_int_prev)
- !$OMP end single
+ !$omp target update to(vbt, vhbt, vbt_trans)
endif
! Contribute to the running sums of the transports and velocities.
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
CS%ubtav(I,j) = CS%ubtav(I,j) + wt_trans(n) * ubt_trans(I,j)
uhbtav(I,j) = uhbtav(I,j) + wt_trans(n) * uhbt(I,j)
ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j)
- enddo ; enddo
- !$OMP end do nowait
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
CS%vbtav(i,J) = CS%vbtav(i,J) + wt_trans(n) * vbt_trans(i,J)
vhbtav(i,J) = vhbtav(i,J) + wt_trans(n) * vhbt(i,J)
vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
if (CS%debug_bt) then
- call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m)
+ 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.
if (integral_BT_cont) then
- !$OMP do
- do j=jsv,jev ; do i=isv,iev
- eta(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT_OBCmask(i,j) * &
+ eta_cor_multiplier = n
+ if ( CS%bt_adjust_src_for_filter ) then
+ if ( nstep > nfilter ) then
+ eta_cor_multiplier = min(nstep - nfilter, n) * nstep / real(nstep - nfilter)
+ else
+ eta_cor_multiplier = nstep
+ endif
+ endif
+
+ eta_is_submerged = .false.
+ do concurrent (j=jsv:jev, i=isv:iev) DO_LOCALITY(reduce(.or.: eta_is_submerged))
+ eta(i,j) = (eta_IC(i,j) + eta_cor_multiplier * eta_src(i,j)) + CS%IareaT_OBCmask(i,j) * &
((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J)))
+ ! eta_acc contains the magnitude of the largest term in the above expression which
+ ! will be used to estimate a bound for round off when comparing to the bottom depth
+ eta_acc = abs( CS%IareaT_OBCmask(i,j) * &
+ ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) )
+ eta_acc = max( eta_acc, abs( eta_cor_multiplier*eta_src(i,j) ), abs( eta_IC(i,j) ) )
+ if ( G%mask2dT(i,j) * ( eta(i,j) + GV%Z_to_H*G%bathyT(i,j) ) > &
+ -G%mask2dT(i,j) * eta_acc * epsilon(eta_acc) * 2. ) &
+ eta(i,j) = max( eta(i,j), -GV%Z_to_H*G%bathyT(i,j) )
eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n)
- enddo ; enddo
+
+ submerged(i,j) = eta(i,j) < -GV%Z_to_H*G%bathyT(i,j) .and. G%mask2dT(i,j) > 0.0
+ eta_is_submerged = submerged(i,j)
+ enddo
+
+ if (eta_is_submerged) then
+ !$omp target update from(submerged)
+ do j=jsv,jev ; do i=isv,iev ; if (submerged(i,j)) then
+ write(mesg,'(ES24.16, " vs. ", ES24.16, " at ", ES12.4, ES12.4, i7, i7)') &
+ GV%H_to_m*eta(i,j), -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), &
+ i + G%HI%idg_offset, j + G%HI%jdg_offset
+ if (CS%bt_limit_integral_transport) &
+ call MOM_error(FATAL, "btstep: eta has dropped below bathyT: " // trim(mesg))
+ endif ; enddo ; enddo
+ endif
else
- !$OMP do
- do j=jsv,jev ; do i=isv,iev
+ do concurrent (j=jsv:jev, i=isv:iev)
eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT_OBCmask(i,j)) * &
((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J)))
eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n)
- enddo ; enddo
+ enddo
endif
if (CS%debug_bt) then
- write(mesg,'("BT step ",I4)') n
- call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, &
- unscale=US%L_T_to_m_s)
- call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, unscale=GV%H_to_MKS)
+ write(mesg,'("BT step ",I0)') n
+ !$omp target update from(ubt, vbt)
+ call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=debug_halo, &
+ symmetric=.true., unscale=US%L_T_to_m_s)
+ !$omp target update from(eta)
+ 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.
+ ! Issue warnings if there are unphysical values of the sea surface height
+ ! or total water column mass.
+ eta_is_submerged = .false.
if (GV%Boussinesq) then
- do j=js,je ; do i=is,ie
- if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then
- write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), &
- -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset
+ do concurrent (j=js:je, i=is:ie) DO_LOCALITY(reduce(.or.: eta_is_submerged))
+ submerged(i,j) = eta(i,j) < -GV%Z_to_H*G%bathyT(i,j) .and. G%mask2dT(i,j) > 0.0
+ eta_is_submerged = submerged(i,j)
+ enddo
+
+ if (eta_is_submerged) then
+ !$omp target update from(submerged)
+ do j=js,je ; do i=is,ie ; if (submerged(i,j)) then
+ write(mesg,'(ES24.16, " vs. ", ES24.16, " at ", ES12.4, ES12.4, i7, i7)') &
+ GV%H_to_m*eta(i,j), -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), &
+ i + G%HI%idg_offset, j + G%HI%jdg_offset
+
+ if (CS%bt_limit_integral_transport) &
+ call MOM_error(FATAL, "btstep: eta has dropped below bathyT: "//trim(mesg))
+
if (err_count < 2) &
call MOM_error(WARNING, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.)
err_count = err_count + 1
- endif
- enddo ; enddo
+ endif ; enddo ; enddo
+ endif
else
- do j=js,je ; do i=is,ie
- if (eta(i,j) < 0.0) then
+ do concurrent (j=js:je, i=is:ie) DO_LOCALITY(reduce(.or.: eta_is_submerged))
+ submerged(i,j) = eta(i,j) < 0.0 .and. G%mask2dT(i,j) > 0.0
+ eta_is_submerged = submerged(i,j)
+ enddo
+
+ if (eta_is_submerged) then
+ !$omp target update from(submerged)
+
+ do j=js,je ; do i=is,ie ; if (submerged(i,j)) then
write(mesg,'(" at ", ES12.4, ES12.4, i7, i7)') &
G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset
+
+ if (CS%bt_limit_integral_transport) &
+ call MOM_error(FATAL, "btstep: negative eta in a non-Boussinesq barotropic solver "//trim(mesg))
+
if (err_count < 2) &
call MOM_error(WARNING, "btstep: negative eta in a non-Boussinesq barotropic solver "//&
trim(mesg), all_print=.true.)
+
err_count = err_count + 1
- endif
- enddo ; enddo
+ endif ; enddo ; enddo
+ endif
endif
! Accumulate some diagnostics of time-averaged barotropic accelerations.
if (do_ave) then
if ((CS%id_PFu_bt > 0) .or. associated(ADp%bt_pgf_u)) then
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
PFu_avg(I,j) = PFu_avg(I,j) + wt_accel2(n) * PFu(I,j)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
if ((CS%id_PFv_bt > 0) .or. associated(ADp%bt_pgf_v)) then
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
PFv_avg(i,J) = PFv_avg(i,J) + wt_accel2(n) * PFv(i,J)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
if ((CS%id_Coru_bt > 0) .or. associated(ADp%bt_cor_u)) then
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
Coru_avg(I,j) = Coru_avg(I,j) + wt_accel2(n) * Cor_u(I,j)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
if ((CS%id_Corv_bt > 0) .or. associated(ADp%bt_cor_v)) then
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
Corv_avg(i,J) = Corv_avg(i,J) + wt_accel2(n) * Cor_v(i,J)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
if (CS%linear_wave_drag) then
if ((CS%id_LDu_bt > 0) .or. (associated(ADp%bt_lwd_u))) then
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
LDu_avg(I,j) = LDu_avg(I,j) - wt_accel2(n) * (ubt(I,j) * Rayleigh_u(I,j))
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
if ((CS%id_LDv_bt > 0) .or. (associated(ADp%bt_lwd_v))) then
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
LDv_avg(i,J) = LDv_avg(i,J) - wt_accel2(n) * (vbt(i,J) * Rayleigh_v(i,J))
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
endif
endif
@@ -2772,11 +3111,23 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL
if (do_hifreq_output) then
! Note that this compresses the time so that all of the timesteps, including those in the
! extra timesteps for filtering, fit within dt.
- time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt_diag)
+ time_step_end = time_bt_start + real_to_time(n*dtbt_diag, unscale=US%T_to_s)
call enable_averages(dtbt, time_step_end, CS%diag)
if (CS%id_ubt_hifreq > 0) call post_data(CS%id_ubt_hifreq, ubt(IsdB:IedB,jsd:jed), CS%diag)
if (CS%id_vbt_hifreq > 0) call post_data(CS%id_vbt_hifreq, vbt(isd:ied,JsdB:JedB), CS%diag)
if (CS%id_eta_hifreq > 0) call post_data(CS%id_eta_hifreq, eta(isd:ied,jsd:jed), CS%diag)
+ if (CS%id_etaPF_hifreq > 0) then
+ if (CS%BT_project_velocity) then
+ do j=js,je ; do i=is,ie
+ eta_anom_PF(i,j) = eta(i,j) - eta_PF(i,j)
+ enddo ; enddo
+ else
+ do j=js,je ; do i=is,ie
+ eta_anom_PF(i,j) = eta_pred(i,j) - eta_PF(i,j)
+ enddo ; enddo
+ endif
+ call post_data(CS%id_etaPF_hifreq, eta_anom_PF(isd:ied,jsd:jed), CS%diag)
+ endif
if (CS%id_uhbt_hifreq > 0) call post_data(CS%id_uhbt_hifreq, uhbt(IsdB:IedB,jsd:jed), CS%diag)
if (CS%id_vhbt_hifreq > 0) call post_data(CS%id_vhbt_hifreq, vhbt(isd:ied,JsdB:JedB), CS%diag)
if (CS%BT_project_velocity) then
@@ -2788,6 +3139,13 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL
endif
enddo ! end of do n=1,ntimestep
+ !$omp target exit data &
+ !$omp map(release: uhbt, vhbt, ubt_prev, vbt_prev, ubt_trans, vbt_trans, PFu, PFv, Cor_u, Cor_v, &
+ !$omp p_surf_dyn, submerged)
+
+ !$omp target exit data map(delete: ubt_int, uhbt_int, vbt_int, vhbt_int, cfl_ltd_vol) &
+ !$omp if (integral_BT_cont)
+
! Reset the time information in the diag type.
if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, CS%diag)
@@ -2822,39 +3180,35 @@ subroutine btstep_find_Cor(q, DCor_u, DCor_v, f_4_u, f_4_v, isvf, ievf, jsvf, je
integer, intent(in) :: jsvf !< The starting j-index of the largest valid range for tracer points
integer, intent(in) :: jevf !< The ending j-index of the largest valid range for tracer points
- real :: C1_3 ! One third [nondim]
+ ! real :: C1_3 ! One third [nondim]
integer :: i, j
if (CS%Sadourny) then
- !$OMP parallel do default(shared)
- do J=jsvf-1,jevf ; do i=isvf-1,ievf+1
+ do concurrent (J=jsvf-1:jevf, i=isvf-1:ievf+1)
f_4_v(1,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j) * q(I-1,J)
f_4_v(2,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j) * q(I,J)
f_4_v(4,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j+1) * q(I,J)
f_4_v(3,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j+1) * q(I-1,J)
- enddo ; enddo
- !$OMP parallel do default(shared)
- do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf
+ enddo
+ do concurrent (j=jsvf-1:jevf+1, I=isvf-1:ievf)
f_4_u(4,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J) * q(I,J)
f_4_u(3,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J) * q(I,J)
f_4_u(1,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J-1) * q(I,J-1)
f_4_u(2,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J-1) * q(I,J-1)
- enddo ; enddo
+ enddo
else !### if (CS%answer_date < 20250601) then ! Uncomment this later.
- !$OMP parallel do default(shared)
- do J=jsvf-1,jevf ; do i=isvf-1,ievf+1
+ do concurrent (J=jsvf-1:jevf, i=isvf-1:ievf+1)
f_4_v(1,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j) * ((q(I,J) + q(I-1,J-1)) + q(I-1,J)) / 3.0
f_4_v(2,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j) * (q(I,J) + (q(I-1,J) + q(I,J-1))) / 3.0
f_4_v(4,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j+1) * (q(I,J) + (q(I-1,J) + q(I,J+1))) / 3.0
f_4_v(3,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j+1) * ((q(I,J) + q(I-1,J+1)) + q(I-1,J)) / 3.0
- enddo ; enddo
- !$OMP parallel do default(shared)
- do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf
+ enddo
+ do concurrent (j=jsvf-1:jevf+1, I=isvf-1:ievf)
f_4_u(4,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J) * (q(I,J) + (q(I+1,J) + q(I,J-1))) / 3.0
f_4_u(3,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J) * (q(I,J) + (q(I-1,J) + q(I,J-1))) / 3.0
f_4_u(1,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J-1) * ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) / 3.0
f_4_u(2,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J-1) * ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) / 3.0
- enddo ; enddo
+ enddo
! else
! C1_3 = 1.0 / 3.0
! !$OMP parallel do default(shared)
@@ -2891,7 +3245,7 @@ subroutine truncate_velocities(ubt, vbt, dt, G, CS, isv, iev, jsv, jev)
integer :: i, j
if (CS%clip_velocity) then
- do j=jsv,jev ; do I=isv-1,iev
+ do concurrent (j=jsv:jev, I=isv-1:iev)
if ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then
! Add some error reporting later.
ubt(I,j) = (-0.95*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j)))
@@ -2899,8 +3253,8 @@ subroutine truncate_velocities(ubt, vbt, dt, G, CS, isv, iev, jsv, jev)
! Add some error reporting later.
ubt(I,j) = (0.95*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j)))
endif
- enddo ; enddo
- do J=jsv-1,jev ; do i=isv,iev
+ enddo
+ do concurrent (J=jsv-1:jev, i=isv:iev)
if ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then
! Add some error reporting later.
vbt(i,J) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J)))
@@ -2908,7 +3262,7 @@ subroutine truncate_velocities(ubt, vbt, dt, G, CS, isv, iev, jsv, jev)
! Add some error reporting later.
vbt(i,J) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J)))
endif
- enddo ; enddo
+ enddo
endif
end subroutine truncate_velocities
@@ -2961,9 +3315,9 @@ subroutine btloop_eta_predictor(n, dtbt, ubt, vbt, eta, ubt_int, vbt_int, uhbt,
real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
vhbt !< The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1].
real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
- uhbt_int !< The running time integral of uhbt over the time steps [H L2 ~> m3].
+ uhbt_int !< The running time integral of uhbt over the time steps [H L2 ~> m3 or kg].
real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
- vhbt_int !< The running time integral of vhbt over the time steps [H L2 ~> m3].
+ vhbt_int !< The running time integral of vhbt over the time steps [H L2 ~> m3 or kg].
real, target, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: &
eta_pred !< A predictor value of eta [H ~> m or kg m-2] like eta.
integer, intent(in) :: isv !< The starting i-index of eta_pred to calculate
@@ -2978,47 +3332,37 @@ subroutine btloop_eta_predictor(n, dtbt, ubt, vbt, eta, ubt_int, vbt_int, uhbt,
integer :: i, j
- !$OMP parallel default(shared)
if (integral_BT_cont) then
- !$OMP do
- do j=jsv-1,jev+1 ; do I=isv-2,iev+1
+ do concurrent (j=jsv-1:jev+1, I=isv-2:iev+1)
uhbt_int(I,j) = find_uhbt(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j)
- enddo ; enddo
- !$OMP end do nowait
- !$OMP do
- do J=jsv-2,jev+1 ; do i=isv-1,iev+1
+ enddo
+ do concurrent (J=jsv-2:jev+1, i=isv-1:iev+1)
vhbt_int(i,J) = find_vhbt(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J)
- enddo ; enddo
- !$OMP do
- do j=jsv-1,jev+1 ; do i=isv-1,iev+1
+ enddo
+ do concurrent (j=jsv-1:jev+1, i=isv-1:iev+1)
eta_pred(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT_OBCmask(i,j) * &
((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J)))
- enddo ; enddo
+ enddo
elseif (use_BT_cont) then
- !$OMP do
- do j=jsv-1,jev+1 ; do I=isv-2,iev+1
+ do concurrent (j=jsv-1:jev+1, I=isv-2:iev+1)
uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j)
- enddo ; enddo
- !$OMP do
- do J=jsv-2,jev+1 ; do i=isv-1,iev+1
+ enddo
+ do concurrent (J=jsv-2:jev+1, i=isv-1:iev+1)
vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J)) + vhbt0(i,J)
- enddo ; enddo
- !$OMP do
- do j=jsv-1,jev+1 ; do i=isv-1,iev+1
+ enddo
+ do concurrent (j=jsv-1:jev+1, i=isv-1:iev+1)
eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT_OBCmask(i,j)) * &
((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J)))
- enddo ; enddo
+ enddo
else
- !$OMP do
- do j=jsv-1,jev+1 ; do i=isv-1,iev+1
+ do concurrent (j=jsv-1:jev+1, i=isv-1:iev+1)
eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT_OBCmask(i,j)) * &
(((Datu(I-1,j)*ubt(I-1,j) + uhbt0(I-1,j)) - &
(Datu(I,j)*ubt(I,j) + uhbt0(I,j))) + &
((Datv(i,J-1)*vbt(i,J-1) + vhbt0(i,J-1)) - &
(Datv(i,J)*vbt(i,J) + vhbt0(i,J))))
- enddo ; enddo
+ enddo
endif
- !$OMP end parallel
end subroutine btloop_eta_predictor
@@ -3084,28 +3428,22 @@ subroutine btloop_find_PF(PFu, PFv, isv, iev, jsv, jev, eta_PF_BT, eta_PF, &
is_v = isv ; ie_v = iev ; js_u = jsv-1 ; je_u = jev+1
endif
- !$OMP do schedule(static)
- do j=js_u,je_u ; do I=isv-1,iev
+ do concurrent (j=js_u:je_u, I=isv-1:iev)
PFu(I,j) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j)) - &
((eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j))) * &
dgeo_de * CS%IdxCu(I,j)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
- !$OMP do schedule(static)
- do J=jsv-1,jev ; do i=is_v,ie_v
+ do concurrent (J=jsv-1:jev, i=is_v:ie_v)
PFv(i,J) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j)) - &
((eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1))) * &
dgeo_de * CS%IdyCv(i,J)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
if (find_etaav .and. (abs(wt_accel2_n) > 0.0)) then
- !$OMP do
- do j=G%jsc,G%jec ; do i=G%isc,G%iec
+ do concurrent (j=G%jsc:G%jec, i=G%isc:G%iec)
eta_sum(i,j) = eta_sum(i,j) + wt_accel2_n * eta_PF_BT(i,j)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
end subroutine btloop_find_PF
@@ -3149,28 +3487,23 @@ subroutine btloop_add_dyn_PF(PFu, PFv, eta_pred, eta, dyn_coef_eta, p_surf_dyn,
endif
! Use the change in eta to estimate the flow divergence and dynamic pressure.
- !$OMP do
- do j=jsv-1,jev+1 ; do i=isv-1,iev+1
+ do concurrent (j=jsv-1:jev+1, i=isv-1:iev+1)
p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j))
- enddo ; enddo
+ enddo
- !$OMP do schedule(static)
- do j=js_u,je_u ; do I=isv-1,iev
+ do concurrent (j=js_u:je_u, I=isv-1:iev)
PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j)
- enddo ; enddo
- !$OMP end do nowait
- !$OMP do schedule(static)
- do J=jsv-1,jev ; do i=is_v,ie_v
+ enddo
+ do concurrent (J=jsv-1:jev, i=is_v:ie_v)
PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
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 +3529,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
@@ -3227,42 +3558,33 @@ subroutine btloop_update_v(dtbt, ubt, vbt, v_accel_bt, &
! The bracket bug only applies if v is second, use ioff to check.
if (use_bracket_bug) then
- !$OMP do schedule(static)
- do J=Js_v,Je_v ; do i=is_v,ie_v
+ do concurrent (J=Js_v:Je_v, i=is_v:ie_v)
Cor_v(i,J) = -1.0*(((f_4_v(1,i,J) * ubt(I-1,j)) + (f_4_v(2,i,J) * ubt(I,j))) + &
((f_4_v(4,i,J) * ubt(I,j+1)) + (f_4_v(3,i,J) * ubt(I-1,j+1)))) - Cor_ref_v(i,J)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
else
- !$OMP do schedule(static)
- do J=Js_v,Je_v ; do i=is_v,ie_v
+ do concurrent (J=Js_v:Je_v, i=is_v:ie_v)
Cor_v(i,J) = -1.0*(((f_4_v(1,i,J) * ubt(I-1,j)) + (f_4_v(4,i,J) * ubt(I,j+1))) + &
((f_4_v(2,i,J) * ubt(I,j)) + (f_4_v(3,i,J) * ubt(I-1,j+1)))) - Cor_ref_v(i,J)
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
- !$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)
+ do concurrent (J=Js_v:Je_v, i=is_v:ie_v)
vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + &
dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J)))
if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0
- enddo ; enddo
- !$OMP end do nowait
+ enddo
if (CS%linear_wave_drag) then
- !$OMP do schedule(static)
- do J=Js_v,Je_v ; do i=is_v,ie_v
+ do concurrent (J=Js_v:Je_v, i=is_v:ie_v)
v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel_n * &
((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J))
- enddo ; enddo
+ enddo
else
- !$OMP do schedule(static)
- do J=Js_v,Je_v ; do i=is_v,ie_v
+ do concurrent (J=Js_v:Je_v, i=is_v:ie_v)
v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel_n * (Cor_v(i,J) + PFv(i,J))
- enddo ; enddo
+ enddo
endif
end subroutine btloop_update_v
@@ -3270,7 +3592,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 +3626,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].
@@ -3318,35 +3638,27 @@ subroutine btloop_update_u(dtbt, ubt, vbt, u_accel_bt, &
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
! Local variables
- real :: vel_prev ! The previous velocity [L T-1 ~> m s-1].
integer :: i, j
- !$OMP do schedule(static)
- do j=js_u,je_u ; do I=Is_u,Ie_u
+ do concurrent (j=js_u:je_u, I=Is_u:Ie_u)
Cor_u(I,j) = (((f_4_u(4,I,j) * vbt(i+1,J)) + (f_4_u(1,I,j) * vbt(i,J-1))) + &
((f_4_u(3,I,j) * vbt(i,J)) + (f_4_u(2,I,j) * vbt(i+1,J-1)))) - &
Cor_ref_u(I,j)
- ubt_prev(I,j) = ubt(I,j)
ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + &
dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j)))
if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0
- enddo ; enddo
- !$OMP end do nowait
+ enddo
if (CS%linear_wave_drag) then
- !$OMP do schedule(static)
- do j=js_u,je_u ; do I=Is_u,Ie_u
+ do concurrent (j=js_u:je_u, I=Is_u:Ie_u)
u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel_n * &
((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j))
- enddo ; enddo
- !$OMP end do nowait
+ enddo
else
- !$OMP do schedule(static)
- do j=js_u,je_u ; do I=Is_u,Ie_u
+ do concurrent (j=js_u:je_u, I=Is_u:Ie_u)
u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel_n * (Cor_u(I,j) + PFu(I,j))
- enddo ; enddo
- !$OMP end do nowait
+ enddo
endif
end subroutine btloop_update_u
@@ -3373,25 +3685,33 @@ subroutine btstep_ubt_from_layer(U_in, V_in, wt_u, wt_v, ubt, vbt, G, GV, CS)
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
- ubt(:,:) = 0.0 ; vbt(:,:) = 0.0
-
- !$OMP parallel do default(shared)
- do j=js,je ; do k=1,nz ; do I=is-1,ie
- ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k)
- enddo ; enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do k=1,nz ; do i=is,ie
- vbt(i,J) = vbt(i,J) + wt_v(i,J,k) * V_in(i,J,k)
- enddo ; enddo ; enddo
+ do concurrent (j=CS%jsdw:CS%jedw, i=CS%isdw-1:CS%iedw)
+ ubt(i,j) = 0.0
+ enddo
+ do concurrent (j=CS%jsdw-1:CS%jedw, i=CS%isdw:CS%iedw)
+ vbt(i,j) = 0.0
+ enddo
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie
- if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie
- if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0
- enddo ; enddo
+ do concurrent (j=js:je)
+ do k=1,nz
+ do concurrent (I=is-1:ie)
+ ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k)
+ enddo
+ enddo
+ do concurrent (I=is-1:ie)
+ if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0
+ enddo
+ enddo
+ do concurrent (J=js-1:je)
+ do k=1,nz
+ do concurrent (i=is:ie)
+ vbt(i,J) = vbt(i,J) + wt_v(i,J,k) * V_in(i,J,k)
+ enddo
+ enddo
+ do concurrent (i=is:ie)
+ if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0
+ enddo
+ enddo
end subroutine btstep_ubt_from_layer
@@ -3453,20 +3773,17 @@ subroutine btstep_layer_accel(dt, u_accel_bt, v_accel_bt, pbce, gtot_E, gtot_W,
accel_underflow = CS%vel_underflow * Idt
! Now calculate each layer's accelerations.
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js,je ; do I=is-1,ie
- accel_layer_u(I,j,k) = (u_accel_bt(I,j) - &
- (((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j)) - &
- ((pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j))) * CS%IdxCu(I,j) )
- if (abs(accel_layer_u(I,j,k)) < accel_underflow) accel_layer_u(I,j,k) = 0.0
- enddo ; enddo
- do J=js-1,je ; do i=is,ie
- accel_layer_v(i,J,k) = (v_accel_bt(i,J) - &
- (((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1)) - &
- ((pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j))) * CS%IdyCv(i,J) )
- if (abs(accel_layer_v(i,J,k)) < accel_underflow) accel_layer_v(i,J,k) = 0.0
- enddo ; enddo
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
+ accel_layer_u(I,j,k) = (u_accel_bt(I,j) - &
+ (((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j)) - &
+ ((pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j))) * CS%IdxCu(I,j) )
+ if (abs(accel_layer_u(I,j,k)) < accel_underflow) accel_layer_u(I,j,k) = 0.0
+ enddo
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
+ accel_layer_v(i,J,k) = (v_accel_bt(i,J) - &
+ (((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1)) - &
+ ((pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j))) * CS%IdyCv(i,J) )
+ if (abs(accel_layer_v(i,J,k)) < accel_underflow) accel_layer_v(i,J,k) = 0.0
enddo
end subroutine btstep_layer_accel
@@ -3541,6 +3858,7 @@ subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add)
use_BT_cont = .false.
if (present(BT_cont)) use_BT_cont = (associated(BT_cont))
+ !$omp target enter data map(alloc: gtot_E, gtot_W, gtot_N, gtot_S, Datu, Datv)
if (use_BT_cont) then
call BT_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo=0)
elseif (CS%Nonlinear_continuity .and. present(eta)) then
@@ -3557,25 +3875,29 @@ subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add)
dgeo_de = 1.0 + max(0.0, CS%G_extra - det_de)
endif
if (present(pbce)) then
- do j=js,je ; do i=is,ie
- gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0
- gtot_N(i,j) = 0.0 ; gtot_S(i,j) = 0.0
- enddo ; enddo
- do k=1,nz ; do j=js,je ; do i=is,ie
- gtot_E(i,j) = gtot_E(i,j) + pbce(i,j,k) * CS%frhatu(I,j,k)
- gtot_W(i,j) = gtot_W(i,j) + pbce(i,j,k) * CS%frhatu(I-1,j,k)
- gtot_N(i,j) = gtot_N(i,j) + pbce(i,j,k) * CS%frhatv(i,J,k)
- gtot_S(i,j) = gtot_S(i,j) + pbce(i,j,k) * CS%frhatv(i,J-1,k)
- enddo ; enddo ; enddo
+ do concurrent (j=js:je)
+ do concurrent (i=is:ie)
+ gtot_E(i,j) = 0.0 ; gtot_W(i,j) = 0.0
+ gtot_N(i,j) = 0.0 ; gtot_S(i,j) = 0.0
+ enddo
+ do k=1,nz
+ do concurrent (i=is:ie)
+ gtot_E(i,j) = gtot_E(i,j) + pbce(i,j,k) * CS%frhatu(I,j,k)
+ gtot_W(i,j) = gtot_W(i,j) + pbce(i,j,k) * CS%frhatu(I-1,j,k)
+ gtot_N(i,j) = gtot_N(i,j) + pbce(i,j,k) * CS%frhatv(i,J,k)
+ gtot_S(i,j) = gtot_S(i,j) + pbce(i,j,k) * CS%frhatv(i,J-1,k)
+ enddo
+ enddo
+ enddo
else
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
gtot_E(i,j) = gtot_est ; gtot_W(i,j) = gtot_est
gtot_N(i,j) = gtot_est ; gtot_S(i,j) = gtot_est
- enddo ; enddo
+ enddo
endif
min_max_dt2 = 1.0e38*US%s_to_T**2 ! A huge value for the permissible timestep squared.
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie) DO_LOCALITY(reduce(min:min_max_dt2))
! This is pretty accurate for gravity waves, but it is a conservative
! estimate since it ignores the stabilizing effect of the bottom drag.
Idt_max2 = 0.5 * (1.0 + 2.0*CS%bebt) * (G%IareaT(i,j) * &
@@ -3584,7 +3906,8 @@ subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add)
((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + &
(G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 )
if (Idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / Idt_max2
- enddo ; enddo
+ enddo
+ !$omp target exit data map(release: gtot_E, gtot_W, gtot_N, gtot_S, Datu, Datv)
dtbt_max = sqrt(min_max_dt2 / dgeo_de)
if (id_clock_sync > 0) call cpu_clock_begin(id_clock_sync)
call min_across_PEs(dtbt_max)
@@ -3597,7 +3920,6 @@ subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add)
call chksum0(CS%dtbt, "End set_dtbt dtbt", unscale=US%T_to_s)
call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", unscale=US%T_to_s)
endif
-
end subroutine set_dtbt
! The following 5 subroutines apply the open boundary conditions.
@@ -4000,8 +4322,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 +4335,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 +4421,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.
@@ -4347,29 +4676,26 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC)
type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary control structure.
! Local variables
- real :: hatu(SZIB_(G),SZK_(GV)) ! The layer thicknesses interpolated to u points [H ~> m or kg m-2]
- real :: hatv(SZI_(G),SZK_(GV)) ! The layer thicknesses interpolated to v points [H ~> m or kg m-2]
- real :: hatutot(SZIB_(G)) ! The sum of the layer thicknesses interpolated to u points [H ~> m or kg m-2].
- real :: hatvtot(SZI_(G)) ! The sum of the layer thicknesses interpolated to v points [H ~> m or kg m-2].
- real :: Ihatutot(SZIB_(G)) ! Ihatutot is the inverse of hatutot [H-1 ~> m-1 or m2 kg-1].
- real :: Ihatvtot(SZI_(G)) ! Ihatvtot is the inverse of hatvtot [H-1 ~> m-1 or m2 kg-1].
+ real :: hatutot(SZIB_(G),SZJ_(G)) ! The sum of the layer thicknesses interpolated to u points [H ~> m or kg m-2].
+ real :: hatvtot(SZI_(G),SZJB_(G)) ! The sum of the layer thicknesses interpolated to v points [H ~> m or kg m-2].
+ real :: Ihatutot(SZIB_(G),SZJ_(G)) ! Ihatutot is the inverse of hatutot [H-1 ~> m-1 or m2 kg-1].
+ real :: Ihatvtot(SZI_(G),SZJB_(G)) ! Ihatvtot is the inverse of hatvtot [H-1 ~> m-1 or m2 kg-1].
real :: h_arith ! The arithmetic mean thickness [H ~> m or kg m-2].
real :: h_harm ! The harmonic mean thicknesses [H ~> m or kg m-2].
real :: h_neglect ! A thickness that is so small it is usually lost
! in roundoff and can be neglected [H ~> m or kg m-2].
real :: wt_arith ! The weight for the arithmetic mean thickness [nondim].
! The harmonic mean uses a weight of (1 - wt_arith).
- real :: e_u(SZIB_(G),SZK_(GV)+1) ! The interface heights at u-velocity points [H ~> m or kg m-2]
- real :: e_v(SZI_(G),SZK_(GV)+1) ! The interface heights at v-velocity points [H ~> m or kg m-2]
- real :: D_shallow_u(SZI_(G)) ! The height of the shallower of the adjacent bathymetric depths
+ real :: e_u(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! The interface heights at u-velocity points [H ~> m or kg m-2]
+ real :: e_v(SZI_(G),SZJB_(G),SZK_(GV)+1) ! The interface heights at v-velocity points [H ~> m or kg m-2]
+ real :: D_shallow_u(SZI_(G),SZJB_(G)) ! The height of the shallower of the adjacent bathymetric depths
! around a u-point (positive upward) [H ~> m or kg m-2]
- real :: D_shallow_v(SZIB_(G))! The height of the shallower of the adjacent bathymetric depths
+ real :: D_shallow_v(SZIB_(G),SZJ_(G))! The height of the shallower of the adjacent bathymetric depths
! around a v-point (positive upward) [H ~> m or kg m-2]
real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3]
logical :: use_default, test_dflt
integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, i, j, k
- integer :: is_v, ie_v, Js_v, Je_v
if (.not.CS%module_is_initialized) call MOM_error(FATAL, &
"btcalc: Module MOM_barotropic must be initialized before it is used.")
@@ -4394,181 +4720,231 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC)
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
h_neglect = GV%H_subroundoff
+ !$omp target enter data map(alloc: hatutot, hatvtot, Ihatutot, Ihatvtot)
- !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) &
- !$OMP private(hatu,hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith,Z_to_H)
- do j=js,je
- do I=is-1,ie ; hatutot(I) = 0.0 ; enddo
+ do concurrent (j=js:je, I=is-1:ie)
+ hatutot(I,j) = 0.0
+ enddo
- if (present(h_u)) then
- do k=1,nz ; do I=is-1,ie
- hatu(I,k) = h_u(I,j,k)
- hatutot(I) = hatutot(I) + hatu(I,k)
- enddo ; enddo
- elseif (CS%hvel_scheme == ARITHMETIC) then
- do k=1,nz ; do I=is-1,ie
- hatu(I,k) = 0.5 * (h(i+1,j,k) + h(i,j,k))
- hatutot(I) = hatutot(I) + hatu(I,k)
- enddo ; enddo
- elseif (CS%hvel_scheme == HYBRID .or. use_default) then
- Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin
- do I=is-1,ie
- e_u(I,nz+1) = -0.5 * Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j))
- D_shallow_u(I) = -Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j))
+ if (present(h_u)) then
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
+ CS%frhatu(I,j,k) = h_u(I,j,k)
+ enddo
+ do concurrent (j=js:je, I=is-1:ie)
+ do k=1,nz
+ hatutot(I,j) = hatutot(I,j) + CS%frhatu(I,j,k)
+ enddo
+ enddo
+ elseif (CS%hvel_scheme == ARITHMETIC) then
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
+ CS%frhatu(I,j,k) = 0.5 * (h(i+1,j,k) + h(i,j,k))
+ enddo
+ do concurrent (j=js:je, I=is-1:ie)
+ do k=1,nz
+ hatutot(I,j) = hatutot(I,j) + CS%frhatu(I,j,k)
enddo
- do k=nz,1,-1 ; do I=is-1,ie
- e_u(I,K) = e_u(I,K+1) + 0.5 * (h(i+1,j,k) + h(i,j,k))
+ enddo
+ elseif (CS%hvel_scheme == HYBRID .or. use_default) then
+ Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin
+ !$omp target data map(alloc: e_u, D_shallow_u)
+ do concurrent (j=js:je, I=is-1:ie)
+ e_u(I,j,nz+1) = -0.5 * Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j))
+ D_shallow_u(I,j) = -Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j))
+ enddo
+ do k=nz,1,-1
+ do concurrent (j=js:je, I=is-1:ie)
+ e_u(I,j,K) = e_u(I,j,K+1) + 0.5 * (h(i+1,j,k) + h(i,j,k))
h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k))
- if (e_u(I,K+1) >= D_shallow_u(I)) then
- hatu(I,k) = h_arith
+ if (e_u(I,j,K+1) >= D_shallow_u(I,j)) then
+ CS%frhatu(I,j,k) = h_arith
else
h_harm = (h(i+1,j,k) * h(i,j,k)) / (h_arith + h_neglect)
- if (e_u(I,K) <= D_shallow_u(I)) then
- hatu(I,k) = h_harm
+ if (e_u(I,j,K) <= D_shallow_u(I,j)) then
+ CS%frhatu(I,j,k) = h_harm
else
- wt_arith = (e_u(I,K) - D_shallow_u(I)) / (h_arith + h_neglect)
- hatu(I,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
+ wt_arith = (e_u(I,j,K) - D_shallow_u(I,j)) / (h_arith + h_neglect)
+ CS%frhatu(I,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
endif
endif
- hatutot(I) = hatutot(I) + hatu(I,k)
- enddo ; enddo
- elseif (CS%hvel_scheme == HARMONIC) then
- ! Interpolates thicknesses onto u grid points with the
- ! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-).
- do k=1,nz ; do I=is-1,ie
- hatu(I,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / &
- ((h(i+1,j,k) + h(i,j,k)) + h_neglect)
- hatutot(I) = hatutot(I) + hatu(I,k)
- enddo ; enddo
- endif
+ hatutot(I,j) = hatutot(I,j) + CS%frhatu(I,j,k)
+ enddo
+ enddo
+ !$omp end target data
+ elseif (CS%hvel_scheme == HARMONIC) then
+ ! Interpolates thicknesses onto u grid points with the
+ ! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-).
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
+ CS%frhatu(I,j,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / &
+ ((h(i+1,j,k) + h(i,j,k)) + h_neglect)
+ enddo
+ do concurrent (j=js:je, I=is-1:ie)
+ do k=1,nz
+ hatutot(I,j) = hatutot(I,j) + CS%frhatu(I,j,k)
+ enddo
+ enddo
+ endif
- if (CS%BT_OBC%u_OBCs_on_PE) then
+ if (CS%BT_OBC%u_OBCs_on_PE) then
+ ! todo: put i,j iterations into single do concurrent
+ do concurrent (j=js:je)
! Reset velocity point thicknesses and their sums at OBC points
if ((j >= CS%BT_OBC%js_u_E_obc) .and. (j <= CS%BT_OBC%je_u_E_obc)) then
+ !$omp do
do I = max(is-1,CS%BT_OBC%Is_u_E_obc), min(ie,CS%BT_OBC%Ie_u_E_obc)
if (CS%BT_OBC%u_OBC_type(I,j) > 0) then ! Eastern boundary condition
- hatutot(I) = 0.0
+ hatutot(I,j) = 0.0
do k=1,nz
- hatu(I,k) = h(i,j,k)
- hatutot(I) = hatutot(I) + hatu(I,k)
+ CS%frhatu(I,j,k) = h(i,j,k)
+ hatutot(I,j) = hatutot(I,j) + CS%frhatu(I,j,k)
enddo
endif
enddo
endif
if ((j >= CS%BT_OBC%js_u_W_obc) .and. (j <= CS%BT_OBC%je_u_W_obc)) then
+ !$omp do
do I = max(is-1,CS%BT_OBC%Is_u_W_obc), min(ie,CS%BT_OBC%Ie_u_W_obc)
if (CS%BT_OBC%u_OBC_type(I,j) < 0) then ! Western boundary condition
- hatutot(I) = 0.0
+ hatutot(I,j) = 0.0
do k=1,nz
- hatu(I,k) = h(i+1,j,k)
- hatutot(I) = hatutot(I) + hatu(I,k)
+ CS%frhatu(I,j,k) = h(i+1,j,k)
+ hatutot(I,j) = hatutot(I,j) + CS%frhatu(I,j,k)
enddo
endif
enddo
endif
- endif
+ enddo
+ endif
- ! Determine the fractional thickness of each layer at the velocity points.
- do I=is-1,ie ; Ihatutot(I) = G%mask2dCu(I,j) / (hatutot(I) + h_neglect) ; enddo
- do k=1,nz ; do I=is-1,ie
- CS%frhatu(I,j,k) = hatu(I,k) * Ihatutot(I)
- enddo ; enddo
+ ! Determine the fractional thickness of each layer at the velocity points.
+ do concurrent (j=js:je, I=is-1:ie)
+ Ihatutot(I,j) = G%mask2dCu(I,j) / (hatutot(I,j) + h_neglect)
+ enddo
+ do concurrent (k=1:nz, j=js:je, I=is-1:ie)
+ CS%frhatu(I,j,k) = CS%frhatu(I,j,k) * Ihatutot(I,j)
enddo
- !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) &
- !$OMP private(hatv,hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith,Z_to_H)
- do J=js-1,je
- do i=is,ie ; hatvtot(i) = 0.0 ; enddo
- if (present(h_v)) then
- do k=1,nz ; do i=is,ie
- hatv(i,k) = h_v(i,J,k)
- hatvtot(i) = hatvtot(i) + hatv(i,k)
- enddo ; enddo
- elseif (CS%hvel_scheme == ARITHMETIC) then
- do k=1,nz ; do i=is,ie
- hatv(i,k) = 0.5 * (h(i,j+1,k) + h(i,j,k))
- hatvtot(i) = hatvtot(i) + hatv(i,k)
- enddo ; enddo
- elseif (CS%hvel_scheme == HYBRID .or. use_default) then
- Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin
- do i=is,ie
- e_v(i,nz+1) = -0.5 * Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j))
- D_shallow_v(I) = -Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j))
+ do concurrent (J=js-1:je, i=is:ie)
+ hatvtot(i,J) = 0.0
+ enddo
+
+ if (present(h_v)) then
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
+ CS%frhatv(i,J,k) = h_v(i,J,k)
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
+ do k=1,nz
+ hatvtot(i,J) = hatvtot(i,J) + CS%frhatv(i,J,k)
enddo
- do k=nz,1,-1 ; do i=is,ie
- e_v(i,K) = e_v(i,K+1) + 0.5 * (h(i,j+1,k) + h(i,j,k))
+ enddo
+ elseif (CS%hvel_scheme == ARITHMETIC) then
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
+ CS%frhatv(i,J,k) = 0.5 * (h(i,j+1,k) + h(i,j,k))
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
+ do k=1,nz
+ hatvtot(i,J) = hatvtot(i,J) + CS%frhatv(i,J,k)
+ enddo
+ enddo
+ elseif (CS%hvel_scheme == HYBRID .or. use_default) then
+ Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin
+ !$omp target data map(alloc: e_v, D_shallow_v)
+ do concurrent (J=js-1:je, i=is:ie)
+ e_v(i,J,nz+1) = -0.5 * Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j))
+ D_shallow_v(i,J) = -Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j))
+ enddo
+ do k=nz,1,-1
+ do concurrent (J=js-1:je, i=is:ie)
+ e_v(i,J,K) = e_v(i,J,K+1) + 0.5 * (h(i,j+1,k) + h(i,j,k))
h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k))
- if (e_v(i,K+1) >= D_shallow_v(i)) then
- hatv(i,k) = h_arith
+ if (e_v(i,J,K+1) >= D_shallow_v(i,J)) then
+ CS%frhatv(i,J,k) = h_arith
else
h_harm = (h(i,j+1,k) * h(i,j,k)) / (h_arith + h_neglect)
- if (e_v(i,K) <= D_shallow_v(i)) then
- hatv(i,k) = h_harm
+ if (e_v(i,J,K) <= D_shallow_v(i,J)) then
+ CS%frhatv(i,J,k) = h_harm
else
- wt_arith = (e_v(i,K) - D_shallow_v(i)) / (h_arith + h_neglect)
- hatv(i,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
+ wt_arith = (e_v(i,J,K) - D_shallow_v(i,J)) / (h_arith + h_neglect)
+ CS%frhatv(i,J,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
endif
endif
- hatvtot(i) = hatvtot(i) + hatv(i,k)
- enddo ; enddo
- elseif (CS%hvel_scheme == HARMONIC) then
- do k=1,nz ; do i=is,ie
- hatv(i,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / &
- ((h(i,j+1,k) + h(i,j,k)) + h_neglect)
- hatvtot(i) = hatvtot(i) + hatv(i,k)
- enddo ; enddo
- endif
+ hatvtot(i,J) = hatvtot(i,J) + CS%frhatv(i,J,k)
+ enddo
+ enddo
+ !$omp end target data
+ elseif (CS%hvel_scheme == HARMONIC) then
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
+ CS%frhatv(i,J,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / &
+ ((h(i,j+1,k) + h(i,j,k)) + h_neglect)
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
+ do k=1,nz
+ hatvtot(i,J) = hatvtot(i,J) + CS%frhatv(i,J,k)
+ enddo
+ enddo
+ endif
- if (CS%BT_OBC%v_OBCs_on_PE) then
+ if (CS%BT_OBC%v_OBCs_on_PE) then
+ ! todo: put i,j iterations into single do concurrent
+ do concurrent (J=js-1:je)
! Reset v-velocity point thicknesses and their sums at OBC points
if ((J >= CS%BT_OBC%Js_v_N_obc) .and. (J <= CS%BT_OBC%Je_v_N_obc)) then
+ !$omp do simd
do i = max(is,CS%BT_OBC%is_v_N_obc), min(ie,CS%BT_OBC%ie_v_N_obc)
if (CS%BT_OBC%v_OBC_type(i,J) > 0) then ! Northern boundary condition
- hatvtot(i) = 0.0
+ hatvtot(i,J) = 0.0
do k=1,nz
- hatv(i,k) = h(i,j,k)
- hatvtot(i) = hatvtot(i) + hatv(i,k)
+ CS%frhatv(i,J,k) = h(i,j,k)
+ hatvtot(i,J) = hatvtot(i,J) + CS%frhatv(i,J,k)
enddo
endif
enddo
endif
if ((J >= CS%BT_OBC%Js_v_S_obc) .and. (J <= CS%BT_OBC%Je_v_S_obc)) then
+ !$omp do simd
do i = max(is,CS%BT_OBC%is_v_S_obc), min(ie,CS%BT_OBC%ie_v_S_obc)
if (CS%BT_OBC%v_OBC_type(i,J) < 0) then ! Southern boundary condition
- hatvtot(i) = 0.0
+ hatvtot(i,J) = 0.0
do k=1,nz
- hatv(i,k) = h(i,j+1,k)
- hatvtot(i) = hatvtot(i) + hatv(i,k)
+ CS%frhatv(i,J,k) = h(i,j+1,k)
+ hatvtot(i,J) = hatvtot(i,J) + CS%frhatv(i,J,k)
enddo
endif
enddo
endif
- endif
+ enddo
+ endif
- ! Determine the fractional thickness of each layer at the velocity points.
- do i=is,ie ; Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) ; enddo
- do k=1,nz ; do i=is,ie
- CS%frhatv(i,J,k) = hatv(i,k) * Ihatvtot(i)
- enddo ; enddo
+ ! Determine the fractional thickness of each layer at the velocity points.
+ do concurrent (J=js-1:je, i=is:ie)
+ Ihatvtot(i,J) = G%mask2dCv(i,J) / (hatvtot(i,J) + h_neglect)
+ enddo
+ do concurrent (k=1:nz, J=js-1:je, i=is:ie)
+ CS%frhatv(i,J,k) = CS%frhatv(i,J,k) * Ihatvtot(i,J)
enddo
+ !$omp target exit data map(delete: hatutot, hatvtot, Ihatutot, Ihatvtot)
+
if (CS%debug) then
+ !$omp target update from(CS%frhatu, CS%frhatv)
call uvchksum("btcalc frhat[uv]", CS%frhatu, CS%frhatv, G%HI, &
haloshift=0, symmetric=.true., omit_corners=.true., &
scalar_pair=.true.)
- if (present(h_u) .and. present(h_v)) &
+
+ if (present(h_u) .and. present(h_v)) then
+ !$omp target update from(h_u, h_v)
call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, &
symmetric=.true., omit_corners=.true., unscale=GV%H_to_MKS, &
scalar_pair=.true.)
+ endif
+
call hchksum(h, "btcalc h", G%HI, haloshift=1, unscale=GV%H_to_MKS)
endif
-
end subroutine btcalc
!> The function find_uhbt determines the zonal transport for a given velocity, or with
!! INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given
!! time-integrated velocity.
-function find_uhbt(u, BTC) result(uhbt)
+pure function find_uhbt(u, BTC) result(uhbt)
real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that
!! allow the barotropic transports to be calculated consistently
@@ -4593,7 +4969,7 @@ end function find_uhbt
!> The function find_duhbt_du determines the marginal zonal face area for a given velocity, or
!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity.
-function find_duhbt_du(u, BTC) result(duhbt_du)
+pure function find_duhbt_du(u, BTC) result(duhbt_du)
real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that
!! allow the barotropic transports to be calculated consistently
@@ -4702,7 +5078,7 @@ end function uhbt_to_ubt
!> The function find_vhbt determines the meridional transport for a given velocity, or with
!! INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given
!! time-integrated velocity.
-function find_vhbt(v, BTC) result(vhbt)
+pure function find_vhbt(v, BTC) result(vhbt)
real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that
!! allow the barotropic transports to be calculated consistently
@@ -4726,7 +5102,7 @@ end function find_vhbt
!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or
!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity.
-function find_dvhbt_dv(v, BTC) result(dvhbt_dv)
+pure function find_dvhbt_dv(v, BTC) result(dvhbt_dv)
real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that
!! allow the barotropic transports to be calculated consistently
@@ -4862,38 +5238,37 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain
real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim]
real, parameter :: C1_3 = 1.0/3.0 ! [nondim]
integer :: i, j, is, ie, js, je, hs
+ real :: tmp
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
hs = max(halo,0)
dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic
+ !$omp target enter data &
+ !$omp map(alloc: u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW, &
+ !$omp v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS)
+
! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays.
- !$OMP parallel default(shared)
- !$OMP do
- do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
+ do concurrent (j=js-hs:je+hs, i=is-hs-1:ie+hs)
u_polarity(i,j) = 1.0
uBT_EE(i,j) = 0.0 ; uBT_WW(i,j) = 0.0
FA_u_EE(i,j) = 0.0 ; FA_u_E0(i,j) = 0.0 ; FA_u_W0(i,j) = 0.0 ; FA_u_WW(i,j) = 0.0
- enddo ; enddo
- !$OMP do
- do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
+ enddo
+ do concurrent (j=js-hs-1:je+hs, i=is-hs:ie+hs)
v_polarity(i,j) = 1.0
vBT_NN(i,j) = 0.0 ; vBT_SS(i,j) = 0.0
FA_v_NN(i,j) = 0.0 ; FA_v_N0(i,j) = 0.0 ; FA_v_S0(i,j) = 0.0 ; FA_v_SS(i,j) = 0.0
- enddo ; enddo
- !$OMP do
- do j=js,je ; do I=is-1,ie
+ enddo
+ do concurrent (j=js:je, I=is-1:ie)
uBT_EE(I,j) = BT_cont%uBT_EE(I,j) ; uBT_WW(I,j) = BT_cont%uBT_WW(I,j)
FA_u_EE(I,j) = BT_cont%FA_u_EE(I,j) ; FA_u_E0(I,j) = BT_cont%FA_u_E0(I,j)
FA_u_W0(I,j) = BT_cont%FA_u_W0(I,j) ; FA_u_WW(I,j) = BT_cont%FA_u_WW(I,j)
- enddo ; enddo
- !$OMP do
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
vBT_NN(i,J) = BT_cont%vBT_NN(i,J) ; vBT_SS(i,J) = BT_cont%vBT_SS(i,J)
FA_v_NN(i,J) = BT_cont%FA_v_NN(i,J) ; FA_v_N0(i,J) = BT_cont%FA_v_N0(i,J)
FA_v_S0(i,J) = BT_cont%FA_v_S0(i,J) ; FA_v_SS(i,J) = BT_cont%FA_v_SS(i,J)
- enddo ; enddo
- !$OMP end parallel
+ enddo
if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
@@ -4908,22 +5283,29 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain
call create_group_pass(BT_cont%pass_FA_uv, FA_u_WW, FA_v_SS, BT_Domain, To_All+Scalar_Pair)
!--- end setup for group halo update
! Do halo updates on BT_cont.
- call do_group_pass(BT_cont%pass_polarity_BT, BT_Domain)
- call do_group_pass(BT_cont%pass_FA_uv, BT_Domain)
+ ! data update directives for MPI transfers (via CPU) needed even for serial
+ call do_group_pass(BT_cont%pass_polarity_BT, BT_Domain, omp_offload=.true.)
+ call do_group_pass(BT_cont%pass_FA_uv, BT_Domain, omp_offload=.true.)
if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
- !$OMP parallel default(shared)
- !$OMP do
- do j=js-hs,je+hs ; do I=is-hs-1,ie+hs
+ do concurrent (j=js-hs:je+hs, I=is-hs-1:ie+hs)
BTCL_u(I,j)%FA_u_EE = FA_u_EE(I,j) ; BTCL_u(I,j)%FA_u_E0 = FA_u_E0(I,j)
BTCL_u(I,j)%FA_u_W0 = FA_u_W0(I,j) ; BTCL_u(I,j)%FA_u_WW = FA_u_WW(I,j)
BTCL_u(I,j)%uBT_EE = dt*uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = dt*uBT_WW(I,j)
! Check for reversed polarity in the tripolar halo regions.
if (u_polarity(I,j) < 0.0) then
- call swap(BTCL_u(I,j)%FA_u_EE, BTCL_u(I,j)%FA_u_WW)
- call swap(BTCL_u(I,j)%FA_u_E0, BTCL_u(I,j)%FA_u_W0)
- call swap(BTCL_u(I,j)%uBT_EE, BTCL_u(I,j)%uBT_WW)
+ tmp = BTCL_u(I,j)%FA_u_EE
+ BTCL_u(I,j)%FA_u_EE = BTCL_u(I,j)%FA_u_WW
+ BTCL_u(I,j)%FA_u_WW = tmp
+
+ tmp = BTCL_u(I,j)%FA_u_E0
+ BTCL_u(I,j)%FA_u_E0 = BTCL_u(I,j)%FA_u_W0
+ BTCL_u(I,j)%FA_u_W0 = tmp
+
+ tmp = BTCL_u(I,j)%uBT_EE
+ BTCL_u(I,j)%uBT_EE = BTCL_u(I,j)%uBT_WW
+ BTCL_u(I,j)%uBT_WW = tmp
endif
BTCL_u(I,j)%uh_EE = BTCL_u(I,j)%uBT_EE * &
@@ -4936,17 +5318,25 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain
(C1_3 * (BTCL_u(I,j)%FA_u_WW - BTCL_u(I,j)%FA_u_W0)) / BTCL_u(I,j)%uBT_WW**2
if (abs(BTCL_u(I,j)%uBT_EE) > 0.0) BTCL_u(I,j)%uh_crvE = &
(C1_3 * (BTCL_u(I,j)%FA_u_EE - BTCL_u(I,j)%FA_u_E0)) / BTCL_u(I,j)%uBT_EE**2
- enddo ; enddo
- !$OMP do
- do J=js-hs-1,je+hs ; do i=is-hs,ie+hs
+ enddo
+
+ do concurrent (J=js-hs-1:je+hs, i=is-hs:ie+hs)
BTCL_v(i,J)%FA_v_NN = FA_v_NN(i,J) ; BTCL_v(i,J)%FA_v_N0 = FA_v_N0(i,J)
BTCL_v(i,J)%FA_v_S0 = FA_v_S0(i,J) ; BTCL_v(i,J)%FA_v_SS = FA_v_SS(i,J)
BTCL_v(i,J)%vBT_NN = dt*vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = dt*vBT_SS(i,J)
! Check for reversed polarity in the tripolar halo regions.
if (v_polarity(i,J) < 0.0) then
- call swap(BTCL_v(i,J)%FA_v_NN, BTCL_v(i,J)%FA_v_SS)
- call swap(BTCL_v(i,J)%FA_v_N0, BTCL_v(i,J)%FA_v_S0)
- call swap(BTCL_v(i,J)%vBT_NN, BTCL_v(i,J)%vBT_SS)
+ tmp = BTCL_v(i,J)%FA_v_NN
+ BTCL_v(i,J)%FA_v_NN = BTCL_v(i,J)%FA_v_SS
+ BTCL_v(i,J)%FA_v_SS = tmp
+
+ tmp = BTCL_v(i,J)%FA_v_N0
+ BTCL_v(i,J)%FA_v_N0 = BTCL_v(i,J)%FA_v_S0
+ BTCL_v(i,J)%FA_v_S0 = tmp
+
+ tmp = BTCL_v(i,J)%vBT_NN
+ BTCL_v(i,J)%vBT_NN = BTCL_v(i,J)%vBT_SS
+ BTCL_v(i,J)%vBT_SS = tmp
endif
BTCL_v(i,J)%vh_NN = BTCL_v(i,J)%vBT_NN * &
@@ -4959,8 +5349,11 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain
(C1_3 * (BTCL_v(i,J)%FA_v_SS - BTCL_v(i,J)%FA_v_S0)) / BTCL_v(i,J)%vBT_SS**2
if (abs(BTCL_v(i,J)%vBT_NN) > 0.0) BTCL_v(i,J)%vh_crvN = &
(C1_3 * (BTCL_v(i,J)%FA_v_NN - BTCL_v(i,J)%FA_v_N0)) / BTCL_v(i,J)%vBT_NN**2
- enddo ; enddo
- !$OMP end parallel
+ enddo
+
+ !$omp target exit data &
+ !$omp map(release: u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW, &
+ !$omp v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS)
end subroutine set_local_BT_cont_types
@@ -5083,19 +5476,19 @@ subroutine BT_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo)
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
hs = 1 ; if (present(halo)) hs = max(halo,0)
- do j=js-hs,je+hs ; do I=is-1-hs,ie+hs
+ do concurrent (j=js-hs:je+hs, I=is-1-hs:ie+hs)
Datu(I,j) = max(BT_cont%FA_u_EE(I,j), BT_cont%FA_u_E0(I,j), &
BT_cont%FA_u_W0(I,j), BT_cont%FA_u_WW(I,j))
- enddo ; enddo
- do J=js-1-hs,je+hs ; do i=is-hs,ie+hs
+ enddo
+ do concurrent (J=js-1-hs:je+hs, i=is-hs:ie+hs)
Datv(i,J) = max(BT_cont%FA_v_NN(i,J), BT_cont%FA_v_N0(i,J), &
BT_cont%FA_v_S0(i,J), BT_cont%FA_v_SS(i,J))
- enddo ; enddo
+ enddo
end subroutine BT_cont_to_face_areas
!> Swap the values of two real variables
-subroutine swap(a,b)
+pure subroutine swap(a,b)
real, intent(inout) :: a !< The first variable to be swapped [arbitrary units]
real, intent(inout) :: b !< The second variable to be swapped [arbitrary units]
real :: tmp ! A temporary variable [arbitrary units]
@@ -5128,73 +5521,70 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max)
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
hs = max(halo,0)
- !$OMP parallel default(shared) private(H1,H2,Z_to_H)
if (present(eta)) then
! The use of harmonic mean thicknesses ensure positive definiteness.
if (GV%Boussinesq) then
- !$OMP do
- do j=js-hs,je+hs ; do I=is-1-hs,ie+hs
+ do concurrent (j=js-hs:je+hs, I=is-1-hs:ie+hs)
H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j)
Datu(I,j) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) &
Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2)
-! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2)
- enddo ; enddo
- !$OMP do
- do J=js-1-hs,je+hs ; do i=is-hs,ie+hs
+ ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2)
+ enddo
+
+ do concurrent (J=js-1-hs:je+hs, i=is-hs:ie+hs)
H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1)
Datv(i,J) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) &
Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2)
-! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2)
- enddo ; enddo
+ ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2)
+ enddo
else
- !$OMP do
- do j=js-hs,je+hs ; do I=is-1-hs,ie+hs
+ do concurrent (j=js-hs:je+hs, I=is-1-hs:ie+hs)
Datu(I,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) &
Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * eta(i,j) * eta(i+1,j)) / &
(eta(i,j) + eta(i+1,j))
! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j))
- enddo ; enddo
- !$OMP do
- do J=js-1-hs,je+hs ; do i=is-hs,ie+hs
+ enddo
+
+ do concurrent (J=js-1-hs:je+hs, i=is-hs:ie+hs)
Datv(i,J) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) &
Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * eta(i,j) * eta(i,j+1)) / &
(eta(i,j) + eta(i,j+1))
! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (eta(i,j) + eta(i,j+1))
- enddo ; enddo
+ enddo
endif
elseif (present(add_max)) then
Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin
- !$OMP do
- do j=js-hs,je+hs ; do I=is-1-hs,ie+hs
- Datu(I,j) = CS%dy_Cu(I,j) * Z_to_H * &
- max(max(CS%bathyT(i+1,j), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0)
- enddo ; enddo
- !$OMP do
- do J=js-1-hs,je+hs ; do i=is-hs,ie+hs
- Datv(i,J) = CS%dx_Cv(i,J) * Z_to_H * &
- max(max(CS%bathyT(i,j+1), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0)
- enddo ; enddo
+ do concurrent (j=js-hs:je+hs, I=is-1-hs:ie+hs)
+ H1 = max((G%meanSL(i+1,j) + add_max) + G%bathyT(i+1,j), 0.0)
+ H2 = max((G%meanSL(i,j) + add_max) + G%bathyT(i,j), 0.0)
+ Datu(I,j) = CS%dy_Cu(I,j) * Z_to_H * max(H1, H2)
+ enddo
+
+ do concurrent (J=js-1-hs:je+hs, i=is-hs:ie+hs)
+ H1 = max((G%meanSL(i,j+1) + add_max) + G%bathyT(i,j+1), 0.0)
+ H2 = max((G%meanSL(i,j) + add_max) + G%bathyT(i,j), 0.0)
+ Datv(i,J) = CS%dx_Cv(i,J) * Z_to_H * max(H1, H2)
+ enddo
else
Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin
- !$OMP do
- do j=js-hs,je+hs ; do I=is-1-hs,ie+hs
- H1 = (CS%bathyT(i,j) + G%Z_ref) * Z_to_H ; H2 = (CS%bathyT(i+1,j) + G%Z_ref) * Z_to_H
+ do concurrent (j=js-hs:je+hs, I=is-1-hs:ie+hs)
+ H1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H
+ H2 = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) * Z_to_H
Datu(I,j) = 0.0
if ((H1 > 0.0) .and. (H2 > 0.0)) &
Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2)
- enddo ; enddo
- !$OMP do
- do J=js-1-hs,je+hs ; do i=is-hs,ie+hs
- H1 = (CS%bathyT(i,j) + G%Z_ref) * Z_to_H ; H2 = (CS%bathyT(i,j+1) + G%Z_ref) * Z_to_H
+ enddo
+
+ do concurrent (J=js-1-hs:je+hs, i=is-hs:ie+hs)
+ H1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H
+ H2 = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) * Z_to_H
Datv(i,J) = 0.0
if ((H1 > 0.0) .and. (H2 > 0.0)) &
Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2)
- enddo ; enddo
+ enddo
endif
- !$OMP end parallel
-
end subroutine find_face_areas
!> bt_mass_source determines the appropriately limited mass source for
@@ -5214,8 +5604,7 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS)
type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure
! Local variables
- real :: h_tot(SZI_(G)) ! The sum of the layer thicknesses [H ~> m or kg m-2].
- real :: eta_h(SZI_(G)) ! The free surface height determined from
+ real :: eta_h(SZI_(G),SZJ_(G)) ! The free surface height determined from
! the sum of the layer thicknesses [H ~> m or kg m-2].
real :: d_eta ! The difference between estimates of the total
! thicknesses [H ~> m or kg m-2].
@@ -5228,32 +5617,38 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS)
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
- !$OMP parallel do default(shared) private(eta_h,h_tot,d_eta)
- do j=js,je
- do i=is,ie ; h_tot(i) = h(i,j,1) ; enddo
+ !$omp target data map(alloc: eta_h)
+
+ do concurrent (j=js:je)
if (GV%Boussinesq) then
- do i=is,ie ; eta_h(i) = h(i,j,1) - G%bathyT(i,j)*GV%Z_to_H ; enddo
+ do concurrent (i=is:ie)
+ eta_h(i,j) = h(i,j,1) - G%bathyT(i,j)*GV%Z_to_H
+ enddo
else
- do i=is,ie ; eta_h(i) = h(i,j,1) ; enddo
+ do concurrent (i=is:ie)
+ eta_h(i,j) = h(i,j,1)
+ enddo
endif
- do k=2,nz ; do i=is,ie
- eta_h(i) = eta_h(i) + h(i,j,k)
- h_tot(i) = h_tot(i) + h(i,j,k)
- enddo ; enddo
-
+ do k=2,nz
+ do concurrent (i=is:ie)
+ eta_h(i,j) = eta_h(i,j) + h(i,j,k)
+ enddo
+ enddo
if (set_cor) then
- do i=is,ie
- d_eta = eta_h(i) - eta(i,j)
+ do concurrent (i=is:ie)
+ d_eta = eta_h(i,j) - eta(i,j)
CS%eta_cor(i,j) = d_eta
enddo
else
- do i=is,ie
- d_eta = eta_h(i) - eta(i,j)
+ do concurrent (i=is:ie)
+ d_eta = eta_h(i,j) - eta(i,j)
CS%eta_cor(i,j) = CS%eta_cor(i,j) + d_eta
enddo
endif
enddo
+ !$omp end target data
+
end subroutine bt_mass_source
!> barotropic_init initializes a number of time-invariant fields used in the
@@ -5310,13 +5705,14 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
! name in wave_drag_file.
character(len=80) :: wave_drag_v ! The wave drag piston velocity variable
! name in wave_drag_file.
- real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the
- ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m].
+ real :: htot ! Total column thickness used when BT_NONLIN_STRESS is false [Z ~> m].
real :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3]
real :: H_to_Z ! A local unit conversion factor [Z H-1 ~> nondim or m3 kg-1]
real :: det_de ! The partial derivative due to self-attraction and loading of the reference
! geopotential with the sea surface height when scalar SAL are enabled [nondim].
! This is typically ~0.09 or less.
+ real :: h_a_neglect ! A cell volume or mass that is so small it is usually lost
+ ! in roundoff and can be neglected [H L2 ~> m3 or kg]
real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points
! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1].
@@ -5325,7 +5721,13 @@ 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 :: OBC_projection_bug
+ logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
+ ! recreate the bugs, or if false bugs are only used if actively selected.
logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG.
character(len=48) :: thickness_units, flux_units
character*(40) :: hvel_str
@@ -5395,6 +5797,16 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
"This is a decent approximation to the inclusion of "//&
"sum(u dh_dt) while also correcting for truncation errors.", &
default=.false.)
+ call get_param(param_file, mdl, "BT_ADJUST_SRC_FOR_FILTER", CS%bt_adjust_src_for_filter, &
+ "If true, increases the rate at which BT mass sources are applied so "//&
+ "that they are all used up before the filtering period starts. "//&
+ "This option is only valid if INTEGRAL_BT_CONTINUITY = True.", &
+ default=.false., do_not_log=.not.CS%integral_bt_cont)
+ call get_param(param_file, mdl, "BT_LIMIT_INTEGRAL_TRANSPORT", CS%bt_limit_integral_transport, &
+ "If true, limit the time-integrated transports by the initial volume "//&
+ "accounting for sinks of mass. The limiter uses MAXCFL_BT_CONT. "//&
+ "This option is only valid if INTEGRAL_BT_CONTINUITY = True.", &
+ default=.false., do_not_log=.not.CS%integral_bt_cont)
call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", CS%visc_rem_u_uh0, &
"If true, use the viscous remnants when estimating the "//&
"barotropic velocities that were used to calculate uh0 "//&
@@ -5406,6 +5818,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 +5892,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=.false., do_not_log=.true.)
call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_BUG", CS%wt_uv_bug, &
"If true, recover a bug in barotropic solver that uses an unnormalized weight "//&
"function for vertical averages of baroclinic velocity and forcing. Default "//&
@@ -5483,7 +5902,17 @@ 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, "OBC_PROJECTION_BUG", OBC_projection_bug, &
+ "If false, use only interior ocean points at OBCs to specify several "//&
+ "calculations at OBC points, and it avoids applying a land mask at the bay-like "//&
+ "intersection of orthogonal OBC segments. Otherwise the calculation of terms "//&
+ "like the potential vorticity used in the barotropic solver relies on bathymetry "//&
+ "or other fields being projected outward across OBCs. This option changes "//&
+ "answers for some configurations that use OBCs.", &
+ default=enable_bugs, do_not_log=.true.)
+ CS%interior_OBC_PV = .not.OBC_projection_bug
+
call get_param(param_file, mdl, "TIDES", use_tides, &
"If true, apply tidal momentum forcing.", default=.false.)
if (use_tides .and. present(HA_CSp)) CS%HA_CSp => HA_CSp
@@ -5545,6 +5974,12 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
"with the barotropic time-step instead of implicit with "//&
"the baroclinic time-step and dividing by the number of "//&
"barotropic steps.", default=.false.)
+ call get_param(param_file, mdl, "RESCALE_STRONG_DRAG", CS%rescale_strong_drag, &
+ "If true, reduce the barotropic contribution to the layer accelerations "//&
+ "to account for the difference between the forces that can be counteracted "//&
+ "by the stronger drag with BT_STRONG_DRAG and the average of the layer "//&
+ "viscous remnants after a baroclinic timestep.", &
+ default=.false., do_not_log=.not.CS%strong_drag)
call get_param(param_file, mdl, "BT_LINEAR_WAVE_DRAG", CS%linear_wave_drag, &
"If true, apply a linear drag to the barotropic velocities, "//&
"using rates set by lin_drag_u & _v divided by the depth of "//&
@@ -5622,6 +6057,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 +6086,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 +6125,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))
@@ -5727,8 +6172,8 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
ALLOC_(CS%dy_Cu(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%dy_Cu(:,:) = 0.0
ALLOC_(CS%dx_Cv(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%dx_Cv(:,:) = 0.0
allocate(CS%IareaT_OBCmask(isdw:iedw,jsdw:jedw), source=0.0)
- ALLOC_(CS%OBCmask_u(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%OBCmask_u(:,:) = 1.0
- ALLOC_(CS%OBCmask_v(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%OBCmask_v(:,:) = 1.0
+ ALLOC_(CS%OBCmask_u(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%OBCmask_u(:,:) = 0.0
+ ALLOC_(CS%OBCmask_v(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%OBCmask_v(:,:) = 0.0
do j=G%jsd,G%jed ; do i=G%isd,G%ied
CS%IareaT(i,j) = G%IareaT(i,j)
CS%bathyT(i,j) = G%bathyT(i,j)
@@ -5739,11 +6184,23 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
! wide halos.
do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB
CS%IdxCu(I,j) = G%IdxCu(I,j) ; CS%dy_Cu(I,j) = G%dy_Cu(I,j)
+ CS%OBCmask_u(I,j) = G%OBCmaskCu(I,j)
enddo ; enddo
do J=G%JsdB,G%JedB ; do i=G%isd,G%ied
CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J)
+ CS%OBCmask_v(i,J) = G%OBCmaskCv(i,J)
enddo ; enddo
+ ! This sets pressure force diagnostics on land, at coastlines and at OBC points to zero.
+ if (mask_coastal_pressure_force) then
+ do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB
+ CS%IdxCu(I,j) = G%IdxCu_OBCmask(I,j)
+ enddo ; enddo
+ do J=G%JsdB,G%JedB ; do i=G%isd,G%ied
+ CS%IdyCv(i,J) = G%IdyCv_OBCmask(i,J)
+ enddo ; enddo
+ endif
+
if (associated(OBC)) then
! Set up information about the location and nature of the open boundary condition points.
call initialize_BT_OBC(OBC, CS%BT_OBC, G, CS)
@@ -5791,6 +6248,58 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
call create_group_pass(pass_static_data, CS%OBCmask_u, CS%OBCmask_v, CS%BT_domain, To_All+Scalar_Pair)
call do_group_pass(pass_static_data, CS%BT_domain)
+ ! Determine the weights to use for the thicknesses when calculating PV for use in the Coriolis terms
+ allocate(CS%q_wt(4,CS%isdw-1:CS%iedw,CS%jsdw-1:CS%jedw), source=0.0)
+ do J=js-1,je ; do I=is-1,ie
+ if (G%mask2dT(i,j) + G%mask2dT(i,j+1) + G%mask2dT(i+1,j) + G%mask2dT(i+1,j+1) > 0.) then
+ CS%q_wt(1,I,J) = G%areaT(i,j) ; CS%q_wt(2,I,J) = G%areaT(i+1,j)
+ CS%q_wt(3,I,J) = G%areaT(i,j+1) ; CS%q_wt(4,I,J) = G%areaT(i+1,j+1)
+ else
+ CS%q_wt(1:4,I,J) = 0.0
+ endif
+ enddo ; enddo
+
+ if (CS%interior_OBC_PV .and. (CS%BT_OBC%u_OBCs_on_PE .or. CS%BT_OBC%v_OBCs_on_PE)) then
+ ! Reset the potential vorticity at OBC vertices as a masked weighted average.
+ do J=js-1,je ; do I=is-1,ie
+ if ((G%mask2dT(i,j) + G%mask2dT(i,j+1) + G%mask2dT(i+1,j) + G%mask2dT(i+1,j+1) > 0.) .and. &
+ ((abs(CS%BT_OBC%u_OBC_type(I,j)) > 0) .or. (abs(CS%BT_OBC%u_OBC_type(I,j+1)) > 0) .or. &
+ (abs(CS%BT_OBC%v_OBC_type(i,J)) > 0) .or. (abs(CS%BT_OBC%v_OBC_type(i+1,J)) > 0)) ) then
+ ! This is an OBC vertex, so use an area weighted masked average and avoid external values.
+ CS%q_wt(1,I,J) = G%mask2dT(i,j) * G%areaT(i,j)
+ CS%q_wt(2,I,J) = G%mask2dT(i+1,j) * G%areaT(i+1,j)
+ CS%q_wt(3,I,J) = G%mask2dT(i,j+1) * G%areaT(i,j+1)
+ CS%q_wt(4,I,J) = G%mask2dT(i+1,j+1) * G%areaT(i+1,j+1)
+
+ ! The following block is the equivalent of shifting weights inward across OBC points. With
+ ! two OBCs in a line, it gives weights of about 1/2 and 1/2 to the interior points. At a
+ ! peninsula-like corner between two OBCs it gives weights of about 3/8, 1/4 and 3/8 for the
+ ! 3 interior points. At a bay-liek corner there is only one interior point with a weight of 1.
+ ! The masking above zeros out the weights for exterior points.
+ if (CS%BT_OBC%u_OBC_type(I,j) > 0) then ! Eastern OBC in the u-point to the south
+ CS%q_wt(1,I,J) = CS%q_wt(1,I,J) + 0.5*G%mask2dT(i,j)*G%areaT(i,j) ! already CS%q_wt(2,I,J) = 0.0
+ elseif (CS%BT_OBC%u_OBC_type(I,j) < 0) then ! Western OBC in the u-point to the south
+ CS%q_wt(2,I,J) = CS%q_wt(2,I,J) + 0.5*G%mask2dT(i+1,j)*G%areaT(i+1,j) ! already CS%q_wt(1,I,J) = 0.0
+ endif
+ if (CS%BT_OBC%u_OBC_type(I,j+1) > 0) then ! Eastern OBC in the u-point to the north
+ CS%q_wt(3,I,J) = CS%q_wt(3,I,J) + 0.5*G%mask2dT(i,j+1)*G%areaT(i,j+1) ! already CS%q_wt(4,I,J) = 0.0
+ elseif (CS%BT_OBC%u_OBC_type(I,j+1) < 0) then ! Western OBC in the u-point to the north
+ CS%q_wt(4,I,J) = CS%q_wt(4,I,J) + 0.5*G%mask2dT(i+1,j+1)*G%areaT(i+1,j+1) ! already CS%q_wt(3,I,J) = 0.0
+ endif
+ if (CS%BT_OBC%v_OBC_type(i,J) > 0) then ! Northern OBC in the v-point to the west
+ CS%q_wt(1,I,J) = CS%q_wt(1,I,J) + 0.5*G%mask2dT(i,j)*G%areaT(i,j) ! already CS%q_wt(3,I,J) = 0.0
+ elseif (CS%BT_OBC%v_OBC_type(i,J) < 0) then ! Southern OBC in the v-point to the west
+ CS%q_wt(3,I,J) = CS%q_wt(3,I,J) + 0.5*G%mask2dT(i,j+1)*G%areaT(i,j+1) ! already CS%q_wt(1,I,J) = 0.0
+ endif
+ if (CS%BT_OBC%v_OBC_type(i+1,J) > 0) then ! Northern OBC in the v-point to the west
+ CS%q_wt(2,I,J) = CS%q_wt(2,I,J) + 0.5*G%mask2dT(i+1,j)*G%areaT(i+1,j) ! already CS%q_wt(4,I,J) = 0.0
+ elseif (CS%BT_OBC%v_OBC_type(i+1,J) < 0) then ! Southern OBC in the v-point to the west
+ CS%q_wt(4,I,J) = CS%q_wt(4,I,J) + 0.5*G%mask2dT(i+1,j+1)*G%areaT(i+1,j+1) ! already CS%q_wt(2,I,J) = 0.0
+ endif
+ endif
+ enddo ; enddo
+ endif
+
if (CS%linearized_BT_PV) then
allocate(CS%q_D(CS%isdw-1:CS%iedw,CS%jsdw-1:CS%jedw), source=0.0)
allocate(CS%D_u_Cor(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw), source=0.0)
@@ -5798,25 +6307,43 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin
- Mean_SL = G%Z_ref
do j=js,je ; do I=is-1,ie
- CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H
+ CS%D_u_Cor(I,j) = 0.5 * ( max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) &
+ + max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) ) * Z_to_H
enddo ; enddo
+ if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then ; do j=js,je ; do I=is-1,ie
+ if (CS%BT_OBC%u_OBC_type(I,j) < 0) & ! Western boundary condition
+ CS%D_u_Cor(I,j) = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) * Z_to_H
+ if (CS%BT_OBC%u_OBC_type(I,j) > 0) & ! Eastern boundary condition
+ CS%D_u_Cor(I,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H
+ enddo ; enddo ; endif
+
do J=js-1,je ; do i=is,ie
- CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H
+ CS%D_v_Cor(i,J) = 0.5 * ( max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) &
+ + max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) ) * Z_to_H
enddo ; enddo
+ if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then ; do J=js-1,je ; do i=is,ie
+ if (CS%BT_OBC%v_OBC_type(i,J) < 0) & ! Southern boundary condition
+ CS%D_v_Cor(i,J) = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) * Z_to_H
+ if (CS%BT_OBC%v_OBC_type(i,J) > 0) & ! Northern boundary condition
+ CS%D_v_Cor(i,J) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H
+ enddo ; enddo ; endif
+
+ h_a_neglect = GV%H_subroundoff * 1.0 * US%m_to_L**2
do J=js-1,je ; do I=is-1,ie
- if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then
+ if ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J)) > 0.) then
CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * &
- ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / &
- (Z_to_H * max((((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0)) + &
- (G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0))) + &
- ((G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0)) + &
- (G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0)))), GV%H_subroundoff) )
- else ! All four h points are masked out so q_D(I,J) will is meaningless
+ ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / &
+ max(Z_to_H * (((CS%q_wt(1,I,J) * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)) + &
+ (CS%q_wt(4,I,J) * max(G%meanSL(i+1,j+1) + G%bathyT(i+1,j+1), 0.0))) + &
+ ((CS%q_wt(2,I,J) * max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0)) + &
+ (CS%q_wt(3,I,J) * max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0)))), &
+ h_a_neglect)
+ else ! All four h points are masked out so q_D(I,J) is meaningless
CS%q_D(I,J) = 0.
endif
enddo ; enddo
+
! With very wide halos, q and D need to be calculated on the available data
! domain and then updated onto the full computational domain.
call create_group_pass(pass_q_D_Cor, CS%q_D, CS%BT_Domain, To_All, position=CORNER)
@@ -5887,20 +6414,6 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
do k=1,GV%ke ; gtot_estimate = gtot_estimate + H_to_Z*GV%g_prime(K) ; enddo
endif
- ! CS%dtbt calculated here by set_dtbt is only used when dtbt is not reset during the run, i.e. DTBT_RESET_PERIOD<0.
- call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra)
-
- if (dtbt_input > 0.0) then
- CS%dtbt = US%s_to_T * dtbt_input
- elseif (dtbt_restart > 0.0) then
- CS%dtbt = dtbt_restart
- endif
-
- calc_dtbt = .true. ; if ((dtbt_restart > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false.
-
- call log_param(param_file, mdl, "DTBT as used", CS%dtbt, units="s", unscale=US%T_to_s)
- call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max, units="s", unscale=US%T_to_s)
-
! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and
! initialized in register_barotropic_restarts.
@@ -5914,6 +6427,9 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
'Zonal Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2)
CS%id_PFv_bt = register_diag_field('ocean_model', 'PFvBT', diag%axesCv1, Time, &
'Meridional Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2)
+ CS%id_etaPF_anom = register_diag_field('ocean_model', 'etaPF_anom', diag%axesT1, Time, &
+ 'Eta anomalies used for pressure forces averaged over a baroclinic timestep', &
+ thickness_units, conversion=GV%H_to_MKS)
if (CS%linear_wave_drag .or. (CS%use_filter .and. CS%linear_freq_drag)) then
CS%id_LDu_bt = register_diag_field('ocean_model', 'WaveDraguBT', diag%axesCu1, Time, &
'Zonal Barotropic Linear Wave Drag Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2)
@@ -5954,11 +6470,15 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
CS%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, Time, &
'Barotropic time-average meridional velocity', 'm s-1', conversion=US%L_T_to_m_s)
CS%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, Time, &
- 'Corrective mass flux within a timestep', 'm', conversion=GV%H_to_m)
+ 'Corrective mass or volume flux within a timestep', thickness_units, conversion=GV%H_to_MKS)
CS%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, Time, &
'Viscous remnant at u', 'nondim')
CS%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, Time, &
'Viscous remnant at v', 'nondim')
+ CS%id_bt_rem_u = register_diag_field('ocean_model', 'bt_rem_u', diag%axesCu1, Time, &
+ 'Barotropic viscous remnant per barotropic step at u', 'nondim')
+ CS%id_bt_rem_v = register_diag_field('ocean_model', 'bt_rem_v', diag%axesCv1, Time, &
+ 'Barotropic viscous remnant per barotropic step at v', 'nondim')
CS%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, Time, &
'gtot to North', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2))
CS%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, Time, &
@@ -5976,6 +6496,8 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
! if (.not.CS%BT_project_velocity) & ! The following diagnostic is redundant with BT_project_velocity.
CS%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, Time, &
'High Frequency Predictor Barotropic SSH', thickness_units, conversion=GV%H_to_MKS)
+ CS%id_etaPF_hifreq = register_diag_field('ocean_model', 'etaPF_hifreq', diag%axesT1, Time, &
+ 'High Frequency Barotropic SSH anomalies used for pressure forces', thickness_units, conversion=GV%H_to_MKS)
CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, &
'High Frequency Barotropic zonal transport', &
'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s)
@@ -6035,12 +6557,44 @@ 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
+
+ !$omp target update to (CS)
+
+ ! CS%dtbt calculated here by set_dtbt is only used when dtbt is not reset during the run, i.e. DTBT_RESET_PERIOD<0.
+ !$omp target enter data map (to: CS%frhatu, CS%frhatv)
+ !$omp target enter data map (to: CS%eta_cor)
+ call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra)
+
+ if (dtbt_input > 0.0) then
+ CS%dtbt = US%s_to_T * dtbt_input
+ elseif (dtbt_restart > 0.0) then
+ CS%dtbt = dtbt_restart
+ endif
+ !$omp target update to (CS%dtbt)
+
+ calc_dtbt = .true. ; if ((dtbt_restart > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false.
+
+ call log_param(param_file, mdl, "DTBT as used", CS%dtbt, units="s", unscale=US%T_to_s)
+ call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max, units="s", unscale=US%T_to_s)
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.)
if (.NOT.query_initialized(CS%ubtav,"ubtav",restart_CS) .or. &
.NOT.query_initialized(CS%vbtav,"vbtav",restart_CS)) then
+ !$omp target update to(h)
call btcalc(h, G, GV, CS, may_use_default=.true.)
CS%ubtav(:,:) = 0.0 ; CS%vbtav(:,:) = 0.0
do k=1,nz ; do j=js,je ; do I=is-1,ie
@@ -6061,19 +6615,20 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
! Calculate other constants which are used for btstep.
if (.not.CS%nonlin_stress) then
- Mean_SL = G%Z_ref
Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin
do j=js,je ; do I=is-1,ie
- if (G%mask2dCu(I,j)>0.) then
- CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (Z_to_H * ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL))
- else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless
+ htot = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) + max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)
+ if (G%OBCmaskCu(I,j) * htot > 0.) then
+ CS%IDatu(I,j) = G%OBCmaskCu(I,j) * 2.0 / (Z_to_H * htot)
+ else ! Both neighboring H points are masked out or this is an OBC face so IDatu(I,j) is unused
CS%IDatu(I,j) = 0.
endif
enddo ; enddo
do J=js-1,je ; do i=is,ie
- if (G%mask2dCv(i,J)>0.) then
- CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (Z_to_H * ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL))
- else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless
+ htot = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) + max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)
+ if (G%OBCmaskCv(i,J) * htot > 0.) then
+ CS%IDatv(i,J) = G%OBCmaskCv(i,J) * 2.0 / (Z_to_H * htot)
+ else ! Both neighboring H points are masked out or this is an OBC face so IDatv(i,J) is unused
CS%IDatv(i,J) = 0.
endif
enddo ; enddo
@@ -6088,6 +6643,7 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
((Datu(I-1,j) + Datu(I,j)) + (Datv(i,J) + Datv(i,J-1)))
enddo ; enddo
endif
+ !$omp target enter data map(to: CS%eta_cor_bound)
if (CS%gradual_BT_ICs) &
call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain)
@@ -6104,6 +6660,18 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
if (dtbt_input <= 0.0) &
id_clock_sync = cpu_clock_id('(Ocean BT global synch)', grain=CLOCK_ROUTINE)
+ ! send initialized data to GPU
+ !$omp target enter data map(to: CS%bathyT)
+ !$omp target enter data map(to: CS%D_u_Cor, CS%D_v_Cor)
+ !$omp target enter data map(to: CS%dx_Cv, CS%dy_Cu)
+ !$omp target enter data map(to: CS%IareaT, CS%IareaT_OBCmask)
+ !$omp target enter data map(to: CS%IDatu, CS%IDatv)
+ !$omp target enter data map(to: CS%IdxCu, CS%IdyCv)
+ !$omp target enter data map(to: CS%OBCmask_u, CS%OBCmask_v)
+ !$omp target enter data map(to: CS%q_d)
+ !$omp target enter data map(to: CS%ua_polarity, CS%va_polarity)
+ !$omp target enter data map(to: CS%ubtav, CS%vbtav)
+
end subroutine barotropic_init
!> Copies ubtav and vbtav from private type into arrays
@@ -6138,9 +6706,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)
@@ -6237,6 +6803,7 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS)
end subroutine register_barotropic_restarts
+
!> \namespace mom_barotropic
!!
!! By Robert Hallberg, April 1994 - January 2007
diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90
index 31863d10c2..70e35f7274 100644
--- a/src/core/MOM_boundary_update.F90
+++ b/src/core/MOM_boundary_update.F90
@@ -1,16 +1,18 @@
-! This file is part of MOM6. See LICENSE.md for the license.
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Controls where open boundary conditions are applied
module MOM_boundary_update
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE
use MOM_diag_mediator, only : time_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING
use MOM_file_parser, only : get_param, log_version, param_file_type, log_param
use MOM_grid, only : ocean_grid_type
use MOM_dyn_horgrid, only : dyn_horgrid_type
-use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data
+use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data, chksum_OBC_segments
+use MOM_open_boundary, only : read_OBC_segment_data
use MOM_open_boundary, only : OBC_registry_type, file_OBC_CS
use MOM_open_boundary, only : register_file_OBC, file_OBC_end
use MOM_unit_scaling, only : unit_scale_type
@@ -41,6 +43,11 @@ module MOM_boundary_update
logical :: use_tidal_bay = .false. !< If true, use the tidal_bay open boundary.
logical :: use_shelfwave = .false. !< If true, use the shelfwave open boundary.
logical :: use_dyed_channel = .false. !< If true, use the dyed channel open boundary.
+ logical :: debug_OBCs = .false. !< If true, write verbose OBC values for debugging purposes.
+ logical :: value_update_bug = .true. !< If true, recover a bug that OBC segment data does not
+ !! update if all segments use 'value' and none uses 'file'.
+ integer :: nk_OBC_debug = 0 !< The number of layers of OBC segment data to write out
+ !! in full when DEBUG_OBCS is true.
!>@{ Pointers to the control structures for named OBC specifications
type(file_OBC_CS), pointer :: file_OBC_CSp => NULL()
type(Kelvin_OBC_CS), pointer :: Kelvin_OBC_CSp => NULL()
@@ -69,6 +76,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".
@@ -81,6 +89,9 @@ subroutine call_OBC_register(G, GV, US, param_file, CS, OBC, tr_Reg)
call log_version(param_file, mdl, version, "")
+ call get_param(param_file, mdl, "OBC_VALUE_UPDATE_BUG", CS%value_update_bug, &
+ "If true, recover a bug that OBC segment data does not update if all segments "//&
+ "use 'value' and none uses 'file'.", default=.true.)
call get_param(param_file, mdl, "USE_FILE_OBC", CS%use_files, &
"If true, use external files for the open boundary.", &
default=.false.)
@@ -106,6 +117,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 +173,15 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time)
if (CS%use_shelfwave) &
call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, US, h, Time)
if (CS%use_dyed_channel) &
- call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, Time)
- if (OBC%any_needs_IO_for_data .or. OBC%add_tide_constituents) &
- call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time)
+ call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, h, Time)
+
+ if (.not. OBC%user_BCs_set_globally) then
+ if (OBC%any_needs_IO_for_data) call read_OBC_segment_data(G, GV, US, OBC, tv, h, Time)
+ if ((.not.CS%value_update_bug) .or. (OBC%any_needs_IO_for_data .or. OBC%add_tide_constituents)) &
+ call update_OBC_segment_data(G, GV, US, OBC, h, Time)
+ endif
+
+ if (CS%debug_OBCs) call chksum_OBC_segments(OBC, G, GV, US, CS%nk_OBC_debug)
end subroutine update_OBC_data
diff --git a/src/core/MOM_check_scaling.F90 b/src/core/MOM_check_scaling.F90
index 2841514924..b52b577293 100644
--- a/src/core/MOM_check_scaling.F90
+++ b/src/core/MOM_check_scaling.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module is used to check the dimensional scaling factors used by the MOM6 ocean model
module MOM_check_scaling
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity
use MOM_unique_scales, only : check_scaling_uniqueness, scales_to_powers
use MOM_unit_scaling, only : unit_scale_type
@@ -126,7 +128,7 @@ subroutine compose_dimension_list(ns, des, wts)
call add_scaling(ns, des, wts, "[S H ~> ppt m or ppt kg m-2]", 8) ! Depth integrated salinity
call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 8) ! Turbulent kinetic energy
call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]", 7) ! Vertically integrated pressure anomalies
- call add_scaling(ns, des, wts, "[Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1]", 7) ! (TKE_to_Kd)
+ call add_scaling(ns, des, wts, "[T2 Z-1 ~> s2 m-1]", 7) ! (TKE_to_Kd)
call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 7) ! Biharmonic viscosity
call add_scaling(ns, des, wts, "[L3 ~> m3]", 7) ! Metric dependent constants for viscosity
call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 7) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1]
diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90
index 13f71a3f16..bfe1366bf6 100644
--- a/src/core/MOM_checksum_packages.F90
+++ b/src/core/MOM_checksum_packages.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides routines that do checksums of groups of MOM variables
module MOM_checksum_packages
-! This file is part of MOM6. See LICENSE.md for the license.
-
! This module provides several routines that do check-sums of groups
! of variables in the various dynamic solver routines.
@@ -235,7 +237,7 @@ subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, US, p
logical :: sym
- sym=.false.; if (present(symmetric)) sym=symmetric
+ sym = .false. ; if (present(symmetric)) sym = symmetric
! Note that for the chksum calls to be useful for reproducing across PE
! counts, there must be no redundant points, so all variables use is..ie
@@ -376,7 +378,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe
write(0,'(a,2f12.5)') 'x,y=', G%geoLonT(i,j), G%geoLatT(i,j)
write(0,'(a3,3a12)') 'k','h','Temp','Salt'
do k = 1, nz
- write(0,'(i3,3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k)
+ write(0,'(I0," ",3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k)
enddo
stop 'Extremum detected'
endif
@@ -389,7 +391,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe
write(0,'(a,2f12.5)') 'x,y=',G%geoLonT(i,j),G%geoLatT(i,j)
write(0,'(a3,3a12)') 'k','h','Temp','Salt'
do k = 1, nz
- write(0,'(i3,3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k)
+ write(0,'(I0," ",3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k)
enddo
stop 'Negative thickness detected'
endif
diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90
index 14582d1eb5..27d69fc3d8 100644
--- a/src/core/MOM_continuity.F90
+++ b/src/core/MOM_continuity.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Solve the layer continuity equation.
module MOM_continuity
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_continuity_PPM, only : continuity=>continuity_PPM
use MOM_continuity_PPM, only : continuity_stencil=>continuity_PPM_stencil
use MOM_continuity_PPM, only : continuity_init=>continuity_PPM_init
diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90
index db60b2f0e4..a0bd64b78c 100644
--- a/src/core/MOM_continuity_PPM.F90
+++ b/src/core/MOM_continuity_PPM.F90
@@ -1,8 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+#include "do_concurrent_compat.h"
+
!> Solve the layer continuity equation using the PPM method for layer fluxes.
module MOM_continuity_PPM
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE
use MOM_diag_mediator, only : time_type, diag_ctrl
use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe
@@ -49,6 +53,9 @@ module MOM_continuity_PPM
!! discrepancies between the barotropic solution and
!! the sum of the layer thicknesses [L T-1 ~> m s-1].
real :: CFL_limit_adjust !< The maximum CFL of the adjusted velocities [nondim]
+ real :: h_marg_min !< Negligible floor on h_marg, the marginal thickness
+ !! used to calculate the partial derivative of transports
+ !! with velocities [H ~> m or kg m-2]
logical :: aggress_adjust !< If true, allow the adjusted velocities to have a
!! relative CFL change up to 0.5. False by default.
logical :: vol_CFL !< If true, use the ratio of the open face lengths
@@ -157,8 +164,10 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb
x_first = (MOD(G%first_direction,2) == 0)
if (present(visc_rem_u) .neqv. present(visc_rem_v)) call MOM_error(FATAL, &
- "MOM_continuity_PPM: Either both visc_rem_u and visc_rem_v or neither"// &
- " one must be present in call to continuity_PPM.")
+ "MOM_continuity_PPM: Either both visc_rem_u and visc_rem_v or neither "// &
+ "one must be present in call to continuity_PPM.")
+
+ !$omp target enter data map(alloc: h_W, h_E, h_S, h_N)
if (x_first) then
! First advect zonally, with loop bounds that accomodate the subsequent meridional advection.
@@ -168,6 +177,8 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb
LB, uhbt, visc_rem_u, u_cor, BT_cont, du_cor)
call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin)
+ ! update host h from continuity_zonal_convergence
+
! Now advect meridionally, using the updated thicknesses to determine the fluxes.
LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.)
call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC, LB)
@@ -191,6 +202,8 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb
call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hmin=h_min)
endif
+ !$omp target exit data map(delete: h_W, h_E, h_S, h_N)
+
end subroutine continuity_PPM
!> Finds the thickness fluxes from the continuity solver without actually updating the
@@ -360,22 +373,23 @@ subroutine continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin, hmin)
real, optional, intent(in) :: hmin !< The minimum layer thickness [H ~> m or kg m-2]
real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0.
- integer :: i, j, k
+ integer :: i, j, k, ish, ieh, jsh, jeh, nz
call cpu_clock_begin(id_clock_update)
h_min = 0.0 ; if (present(hmin)) h_min = hmin
+ ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke
+
if (present(hin)) then
- !$OMP parallel do default(shared)
- do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh
+ do concurrent (k=1:nz, j=jsh:jeh, i=ish:ieh)
h(i,j,k) = max( hin(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)), h_min )
- enddo ; enddo ; enddo
+ enddo
else
- !$OMP parallel do default(shared)
- do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh
+ ! untested
+ do concurrent (k=1:nz, j=jsh:jeh, i=ish:ieh)
h(i,j,k) = max( h(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)), h_min )
- enddo ; enddo ; enddo
+ enddo
endif
call cpu_clock_end(id_clock_update)
@@ -398,22 +412,23 @@ subroutine continuity_merdional_convergence(h, vh, dt, G, GV, LB, hin, hmin)
real, optional, intent(in) :: hmin !< The minimum layer thickness [H ~> m or kg m-2]
real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0.
- integer :: i, j, k
+ integer :: i, j, k, ish, ieh, jsh, jeh, nz
call cpu_clock_begin(id_clock_update)
+ ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke
+
h_min = 0.0 ; if (present(hmin)) h_min = hmin
if (present(hin)) then
- !$OMP parallel do default(shared)
- do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh
+ ! untested
+ do concurrent (k=1:nz, j=jsh:jeh, i=ish:ieh)
h(i,j,k) = max( hin(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)), h_min )
- enddo ; enddo ; enddo
+ enddo
else
- !$OMP parallel do default(shared)
- do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh
+ do concurrent (k=1:nz, j=jsh:jeh, i=ish:ieh)
h(i,j,k) = max( h(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)), h_min )
- enddo ; enddo ; enddo
+ enddo
endif
call cpu_clock_end(id_clock_update)
@@ -451,16 +466,12 @@ subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in)
ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke
if (CS%upwind_1st) then
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=jsh,jeh ; do i=ish-1,ieh+1
+ do concurrent (k=1:nz, j=jsh:jeh, i=ish-1:ieh+1)
h_W(i,j,k) = h_in(i,j,k) ; h_E(i,j,k) = h_in(i,j,k)
- enddo ; enddo ; enddo
- else
- !$OMP parallel do default(shared)
- do k=1,nz
- call PPM_reconstruction_x(h_in(:,:,k), h_W(:,:,k), h_E(:,:,k), G, LB, &
- 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC)
enddo
+ else
+ call PPM_reconstruction_x(h_in, h_W, h_E, G, GV, LB, &
+ 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC)
endif
call cpu_clock_end(id_clock_reconstruct)
@@ -498,16 +509,13 @@ subroutine meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB_in)
ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke
if (CS%upwind_1st) then
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=jsh-1,jeh+1 ; do i=ish,ieh
+ ! untested
+ do concurrent (k=1:nz, j=jsh-1:jeh+1, i=ish:ieh)
h_S(i,j,k) = h_in(i,j,k) ; h_N(i,j,k) = h_in(i,j,k)
- enddo ; enddo ; enddo
- else
- !$OMP parallel do default(shared)
- do k=1,nz
- call PPM_reconstruction_y(h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), G, LB, &
- 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC)
enddo
+ else
+ call PPM_reconstruction_y(h_in, h_S, h_N, G, GV, LB, &
+ 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC)
endif
call cpu_clock_end(id_clock_reconstruct)
@@ -559,18 +567,17 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa
!! as the depth-integrated transports [L T-1 ~> m s-1].
! Local variables
- real, dimension(SZIB_(G),SZK_(GV)) :: duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1].
- real, dimension(SZIB_(G)) :: &
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1].
+ real, dimension(SZIB_(G),SZJ_(G)) :: &
du, & ! Corrective barotropic change in the velocity to give uhbt [L T-1 ~> m s-1].
du_min_CFL, & ! Lower limit on du correction to avoid CFL violations [L T-1 ~> m s-1]
du_max_CFL, & ! Upper limit on du correction to avoid CFL violations [L T-1 ~> m s-1]
duhdu_tot_0, & ! Summed partial derivative of uh with u [H L ~> m2 or kg m-1].
uh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1].
visc_rem_max ! The column maximum of visc_rem [nondim].
- logical, dimension(SZIB_(G)) :: do_I
- real, dimension(SZIB_(G),SZK_(GV)) :: &
- visc_rem ! A 2-D copy of visc_rem_u or an array of 1's [nondim].
- real, dimension(SZIB_(G)) :: FAuI ! A list of sums of zonal face areas [H L ~> m2 or kg m-1].
+ real, dimension(SZIB_(G),SZJ_(G), SZK_(GV)) :: &
+ visc_rem_u_tmp ! A 2-D copy of visc_rem_u or an array of 1's [nondim].
+ real :: FAuI ! A sum of zonal face areas [H L ~> m2 or kg m-1].
real :: FA_u ! A sum of zonal face areas [H L ~> m2 or kg m-1].
real :: I_vrm ! 1.0 / visc_rem_max [nondim]
real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by
@@ -582,8 +589,7 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa
integer :: i, j, k, ish, ieh, jsh, jeh, n, nz
integer :: l_seg ! The OBC segment number
logical :: use_visc_rem, set_BT_cont
- logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals
- logical :: simple_OBC_pt(SZIB_(G)) ! Indicates points in a row with specified transport OBCs
+ logical :: local_specified_BC, local_open_BC, any_simple_OBC ! OBC-related logicals
call cpu_clock_begin(id_clock_correct)
@@ -591,15 +597,12 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa
set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont))
- local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false.
+ local_specified_BC = .false. ; local_open_BC = .false.
if (associated(OBC)) then ; if (OBC%OBC_pe) then
local_specified_BC = OBC%specified_u_BCs_exist_globally
- local_Flather_OBC = OBC%Flather_u_BCs_exist_globally
local_open_BC = OBC%open_u_BCs_exist_globally
endif ; endif
- if (present(du_cor)) du_cor(:,:) = 0.0
-
if (present(LB_in)) then
LB = LB_in
else
@@ -611,181 +614,316 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa
I_dt = 1.0 / dt
if (CS%aggress_adjust) CFL_dt = I_dt
- if (.not.use_visc_rem) visc_rem(:,:) = 1.0
- !$OMP parallel do default(shared) private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0, &
- !$OMP duhdu_tot_0,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, &
- !$OMP simple_OBC_pt,any_simple_OBC,l_seg) &
- !$OMP firstprivate(visc_rem)
- do j=jsh,jeh
- do I=ish-1,ieh ; do_I(I) = .true. ; enddo
+ !$omp target enter data &
+ !$omp map(alloc: visc_rem_u_tmp, duhdu, du, du_min_CFL, du_max_CFL, duhdu_tot_0, uh_tot_0, &
+ !$omp visc_rem_max)
+
+ do concurrent (j=jsh:jeh)
+
+ if (present(du_cor)) then
+ do concurrent (i=ish-1:ieh)
+ du_cor(i,j) = 0.0
+ enddo
+ endif
+
+ if (.not.use_visc_rem) then
+ do concurrent (k=1:nz, i=ish-1:ieh)
+ visc_rem_u_tmp(i,j,k) = 1.0
+ enddo
+ else
+ ! this is expensive
+ do concurrent (k=1:nz, i=ish-1:ieh)
+ visc_rem_u_tmp(i,j,k) = visc_rem_u(i,j,k)
+ enddo
+ end if
+
! Set uh and duhdu.
- do k=1,nz
- if (use_visc_rem) then ; do I=ish-1,ieh
- visc_rem(I,k) = visc_rem_u(I,j,k)
- enddo ; endif
- call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), &
- uh(:,j,k), duhdu(:,k), visc_rem(:,k), &
- dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC)
- 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)
- if (OBC%segment(l_seg)%specified) uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k)
- endif ; enddo
- endif
+ do concurrent (k=1:nz , I=ish-1:ieh)
+ call flux_elem(u(I,j,k), h_in(I,j,k), h_in(I+1,j,k), h_W(I,j,k), h_W(I+1,j,k), h_E(I,j,k), &
+ h_E(I+1,j,k), uh(I,j,k), duhdu(I,j,k), visc_rem_u_tmp(I,j,k), G%dy_Cu(I,j), &
+ G%IareaT(I,j), G%IareaT(I+1,j), G%IdxT(I,j), G%IdxT(i+1,j), dt, G, GV, US, &
+ CS%vol_CFL, por_face_areaU(I,j,k))
enddo
+ if (local_open_BC) then
+ do concurrent (k=1:nz, I=ish-1:ieh)
+ call flux_elem_OBC(u(I,j,k), h_in(I,j,k), h_in(I+1,j,k), uh(I,j,k), duhdu(I,j,k), &
+ visc_rem_u_tmp(I,j,k), G, GV, por_face_areaU(I,j,k), G%dy_Cu(I,j), &
+ OBC, OBC%segnum_u(I,j))
+ enddo
+ endif
+
+ ! untested!
+ if (local_specified_BC) then
+ do concurrent (k=1:nz, I=ish-1:ieh, OBC%segnum_u(I,j) /= 0)
+ 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)
+ enddo
+ endif
if (present(uhbt) .or. set_BT_cont) then
- if (use_visc_rem .and. CS%use_visc_rem_max) then
- visc_rem_max(:) = 0.0
- do k=1,nz ; do I=ish-1,ieh
- visc_rem_max(I) = max(visc_rem_max(I), visc_rem(I,k))
+ if (use_visc_rem.and.CS%use_visc_rem_max) then
+ ! poor performance for nvfortran + do concurrent if k is inside loop
+ do concurrent (I=ish-1:ieh)
+ visc_rem_max(I,j) = visc_rem_u_tmp(I,j,1)
+ enddo
+ do k=2,nz ; do concurrent (I=ish-1:ieh)
+ visc_rem_max(I,j) = max(visc_rem_max(I,j), visc_rem_u_tmp(I,j,k))
enddo ; enddo
else
- visc_rem_max(:) = 1.0
+ do concurrent (i=ish-1:ieh)
+ visc_rem_max(i, j) = 1.0
+ enddo
endif
! Set limits on du that will keep the CFL number between -1 and 1.
! This should be adequate to keep the root bracketed in all cases.
- do I=ish-1,ieh
+ do concurrent (I=ish-1:ieh)
I_vrm = 0.0
- if (visc_rem_max(I) > 0.0) I_vrm = 1.0 / visc_rem_max(I)
+ if (visc_rem_max(I,j) > 0.0) I_vrm = 1.0 / visc_rem_max(I,j)
if (CS%vol_CFL) then
dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j))
dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j))
else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif
- du_max_CFL(I) = 2.0* (CFL_dt * dx_W) * I_vrm
- du_min_CFL(I) = -2.0 * (CFL_dt * dx_E) * I_vrm
- uh_tot_0(I) = 0.0 ; duhdu_tot_0(I) = 0.0
+ du_max_CFL(I,j) = 2.0* (CFL_dt * dx_W) * I_vrm
+ du_min_CFL(I,j) = -2.0 * (CFL_dt * dx_E) * I_vrm
+ uh_tot_0(I,j) = 0.0 ; duhdu_tot_0(I,j) = 0.0
enddo
- do k=1,nz ; do I=ish-1,ieh
- duhdu_tot_0(I) = duhdu_tot_0(I) + duhdu(I,k)
- uh_tot_0(I) = uh_tot_0(I) + uh(I,j,k)
+ ! poor performance for nvfortran + do concurrent if k is inside loop
+ do k=1,nz ; do concurrent (I=ish-1:ieh)
+ duhdu_tot_0(I,j) = duhdu_tot_0(I,j) + duhdu(I, j, k)
+ uh_tot_0(I,j) = uh_tot_0(I,j) + uh(I,j,k)
enddo ; enddo
+
if (use_visc_rem) then
if (CS%aggress_adjust) then
- do k=1,nz ; do I=ish-1,ieh
+ ! untested!
+ do k=1,nz ; do concurrent (I=ish-1:ieh)
if (CS%vol_CFL) then
dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j))
dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j))
else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif
du_lim = 0.499*((dx_W*I_dt - u(I,j,k)) + MIN(0.0,u(I-1,j,k)))
- if (du_max_CFL(I) * visc_rem(I,k) > du_lim) &
- du_max_CFL(I) = du_lim / visc_rem(I,k)
+ if (du_max_CFL(I,j) * visc_rem_u_tmp(I,j,k) > du_lim) &
+ du_max_CFL(I,j) = du_lim / visc_rem_u_tmp(I,j,k)
du_lim = 0.499*((-dx_E*I_dt - u(I,j,k)) + MAX(0.0,u(I+1,j,k)))
- if (du_min_CFL(I) * visc_rem(I,k) < du_lim) &
- du_min_CFL(I) = du_lim / visc_rem(I,k)
+ if (du_min_CFL(I,j) * visc_rem_u_tmp(I,j,k) < du_lim) &
+ du_min_CFL(I,j) = du_lim / visc_rem_u_tmp(I,j,k)
enddo ; enddo
else
- do k=1,nz ; do I=ish-1,ieh
+ do k=1,nz ; do concurrent (I=ish-1:ieh)
if (CS%vol_CFL) then
dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j))
dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j))
else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif
- if (du_max_CFL(I) * visc_rem(I,k) > dx_W*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) &
- du_max_CFL(I) = (dx_W*CFL_dt - u(I,j,k)) / visc_rem(I,k)
- if (du_min_CFL(I) * visc_rem(I,k) < -dx_E*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) &
- du_min_CFL(I) = -(dx_E*CFL_dt + u(I,j,k)) / visc_rem(I,k)
+ if (du_max_CFL(I,j) * visc_rem_u_tmp(I,j,k) > dx_W*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) &
+ du_max_CFL(I,j) = (dx_W*CFL_dt - u(I,j,k)) / visc_rem_u_tmp(I,j,k)
+ if (du_min_CFL(I,j) * visc_rem_u_tmp(I,j,k) < -dx_E*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) &
+ du_min_CFL(I,j) = -(dx_E*CFL_dt + u(I,j,k)) / visc_rem_u_tmp(I,j,k)
enddo ; enddo
endif
else
+ ! untested!
if (CS%aggress_adjust) then
- do k=1,nz ; do I=ish-1,ieh
+ do k=1,nz ; do concurrent (I=ish-1:ieh)
if (CS%vol_CFL) then
dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j))
dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j))
else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif
- du_max_CFL(I) = MIN(du_max_CFL(I), 0.499 * &
+ du_max_CFL(I,j) = MIN(du_max_CFL(I,j), 0.499 * &
((dx_W*I_dt - u(I,j,k)) + MIN(0.0,u(I-1,j,k))) )
- du_min_CFL(I) = MAX(du_min_CFL(I), 0.499 * &
+ du_min_CFL(I,j) = MAX(du_min_CFL(I,j), 0.499 * &
((-dx_E*I_dt - u(I,j,k)) + MAX(0.0,u(I+1,j,k))) )
enddo ; enddo
else
- do k=1,nz ; do I=ish-1,ieh
+ do k=1,nz ; do concurrent (I=ish-1:ieh)
if (CS%vol_CFL) then
dx_W = ratio_max(G%areaT(i,j), G%dy_Cu(I,j), 1000.0*G%dxT(i,j))
dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j))
else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif
- du_max_CFL(I) = MIN(du_max_CFL(I), dx_W*CFL_dt - u(I,j,k))
- du_min_CFL(I) = MAX(du_min_CFL(I), -(dx_E*CFL_dt + u(I,j,k)))
+ du_max_CFL(I,j) = MIN(du_max_CFL(I,j), dx_W*CFL_dt - u(I,j,k))
+ du_min_CFL(I,j) = MAX(du_min_CFL(I,j), -(dx_E*CFL_dt + u(I,j,k)))
enddo ; enddo
- endif
- endif
- do I=ish-1,ieh
- du_max_CFL(I) = max(du_max_CFL(I),0.0)
- du_min_CFL(I) = min(du_min_CFL(I),0.0)
+ endif ! CS%agress_adjust
+ endif ! use_visc_rem
+ do concurrent (I=ish-1:ieh)
+ du_max_CFL(I,j) = max(du_max_CFL(I,j),0.0)
+ du_min_CFL(I,j) = min(du_min_CFL(I,j),0.0)
enddo
+ endif ! present(uhbt) .or. set_BT_cont
+ enddo
- 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)
-
- ! 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
- do_I(I) = .not.simple_OBC_pt(I)
- any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(I)
- enddo ; else ; do I=ish-1,ieh
- do_I(I) = .true.
- enddo ; endif
- endif
+ call present_uhbt_or_set_BT_cont(u, h_in, h_W, h_E, uh_tot_0, duhdu_tot_0, du, du_max_CFL, &
+ du_min_CFL, visc_rem_u_tmp, visc_rem_max, por_face_areaU, uhbt, &
+ uh, u_cor, du_cor, BT_cont, dt, G, GV, US, CS, OBC, LB)
- if (present(uhbt)) then
- ! Find du and uh.
- call zonal_flux_adjust(u, h_in, h_W, h_E, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, &
- du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, &
- j, ish, ieh, do_I, por_face_areaU, uh, OBC=OBC)
+ !$omp target exit data &
+ !$omp map(release: visc_rem_u_tmp, duhdu, du, du_min_CFL, du_max_CFL, duhdu_tot_0, uh_tot_0, &
+ !$omp visc_rem_max)
- 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)
- endif ; enddo ; endif
- enddo ; endif ! u-corrected
+ call cpu_clock_end(id_clock_correct)
- if (present(du_cor)) then
- do I=ish-1,ieh ; du_cor(I,j) = du(I) ; enddo
- endif
+end subroutine zonal_mass_flux
- endif
+subroutine present_uhbt_or_set_BT_cont(u, h_in, h_W, h_E, uh_tot_0, duhdu_tot_0, du, du_max_CFL, &
+ du_min_CFL, visc_rem_u, visc_rem_max, por_face_areaU, uhbt, &
+ uh, u_cor, du_cor, BT_cont, dt, G, GV, US, CS, OBC, LB)
+ type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_W !< Western edge thicknesses [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_E !< Eastern edge thicknesses [H ~> m or kg m-2].
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: uh_tot_0 !< Summed transport with no barotropic correction
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: duhdu_tot_0 !< Summed partial derivative of uh with u
+ !! [H L ~> m2 or kg m-1].
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(inout) :: du !< Corrective barotropic change in the velocity to give uhbt
+ !! [L T-1 ~> m s-1].
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: du_max_CFL !< Upper limit on du correction to avoid CFL violations
+ !! [L T-1 ~> m s-1]
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: du_min_CFL !< Lower limit on du correction to avoid CFL violations
+ !![L T-1 ~> m s-1]
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
+ intent(inout) :: uh !< Volume flux through zonal faces = u*h*dy
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: visc_rem_u
+ !< The fraction of zonal momentum originally in a layer that remains after a
+ !! time-step of viscosity, and the fraction of a time-step's worth of a barotropic
+ !! acceleration that a layer experiences after viscosity is applied [nondim].
+ !! Visc_rem_u is between 0 (at the bottom) and 1 (far above the bottom).
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: visc_rem_max !< The column maximum of visc_rem [nondim].
+ real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), &
+ intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim]
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
+ optional, intent(out) :: u_cor !< The zonal velocities (u with a barotropic correction)
+ !! that give uhbt as the depth-integrated transport [L T-1 ~> m s-1]
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ optional, intent(out) :: du_cor !< The zonal velocity increments from u that give uhbt
+ !! as the depth-integrated transports [L T-1 ~> m s-1].
+ type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the
+ !! effective open face areas as a function of barotropic flow.
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ optional, intent(in) :: uhbt !< The summed volume flux through zonal faces
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, intent(in) :: dt !< Time increment [T ~> s].
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
+ type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure.
+ type(cont_loop_bounds_type), intent(in) :: LB !< Loop boundary variable.
+ ! Local variables
+ logical, dimension(SZIB_(G), SZJ_(G)) :: do_I
+ logical, dimension(SZIB_(G), SZJ_(G)) :: simple_OBC_pt ! Indicates points in a row with specified transport OBCs
+ logical:: set_BT_cont
+ logical:: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals
+ integer:: l_seg, i, j, k, n, ish, ieh, jsh, jeh, nz
+ real :: FAuI, FA_u
- if (set_BT_cont) then
- call set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0,&
- du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, &
- visc_rem_max, j, ish, ieh, do_I, por_face_areaU)
- if (any_simple_OBC) then
- do I=ish-1,ieh
- if (simple_OBC_pt(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j)
- 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)
- 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)
- BT_cont%FA_u_WW(I,j) = FAuI(I) ; BT_cont%FA_u_EE(I,j) = FAuI(I)
- BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0
- endif ; enddo
- endif
- endif ! set_BT_cont
+ ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke
- endif ! present(uhbt) or set_BT_cont
+ set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont))
- enddo ! j-loop
+ local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false.
+ if (associated(OBC)) then ; if (OBC%OBC_pe) then
+ local_specified_BC = OBC%specified_u_BCs_exist_globally
+ local_Flather_OBC = OBC%Flather_u_BCs_exist_globally
+ local_open_BC = OBC%open_u_BCs_exist_globally
+ endif ; endif
+
+ if (present(uhbt) .or. set_BT_cont) then
+ !$omp target enter data map(alloc: do_I, simple_OBC_pt)
+ any_simple_OBC = .false.
+ if (local_specified_BC .or. local_Flather_OBC) then
+ do concurrent (j=jsh:jeh, I=ish-1:ieh)
+ l_seg = abs(OBC%segnum_u(I,j))
+ ! Avoid reconciling barotropic/baroclinic transports if transport is specified
+ simple_OBC_pt(I,j) = .false.
+ if (l_seg /= OBC_NONE) simple_OBC_pt(I,j) = OBC%segment(l_seg)%specified
+ do_I(I, j) = .not.simple_OBC_pt(I,j)
+ any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(I,j)
+ enddo
+ else
+ do concurrent (j=jsh:jeh, I=ish-1:ieh)
+ do_I(I, j) = .true.
+ enddo
+ endif
+
+ if (present(uhbt)) then
+ ! Find du and uh.
+ call zonal_flux_adjust(u, h_in, h_W, h_E, uh_tot_0, duhdu_tot_0, du, &
+ du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem_u, &
+ ish, ieh, jsh, jeh, do_I, por_face_areaU, uhbt, uh, OBC=OBC)
+
+ do concurrent (j=jsh:jeh)
+ if (present(u_cor)) then
+ do concurrent (k=1:nz, I=ish-1:ieh)
+ u_cor(I,j,k) = u(I,j,k) + du(I,j) * visc_rem_u(I,j,k)
+ enddo
+ if (any_simple_OBC) then
+ ! untested
+ do concurrent (k=1:nz, I=ish-1:ieh, simple_OBC_pt(I,j))
+ u_cor(I,j,k) = OBC%segment(abs(OBC%segnum_u(I,j)))%normal_vel(I,j,k)
+ enddo
+ endif
+ endif ! u-corrected
+
+ if (present(du_cor)) then
+ do concurrent (I=ish-1:ieh)
+ du_cor(I,j) = du(I,j)
+ enddo
+ endif ! du-corrected
+ enddo
+ endif
+ if (set_BT_cont) then
+ ! Diagnose the zero-transport correction, du0.
+ call zonal_flux_adjust(u, h_in, h_W, h_E, uh_tot_0, duhdu_tot_0, du, &
+ du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem_u, &
+ ish, ieh, jsh, jeh, do_I, por_face_areaU)
+ call set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, du, uh_tot_0, duhdu_tot_0,&
+ du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem_u, &
+ visc_rem_max, ish, ieh, jsh, jeh, do_I, por_face_areaU)
+ if (any_simple_OBC) then
+ ! untested
+ do concurrent (j=jsh:jeh, I=ish-1:ieh)
+ ! NOTE: simple_OBC_pt(I, j) should prevent access to segment OBC_NONE
+ if (simple_OBC_pt(I,j)) then
+ FAuI = GV%H_subroundoff*G%dy_Cu(I,j)
+ do k=1,nz
+ 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 = FAuI + OBC%segment(l_seg)%normal_trans(I,j,k) / OBC%segment(l_seg)%normal_vel(I,j,k)
+ enddo
+ BT_cont%FA_u_W0(I,j) = FAuI ; BT_cont%FA_u_E0(I,j) = FAuI
+ BT_cont%FA_u_WW(I,j) = FAuI ; BT_cont%FA_u_EE(I,j) = FAuI
+ BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0
+ endif
+ enddo
+ endif
+ endif
+ !$omp target exit data map(release: do_I, simple_OBC_pt)
+ endif
+ ! untested!
if (local_open_BC .and. set_BT_cont) then
do n = 1, OBC%number_of_segments
if (OBC%segment(n)%open .and. OBC%segment(n)%is_E_or_W) then
I = OBC%segment(n)%HI%IsdB
if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- do j = OBC%segment(n)%HI%Jsd, OBC%segment(n)%HI%Jed
+ do concurrent (j = OBC%segment(n)%HI%Jsd:OBC%segment(n)%HI%Jed)
FA_u = 0.0
do k=1,nz ; FA_u = FA_u + h_in(i,j,k)*(G%dy_Cu(I,j)*por_face_areaU(I,j,k)) ; enddo
BT_cont%FA_u_W0(I,j) = FA_u ; BT_cont%FA_u_E0(I,j) = FA_u
@@ -793,7 +931,7 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa
BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0
enddo
else
- do j = OBC%segment(n)%HI%Jsd, OBC%segment(n)%HI%Jed
+ do concurrent (j = OBC%segment(n)%HI%Jsd:OBC%segment(n)%HI%Jed)
FA_u = 0.0
do k=1,nz ; FA_u = FA_u + h_in(i+1,j,k)*(G%dy_Cu(I,j)*por_face_areaU(I,j,k)) ; enddo
BT_cont%FA_u_W0(I,j) = FA_u ; BT_cont%FA_u_E0(I,j) = FA_u
@@ -815,9 +953,7 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa
endif
endif ; endif
- call cpu_clock_end(id_clock_correct)
-
-end subroutine zonal_mass_flux
+end subroutine present_uhbt_or_set_BT_cont
!> Calculates the vertically integrated mass or volume fluxes through the zonal faces.
@@ -843,12 +979,11 @@ subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, p
type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure.
! Local variables
- real :: uh(SZIB_(G)) ! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]
- real :: duhdu(SZIB_(G)) ! Partial derivative of uh with u [H L ~> m2 or kg m-1].
- logical, dimension(SZIB_(G)) :: do_I
- real :: ones(SZIB_(G)) ! An array of 1's [nondim]
- integer :: i, j, k, ish, ieh, jsh, jeh, nz
- logical :: local_specified_BC, OBC_in_row
+ real :: uh(SZIB_(G),SZJ_(G),SZK_(GV)) ! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]
+ real :: duhdu(SZIB_(G),SZJ_(G),SZK_(GV)) ! Partial derivative of uh with u [H L ~> m2 or kg m-1].
+ integer :: i, j, k, ish, ieh, jsh, jeh, nz, l_seg
+ logical :: local_specified_BC
+ logical, dimension(SZJ_(G)) :: OBC_in_row
call cpu_clock_begin(id_clock_correct)
@@ -863,113 +998,149 @@ subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, p
ish = G%isc ; ieh = G%iec ; jsh = G%jsc ; jeh = G%jec ; nz = GV%ke
endif
- ones(:) = 1.0 ; do_I(:) = .true.
+ OBC_in_row(:) = .false.
uhbt(:,:) = 0.0
- !$OMP parallel do default(shared) private(uh,duhdu,OBC_in_row)
- do j=jsh,jeh
- ! Determining whether there are any OBC points outside of the k-loop should be more efficient.
- OBC_in_row = .false.
- if (local_specified_BC) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then
- if (OBC%segment(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)
- endif ; enddo ; endif
-
- ! Accumulate the barotropic transport.
- do I=ish-1,ieh
- uhbt(I,j) = uhbt(I,j) + uh(I)
- enddo
- enddo ! k-loop
- enddo ! j-loop
+
+ ! Determining whether there are any OBC points outside of the k-loop should be more efficient.
+ if (local_specified_BC) then
+ do j=jsh,jeh ; 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(j) = .true.
+ endif ; enddo ; enddo
+ endif
+
+ ! This sets uh and duhdu.
+ do concurrent (k=1:nz, j=jsh:jeh, I=ish-1:ieh)
+ call flux_elem(u(I,j,k), h_in(I,j,k), h_in(I+1,j,k), h_W(I,j,k), h_W(I+1,j,k), h_E(I,j,k), &
+ h_E(I+1,j,k), uh(I,j,k), duhdu(I,j,k), 1.0, G%dy_Cu(I,j), G%IareaT(I,j), &
+ G%IareaT(I+1,j), G%IdxT(I,j), G%IdxT(I+1,j), dt, G, GV, US, CS%vol_CFL, &
+ por_face_areaU(I,j,k))
+ if (local_specified_BC) &
+ call flux_elem_OBC(u(I,j,k), h_in(I,j,k), h_in(I+1,j,k), uh(I,j,k), duhdu(I,j,k), 1.0, G, GV, &
+ por_face_areaU(I,j,k), G%dy_Cu(I,j), OBC, OBC%segnum_u(I,j))
+ enddo
+
+ do k=1,nz ; do j=jsh,jeh ; do i=ish-1,ieh
+ if (OBC_in_row(j) .and. 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 ; enddo ; enddo
+
+ ! Accumulate the barotropic transport.
+ do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh
+ uhbt(I,j) = uhbt(I,j) + uh(I,j,k)
+ enddo ; enddo ; enddo ! j-loop
+
call cpu_clock_end(id_clock_correct)
end subroutine zonal_BT_mass_flux
-
-!> Evaluates the zonal mass or volume fluxes in a layer.
-subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, &
- ish, ieh, do_I, vol_CFL, por_face_areaU, OBC)
- type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1].
- real, dimension(SZIB_(G)), intent(in) :: visc_rem !< Both the fraction of the
+!> Evaluates the zonal mass or volume fluxes in an element.
+elemental subroutine flux_elem(u, h, h_p1, h_L, h_L_p1, h_R, h_R_p1, uh, duhdu, visc_rem, &
+ G_dy_Cu, G_IareaT, G_IareaT_p1, G_IdxT, G_IdxT_p1, dt, G, GV, &
+ US, vol_CFL, por_face_area)
+ type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, intent(in) :: u !< Zonal or meridional velocity [L T-1 ~> m s-1].
+ real, intent(in) :: visc_rem !< Both the fraction of the
!! momentum originally in a layer that remains after a time-step
!! of viscosity, and the fraction of a time-step's worth of a barotropic
!! acceleration that a layer experiences after viscosity is applied [nondim].
!! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom).
- real, dimension(SZI_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2].
- real, dimension(SZI_(G)), intent(in) :: h_W !< West edge thickness [H ~> m or kg m-2].
- real, dimension(SZI_(G)), intent(in) :: h_E !< East edge thickness [H ~> m or kg m-2].
- real, dimension(SZIB_(G)), intent(inout) :: uh !< Zonal mass or volume
- !! transport [H L2 T-1 ~> m3 s-1 or kg s-1].
- real, dimension(SZIB_(G)), intent(inout) :: duhdu !< Partial derivative of uh
- !! with u [H L ~> m2 or kg m-1].
- real, intent(in) :: dt !< Time increment [T ~> s]
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- integer, intent(in) :: j !< Spatial index.
- integer, intent(in) :: ish !< Start of index range.
- integer, intent(in) :: ieh !< End of index range.
- logical, dimension(SZIB_(G)), intent(in) :: do_I !< Which i values to work on.
- logical, intent(in) :: vol_CFL !< If true, rescale the
- real, dimension(SZIB_(G)), intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim]
- !! ratio of face areas to the cell areas when estimating the CFL number.
- type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure.
+ real, intent(in) :: h !< Layer thickness [H ~> m or kg m-2].
+ real, intent(in) :: h_p1 !< Layer thickness - offset by 1 [ H ~> m or kg m-2].
+ real, intent(in) :: h_L !< West/South edge thickness [H ~> m or kg m-2].
+ real, intent(in) :: h_L_p1 !< West/South edge thickness - offset by 1 [H ~> m or kg m-2].
+ real, intent(in) :: h_R !< East/North edge thickness [H ~> m or kg m-2].
+ real, intent(in) :: h_R_p1 !< East/North edge thickness - offset by 1 [H ~> m or kg m-2].
+ real, intent(out) :: uh !< Zonal or meridional mass or volume transport
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, intent(out) :: duhdu !< Partial derivative of uh
+ !! with u [H L ~> m2 or kg m-1].
+ real, intent(in) :: dt !< Time increment [T ~> s]
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type.
+ logical, intent(in) :: vol_CFL !< If true, rescale the ratio of face areas to the
+ !! cell areas when estimating the CFL number.
+ real, intent(in) :: por_face_area !< fractional open area of U/V-faces [nondim].
+ real, intent(in) :: G_dy_Cu !< The grid cell's unblocked lengths of the u/v-faces
+ !! of the h-cell [L ~> m].
+ real, intent(in) :: G_IareaT !< The grid cell's 1/areaT [L-2 ~> m-2].
+ real, intent(in) :: G_IareaT_p1 !< The grid cell's 1/areaT - offset by 1 [L-2 ~> m-2].
+ real, intent(in) :: G_IdxT !< The grid cell's 1/dxT [L-1 ~> m-1].
+ real, intent(in) :: G_IdxT_p1 !< The grid cell's 1/dxT - offset by 1 [L-1 ~> m-1].
! Local variables
real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]
real :: curv_3 ! A measure of the thickness curvature over a grid length [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.
- if (present(OBC)) then ; if (associated(OBC)) then
- local_open_BC = OBC%open_u_BCs_exist_globally
- endif ; endif
+ real :: tmp ! temporary variable to store precalculted values
+ real :: dh ! h differential between E/W
+
+ ! Set new values of uh and duhdu.
+ tmp = G_dy_Cu * por_face_area ! precalculate things
+ if (u > 0.0) then
+ if (vol_CFL) then ; CFL = (u * dt) * (G_dy_Cu * G_IareaT)
+ else ; CFL = u * dt * G_IdxT ; endif
+ curv_3 = (h_L + h_R) - 2.0*h
+ dh = h_L - h_R
+ uh = tmp * u * &
+ (h_R + CFL * (0.5*dh + curv_3*(CFL - 1.5)))
+ h_marg = h_R + CFL * (dh + 3.0*curv_3*(CFL - 1.0))
+ elseif (u < 0.0) then
+ if (vol_CFL) then ; CFL = (-u * dt) * (G_dy_Cu * G_IareaT_p1)
+ else ; CFL = -u * dt * G_IdxT_p1 ; endif
+ curv_3 = (h_L_p1 + h_R_p1) - 2.0*h_p1
+ dh = h_R_p1-h_L_p1
+ uh = tmp * u * &
+ (h_L_p1 + CFL * (0.5*dh + curv_3*(CFL - 1.5)))
+ h_marg = h_L_p1 + CFL * (dh + 3.0*curv_3*(CFL - 1.0))
+ else
+ uh = 0.0
+ h_marg = 0.5 * (h_L_p1 + h_R)
+ endif
+ duhdu = tmp * h_marg * visc_rem
- do I=ish-1,ieh ; if (do_I(I)) then
- ! Set new values of uh and duhdu.
- if (u(I) > 0.0) then
- if (vol_CFL) then ; CFL = (u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j))
- else ; CFL = u(I) * dt * G%IdxT(i,j) ; endif
- curv_3 = (h_W(i) + h_E(i)) - 2.0*h(i)
- uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * &
- (h_E(i) + CFL * (0.5*(h_W(i) - h_E(i)) + curv_3*(CFL - 1.5)))
- h_marg = h_E(i) + CFL * ((h_W(i) - h_E(i)) + 3.0*curv_3*(CFL - 1.0))
- elseif (u(I) < 0.0) then
- if (vol_CFL) then ; CFL = (-u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j))
- else ; CFL = -u(I) * dt * G%IdxT(i+1,j) ; endif
- curv_3 = (h_W(i+1) + h_E(i+1)) - 2.0*h(i+1)
- uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * &
- (h_W(i+1) + CFL * (0.5*(h_E(i+1)-h_W(i+1)) + curv_3*(CFL - 1.5)))
- h_marg = h_W(i+1) + CFL * ((h_E(i+1)-h_W(i+1)) + 3.0*curv_3*(CFL - 1.0))
- else
- uh(I) = 0.0
- h_marg = 0.5 * (h_W(i+1) + h_E(i))
- endif
- duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h_marg * visc_rem(I)
- endif ; enddo
+end subroutine flux_elem
- 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
- uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i)
- duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h(i) * visc_rem(I)
- else
- uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i+1)
- duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * h(i+1) * visc_rem(I)
- endif
+elemental subroutine flux_elem_OBC(u, h, h_p1, uh, duhdu, visc_rem, G, GV, por_face_area, &
+ G_dy_Cu, OBC, l_seg)
+ type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, intent(in) :: u !< Zonal/meridional velocity [L T-1 ~> m s-1].
+ real, intent(in) :: visc_rem !< Both the fraction of the
+ !! momentum originally in a layer that remains after a time-step
+ !! of viscosity, and the fraction of a time-step's worth of a barotropic
+ !! acceleration that a layer experiences after viscosity is applied [nondim].
+ !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom).
+ real, intent(in) :: h !< Layer thickness [H ~> m or kg m-2].
+ real, intent(in) :: h_p1 !< Layer thickness offset by 1 [H ~> m or kg m-2].
+ real, intent(inout) :: uh !< Zonal/meridional mass or volume
+ !! transport [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, intent(inout) :: duhdu !< Partial derivative of uh
+ !! with u [H L ~> m2 or kg m-1].
+ real, intent(in) :: por_face_area !< fractional open area of U/V-faces
+ !! [nondim].
+ real, intent(in) :: G_dy_Cu !< The grid cell's unblocked lengths of the
+ !! u/v-faces of the h-cell [L ~> m].
+ !! ratio of face areas to the cell areas when estimating the CFL number.
+ type(ocean_OBC_type), intent(in) :: OBC !< Open boundaries control structure.
+ integer, intent(in) :: l_seg !< Segment index.
+
+ ! untested
+ if (l_seg /= 0) then
+ if (OBC%segment(abs(l_seg))%open) then
+ if (l_seg > 0) then ! OBC_DIRECTION_E or OBC_DIRECTION_N
+ uh = (G_dy_Cu * por_face_area) * u * h
+ duhdu = (G_dy_Cu * por_face_area) * h * visc_rem
+ else ! OBC_DIRECTION_W or OBC_DIRECTION_S
+ uh = (G_dy_Cu * por_face_area) * u * h_p1
+ duhdu = (G_dy_Cu* por_face_area) * h_p1 * visc_rem
endif
- endif ; endif ; enddo
+ endif
endif
-end subroutine zonal_flux_layer
+
+end subroutine flux_elem_OBC
+
!> Sets the effective interface thickness associated with the fluxes at each zonal velocity point,
!! optionally scaling back these thicknesses to account for viscosity and fractional open areas.
@@ -1008,80 +1179,77 @@ subroutine zonal_flux_thickness(u, h, h_W, h_E, h_u, dt, G, GV, US, LB, vol_CFL,
! Local variables
real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]
real :: curv_3 ! A measure of the thickness curvature over a grid length [H ~> m or kg m-2]
- real :: h_avg ! The average thickness of a flux [H ~> m or kg m-2].
- real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2].
logical :: local_open_BC
integer :: i, j, k, ish, ieh, jsh, jeh, nz, n
+ real :: dh
ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke
- !$OMP parallel do default(shared) private(CFL,curv_3,h_marg,h_avg)
- do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh
+ do concurrent (k=1:nz, j=jsh:jeh, I=ish-1:ieh)
if (u(I,j,k) > 0.0) then
if (vol_CFL) then ; CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j))
else ; CFL = u(I,j,k) * dt * G%IdxT(i,j) ; endif
curv_3 = (h_W(i,j,k) + h_E(i,j,k)) - 2.0*h(i,j,k)
- h_avg = h_E(i,j,k) + CFL * (0.5*(h_W(i,j,k) - h_E(i,j,k)) + curv_3*(CFL - 1.5))
- h_marg = h_E(i,j,k) + CFL * ((h_W(i,j,k) - h_E(i,j,k)) + 3.0*curv_3*(CFL - 1.0))
+ dh = h_W(i,j,k) - h_E(i,j,k)
+ if (marginal) then
+ h_u(I,j,k) = h_E(i,j,k) + CFL * (dh + 3.0*curv_3*(CFL - 1.0))
+ else
+ h_u(I,j,k) = h_E(i,j,k) + CFL * (0.5*dh + curv_3*(CFL - 1.5))
+ endif
elseif (u(I,j,k) < 0.0) then
if (vol_CFL) then ; CFL = (-u(I,j,k)*dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j))
else ; CFL = -u(I,j,k) * dt * G%IdxT(i+1,j) ; endif
curv_3 = (h_W(i+1,j,k) + h_E(i+1,j,k)) - 2.0*h(i+1,j,k)
- h_avg = h_W(i+1,j,k) + CFL * (0.5*(h_E(i+1,j,k)-h_W(i+1,j,k)) + curv_3*(CFL - 1.5))
- h_marg = h_W(i+1,j,k) + CFL * ((h_E(i+1,j,k)-h_W(i+1,j,k)) + &
- 3.0*curv_3*(CFL - 1.0))
+ dh = h_E(i+1,j,k)-h_W(i+1,j,k)
+ if (marginal) then
+ h_u(I,j,k) = h_W(i+1,j,k) + CFL * (dh + 3.0*curv_3*(CFL - 1.0))
+ else
+ h_u(I,j,k) = h_W(i+1,j,k) + CFL * (0.5*dh + curv_3*(CFL - 1.5))
+ endif
else
- h_avg = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k))
! The choice to use the arithmetic mean here is somewhat arbitrarily, but
! it should be noted that h_W(i+1,j,k) and h_E(i,j,k) are usually the same.
- h_marg = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k))
+ h_u(I,j,k) = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k))
! h_marg = (2.0 * h_W(i+1,j,k) * h_E(i,j,k)) / &
! (h_W(i+1,j,k) + h_E(i,j,k) + GV%H_subroundoff)
endif
- if (marginal) then ; h_u(I,j,k) = h_marg
- else ; h_u(I,j,k) = h_avg ; endif
- enddo ; enddo ; enddo
- if (present(visc_rem_u)) then
- ! Scale back the thickness to account for the effects of viscosity and the fractional open
- ! thickness to give an appropriate non-normalized weight for each layer in determining the
- ! barotropic acceleration.
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh
+ if (present(visc_rem_u)) then
+ ! Scale back the thickness to account for the effects of viscosity and the fractional open
+ ! thickness to give an appropriate non-normalized weight for each layer in determining the
+ ! barotropic acceleration.
h_u(I,j,k) = h_u(I,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k))
- enddo ; enddo ; enddo
- else
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh
+ else
h_u(I,j,k) = h_u(I,j,k) * por_face_areaU(I,j,k)
- enddo ; enddo ; enddo
- endif
+ endif
+ enddo
local_open_BC = .false.
if (associated(OBC)) local_open_BC = OBC%open_u_BCs_exist_globally
if (local_open_BC) then
+ ! untested
do n = 1, OBC%number_of_segments
if (OBC%segment(n)%open .and. OBC%segment(n)%is_E_or_W) then
I = OBC%segment(n)%HI%IsdB
if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- if (present(visc_rem_u)) then ; do k=1,nz
- do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed
+ if (present(visc_rem_u)) then
+ do concurrent (k=1:nz, j = OBC%segment(n)%HI%jsd:OBC%segment(n)%HI%jed)
h_u(I,j,k) = h(i,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k))
enddo
- enddo ; else ; do k=1,nz
- do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed
+ else
+ do concurrent (k=1:nz, j = OBC%segment(n)%HI%jsd:OBC%segment(n)%HI%jed)
h_u(I,j,k) = h(i,j,k) * por_face_areaU(I,j,k)
enddo
- enddo ; endif
+ endif
else
- if (present(visc_rem_u)) then ; do k=1,nz
- do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed
+ if (present(visc_rem_u)) then
+ do concurrent (k=1:nz, j = OBC%segment(n)%HI%jsd:OBC%segment(n)%HI%jed)
h_u(I,j,k) = h(i+1,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k))
enddo
- enddo ; else ; do k=1,nz
- do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed
+ else
+ do concurrent (k=1:nz, j = OBC%segment(n)%HI%jsd:OBC%segment(n)%HI%jed)
h_u(I,j,k) = h(i+1,j,k) * por_face_areaU(I,j,k)
enddo
- enddo ; endif
+ endif
endif
endif
enddo
@@ -1091,215 +1259,261 @@ end subroutine zonal_flux_thickness
!> Returns the barotropic velocity adjustment that gives the
!! desired barotropic (layer-summed) transport.
-subroutine zonal_flux_adjust(u, h_in, h_W, h_E, uhbt, uh_tot_0, duhdu_tot_0, &
+subroutine zonal_flux_adjust(u, h_in, h_W, h_E, uh_tot_0, duhdu_tot_0, &
du, du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, &
- j, ish, ieh, do_I_in, por_face_areaU, uh_3d, OBC)
-
- type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
- real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to
- !! calculate fluxes [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the
- !! reconstruction [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the
- !! reconstruction [H ~> m or kg m-2].
- real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the
+ ish, ieh, jsh, jeh, do_I_in, por_face_areaU, uhbt, uh_3d, OBC)
+
+ type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to
+ !! calculate fluxes [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the
+ !! reconstruction [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the
+ !! reconstruction [H ~> m or kg m-2].
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the
!! momentum originally in a layer that remains after a time-step of viscosity, and
!! the fraction of a time-step's worth of a barotropic acceleration that a layer
!! experiences after viscosity is applied [nondim].
!! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom).
- real, dimension(SZIB_(G)), intent(in) :: uhbt !< The summed volume flux
+ real, dimension(SZIB_(G),SZJ_(G)), optional, intent(in) :: uhbt !< The summed volume flux
!! through zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1].
-
- real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable
+ real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: du_max_CFL !< Maximum acceptable
!! value of du [L T-1 ~> m s-1].
- real, dimension(SZIB_(G)), intent(in) :: du_min_CFL !< Minimum acceptable
+ real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: du_min_CFL !< Minimum acceptable
!! value of du [L T-1 ~> m s-1].
- real, dimension(SZIB_(G)), intent(in) :: uh_tot_0 !< The summed transport
+ real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: uh_tot_0 !< The summed transport
!! with 0 adjustment [H L2 T-1 ~> m3 s-1 or kg s-1].
- real, dimension(SZIB_(G)), intent(in) :: duhdu_tot_0 !< The partial derivative
+ real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: duhdu_tot_0 !< The partial derivative
!! of du_err with du at 0 adjustment [H L ~> m2 or kg m-1].
- real, dimension(SZIB_(G)), intent(out) :: du !<
+ real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: du !<
!! The barotropic velocity adjustment [L T-1 ~> m s-1].
- real, intent(in) :: dt !< Time increment [T ~> s].
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
- integer, intent(in) :: j !< Spatial index.
- integer, intent(in) :: ish !< Start of index range.
- integer, intent(in) :: ieh !< End of index range.
- logical, dimension(SZIB_(G)), intent(in) :: do_I_in !<
- !! A logical flag indicating which I values to work on.
- real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), &
- intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim]
- real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: uh_3d !<
- !! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1].
- type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure.
+ real, intent(in) :: dt !< Time increment [T ~> s].
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type.
+ type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
+ integer, intent(in) :: ish !< Start of i index range.
+ integer, intent(in) :: jsh !< Start of j index range.
+ integer, intent(in) :: ieh !< End of i index range.
+ integer, intent(in) :: jeh !< End of j index range.
+ logical, dimension(SZIB_(G),SZJ_(G)), intent(in) :: do_I_in !< A logical flag indicating
+ !! which I values to work on.
+ real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), intent(in) :: por_face_areaU !< fractional open area
+ !! of U-faces [nondim].
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
+ optional, intent(inout) :: uh_3d !< Volume flux through zonal
+ !! faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1].
+ type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure.
! Local variables
real, dimension(SZIB_(G),SZK_(GV)) :: &
- uh_aux, & ! An auxiliary zonal volume flux [H L2 T-1 ~> m3 s-1 or kg s-1].
- duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1].
+ uh_aux ! An auxiliary zonal volume flux [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real :: &
+ duhdu, & ! Partial derivative of uh with u [H L ~> m2 or kg m-1].
+ u_new ! The velocity with the correction added [L T-1 ~> m s-1].
real, dimension(SZIB_(G)) :: &
- uh_err, & ! Difference between uhbt and the summed uh [H L2 T-1 ~> m3 s-1 or kg s-1].
+ uh_err, & ! Difference between uhbt and the summed uh [H L2 T-1 ~> m3 s-1 or kg s-1].
uh_err_best, & ! The smallest value of uh_err found so far [H L2 T-1 ~> m3 s-1 or kg s-1].
- u_new, & ! The velocity with the correction added [L T-1 ~> m s-1].
- duhdu_tot,&! Summed partial derivative of uh with u [H L ~> m2 or kg m-1].
- du_min, & ! Lower limit on du correction based on CFL limits and previous iterations [L T-1 ~> m s-1]
- du_max ! Upper limit on du correction based on CFL limits and previous iterations [L T-1 ~> m s-1]
- real :: du_prev ! The previous value of du [L T-1 ~> m s-1].
- real :: ddu ! The change in du from the previous iteration [L T-1 ~> m s-1].
- real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2].
- real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1].
- integer :: i, k, nz, itt, max_itts = 20
- logical :: domore, do_I(SZIB_(G))
+ duhdu_tot,& ! Summed partial derivative of uh with u [H L ~> m2 or kg m-1].
+ du_min, & ! Lower limit on du correction based on CFL limits and previous iterations [L T-1 ~> m s-1]
+ du_max ! Upper limit on du correction based on CFL limits and previous iterations [L T-1 ~> m s-1]
+ real :: du_prev ! The previous value of du [L T-1 ~> m s-1].
+ real :: ddu ! The change in du from the previous iteration [L T-1 ~> m s-1].
+ real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2].
+ real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1].
+ integer :: i, j, k, nz, itt
+ logical :: do_I(SZIB_(G)), local_OBC, use_uhbt
+ integer, parameter:: max_itts = 20
+
+ local_OBC = .false.
+ if (present(OBC)) then
+ if (associated(OBC)) then
+ local_OBC = OBC%open_u_BCs_exist_globally
+ endif
+ endif
+
+ use_uhbt = present(uhbt)
nz = GV%ke
- uh_aux(:,:) = 0.0 ; duhdu(:,:) = 0.0
+ tol_vel = CS%tol_vel
- if (present(uh_3d)) then ; do k=1,nz ; do I=ish-1,ieh
- uh_aux(i,k) = uh_3d(I,j,k)
- enddo ; enddo ; endif
+ ! NVIDIA needs private arrays to be alloc'ed to prevent data transfers.
+ ! GCC doesn't understand map(alloc: ...) for variables also marked private
+ !$omp target enter data map(alloc: do_I, du_max, du_min, duhdu_tot, uh_err, uh_err_best, uh_aux)
- do I=ish-1,ieh
- du(I) = 0.0 ; do_I(I) = do_I_in(I)
- du_max(I) = du_max_CFL(I) ; du_min(I) = du_min_CFL(I)
- uh_err(I) = uh_tot_0(I) - uhbt(I) ; duhdu_tot(I) = duhdu_tot_0(I)
- uh_err_best(I) = abs(uh_err(I))
- enddo
+ ! NVIDIA do concurrent doesn't work with private arrays (private scalars OK)
+ !$omp target teams loop &
+ !$omp private(uh_err, uh_err_best, duhdu_tot, du_min, du_max, do_I, uh_aux, itt, tol_eta)
+ do j=jsh,jeh
+
+ if (present(uh_3d)) then
+ do concurrent (k=1:nz, I=ish-1:ieh)
+ uh_aux(I,k) = uh_3d(I,j,k)
+ enddo
+ endif
- do itt=1,max_itts
- select case (itt)
- case (:1) ; tol_eta = 1e-6 * CS%tol_eta
- case (2) ; tol_eta = 1e-4 * CS%tol_eta
- case (3) ; tol_eta = 1e-2 * CS%tol_eta
- case default ; tol_eta = CS%tol_eta
- end select
- tol_vel = CS%tol_vel
-
- do I=ish-1,ieh
- if (uh_err(I) > 0.0) then ; du_max(I) = du(I)
- elseif (uh_err(I) < 0.0) then ; du_min(I) = du(I)
- else ; do_I(I) = .false. ; endif
+ do concurrent (I=ish-1:ieh)
+ du(I,j) = 0.0 ; do_I(I) = do_I_in(I,j)
+ du_max(I) = du_max_CFL(I,j) ; du_min(I) = du_min_CFL(I,j)
+ uh_err(I) = uh_tot_0(I,j)
+ if (use_uhbt) uh_err(I) = uh_err(I) - uhbt(I,j)
+ duhdu_tot(I) = duhdu_tot_0(I,j)
+ uh_err_best(I) = abs(uh_err(I))
enddo
- domore = .false.
- do I=ish-1,ieh ; if (do_I(I)) then
- if ((dt * min(G%IareaT(i,j),G%IareaT(i+1,j))*abs(uh_err(I)) > tol_eta) .or. &
- (CS%better_iter .and. ((abs(uh_err(I)) > tol_vel * duhdu_tot(I)) .or. &
- (abs(uh_err(I)) > uh_err_best(I))) )) then
- ! Use Newton's method, provided it stays bounded. Otherwise bisect
- ! the value with the appropriate bound.
- ddu = -uh_err(I) / duhdu_tot(I)
- du_prev = du(I)
- du(I) = du(I) + ddu
- if (abs(ddu) < 1.0e-15*abs(du(I))) then
- do_I(I) = .false. ! ddu is small enough to quit.
- elseif (ddu > 0.0) then
- if (du(I) >= du_max(I)) then
- du(I) = 0.5*(du_prev + du_max(I))
- if (du_max(I) - du_prev < 1.0e-15*abs(du(I))) do_I(I) = .false.
- endif
- else ! ddu < 0.0
- if (du(I) <= du_min(I)) then
- du(I) = 0.5*(du_prev + du_min(I))
- if (du_prev - du_min(I) < 1.0e-15*abs(du(I))) do_I(I) = .false.
+
+ do itt=1,max_itts
+ select case (itt)
+ case (:1) ; tol_eta = 1e-6 * CS%tol_eta
+ case (2) ; tol_eta = 1e-4 * CS%tol_eta
+ case (3) ; tol_eta = 1e-2 * CS%tol_eta
+ case default ; tol_eta = CS%tol_eta
+ end select
+
+ do concurrent (I=ish-1:ieh, do_I(I)) &
+ & DO_LOCALITY(local(ddu, du_prev))
+ if (uh_err(I) > 0.0) then ; du_max(I) = du(I,j)
+ elseif (uh_err(I) < 0.0) then ; du_min(I) = du(I,j)
+ else ; do_I(I) = .false. ; endif
+ if ((dt * min(G%IareaT(i,j),G%IareaT(i+1,j))*abs(uh_err(I)) > tol_eta) .or. &
+ (CS%better_iter .and. ((abs(uh_err(I)) > tol_vel * duhdu_tot(I)) .or. &
+ (abs(uh_err(I)) > uh_err_best(I))) )) then
+ ! Use Newton's method, provided it stays bounded. Otherwise bisect
+ ! the value with the appropriate bound.
+ ddu = -uh_err(I) / duhdu_tot(I)
+ du_prev = du(I,j)
+ du(I,j) = du(I,j) + ddu
+ if (abs(ddu) < 1.0e-15*abs(du(I,j))) then
+ do_I(I) = .false. ! ddu is small enough to quit.
+ elseif (ddu > 0.0) then
+ if (du(I,j) >= du_max(I)) then
+ du(I,j) = 0.5*(du_prev + du_max(I))
+ if (du_max(I) - du_prev < 1.0e-15*abs(du(I,j))) do_I(I) = .false.
+ endif
+ else ! ddu < 0.0
+ if (du(I,j) <= du_min(I)) then
+ du(I,j) = 0.5*(du_prev + du_min(I))
+ if (du_prev - du_min(I) < 1.0e-15*abs(du(I,j))) do_I(I) = .false.
+ endif
endif
+ else
+ do_I(I) = .false.
endif
- if (do_I(I)) domore = .true.
- else
- do_I(I) = .false.
- endif
- endif ; enddo
- if (.not.domore) exit
-
- if ((itt < max_itts) .or. present(uh_3d)) then ; do k=1,nz
- do I=ish-1,ieh ; u_new(I) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo
- call zonal_flux_layer(u_new, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), &
- uh_aux(:,k), duhdu(:,k), visc_rem(:,k), &
- dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC)
- enddo ; endif
-
- if (itt < max_itts) then
- do I=ish-1,ieh
- uh_err(I) = -uhbt(I) ; duhdu_tot(I) = 0.0
enddo
- do k=1,nz ; do I=ish-1,ieh
- uh_err(I) = uh_err(I) + uh_aux(I,k)
- duhdu_tot(I) = duhdu_tot(I) + duhdu(I,k)
- enddo ; enddo
- do I=ish-1,ieh
- uh_err_best(I) = min(uh_err_best(I), abs(uh_err(I)))
+
+ ! Below conditional compilation is to control whether early exit happens when compiled with
+ ! OpenMP - compiling with OpenMP prevents early exit. Without OpenMP, enables early exit.
+ ! Early exit saves time on CPU, but causes other loops to be serialized on GPU.
+ !$ if (.false.) then
+ if (.not. any(do_I(ish-1:ieh))) exit
+ !$ endif
+
+ if ((itt < max_itts) .or. present(uh_3d)) then
+ do concurrent (I=ish-1:ieh)
+ uh_err(I) = 0.0 ; duhdu_tot(I) = 0.0
+ if (use_uhbt) uh_err(I) = -uhbt(I,j)
+ enddo
+ do k=1,nz ; do concurrent (I=ish-1:ieh, do_I(I)) DO_LOCALITY(local(u_new, duhdu))
+ u_new = u(I,j,k) + du(I,j) * visc_rem(I,j,k)
+ call flux_elem(u_new, h_in(I,j,k), h_in(I+1,j,k), h_W(I,j,k), h_W(I+1,j,k), h_E(I,j,k), &
+ h_E(I+1,j,k), uh_aux(I,k), duhdu, visc_rem(I,j,k), G%dy_Cu(I,j), &
+ G%IareaT(I,j), G%IareaT(I+1,j), G%IdxT(I,j), G%IdxT(i+1,j), dt, G, GV, US, &
+ CS%vol_CFL, por_face_areaU(I,j,k))
+ ! Below if statement looks expensive in profiling results, but I believe it's
+ ! masking the expensive update of uh_err beneath
+ if (local_OBC) &
+ call flux_elem_OBC(u_new, h_in(I,j,k), h_in(I+1,j,k), uh_aux(I,k), duhdu, &
+ visc_rem(I,j,k), G, GV, por_face_areaU(I,j,k), G%dy_Cu(I,j), OBC, &
+ OBC%segnum_u(I,j))
+ uh_err(I) = uh_err(I) + uh_aux(I,k)
+ duhdu_tot(I) = duhdu_tot(I) + duhdu
+ enddo ; enddo
+ do concurrent (I=ish-1:ieh)
+ uh_err_best(I) = min(uh_err_best(I), abs(uh_err(I)))
+ enddo
+ endif
+
+ enddo ! itt-loop
+ if (present(uh_3d)) then
+ do concurrent (k=1:nz, I=ish-1:ieh)
+ uh_3d(I,j,k) = uh_aux(I,k)
enddo
endif
- enddo ! itt-loop
+ enddo ! j-loop
! If there are any faces which have not converged to within the tolerance,
! so-be-it, or else use a final upwind correction?
! This never seems to happen with 20 iterations as max_itt.
- if (present(uh_3d)) then ; do k=1,nz ; do I=ish-1,ieh
- uh_3d(I,j,k) = uh_aux(I,k)
- enddo ; enddo ; endif
+ !$omp target exit data map(release: do_I, du_max, du_min, duhdu_tot, uh_err, uh_err_best, uh_aux)
end subroutine zonal_flux_adjust
+
!> Sets a structure that describes the zonal barotropic volume or mass fluxes as a
!! function of barotropic flow to agree closely with the sum of the layer's transports.
-subroutine set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0, &
+subroutine set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, du0, uh_tot_0, duhdu_tot_0, &
du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, &
- visc_rem_max, j, ish, ieh, do_I, por_face_areaU)
- type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
- real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to
- !! calculate fluxes [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the
- !! reconstruction [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the
- !! reconstruction [H ~> m or kg m-2].
- type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements
+ visc_rem_max, ish, ieh, jsh, jeh, do_I, por_face_areaU)
+ type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_W !< West edge thickness in the reconstruction [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_E !< East edge thickness in the reconstruction [H ~> m or kg m-2].
+ type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements
!! that describe the effective open face areas as a function of barotropic flow.
- real, dimension(SZIB_(G)), intent(in) :: uh_tot_0 !< The summed transport
- !! with 0 adjustment [H L2 T-1 ~> m3 s-1 or kg s-1].
- real, dimension(SZIB_(G)), intent(in) :: duhdu_tot_0 !< The partial derivative
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: du0 !< The barotropic velocity increment that gives 0 transport
+ !! [L T-1 ~> m s-1].
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: uh_tot_0 !< The summed transport with 0 adjustment
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: duhdu_tot_0 !< The partial derivative
!! of du_err with du at 0 adjustment [H L ~> m2 or kg m-1].
- real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable
- !! value of du [L T-1 ~> m s-1].
- real, dimension(SZIB_(G)), intent(in) :: du_min_CFL !< Minimum acceptable
- !! value of du [L T-1 ~> m s-1].
- real, intent(in) :: dt !< Time increment [T ~> s].
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
- real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: du_max_CFL !< Maximum acceptable value of du [L T-1 ~> m s-1].
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: du_min_CFL !< Minimum acceptable value of du [L T-1 ~> m s-1].
+ real, intent(in) :: dt !< Time increment [T ~> s].
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: visc_rem !< Both the fraction of the
!! momentum originally in a layer that remains after a time-step of viscosity, and
!! the fraction of a time-step's worth of a barotropic acceleration that a layer
!! experiences after viscosity is applied [nondim].
!! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom).
- real, dimension(SZIB_(G)), intent(in) :: visc_rem_max !< Maximum allowable visc_rem [nondim].
- integer, intent(in) :: j !< Spatial index.
- integer, intent(in) :: ish !< Start of index range.
- integer, intent(in) :: ieh !< End of index range.
- logical, dimension(SZIB_(G)), intent(in) :: do_I !< A logical flag indicating
- !! which I values to work on.
- real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), &
- intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim]
+ real, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: visc_rem_max !< Maximum allowable visc_rem [nondim].
+ integer, intent(in) :: ish !< Start of i index range.
+ integer, intent(in) :: ieh !< End of i index range.
+ integer, intent(in) :: jsh !< Start of j index range.
+ integer, intent(in) :: jeh !< End of j index range.
+ logical, dimension(SZIB_(G),SZJ_(G)), &
+ intent(in) :: do_I !< A logical flag indicating which I values to work on.
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
+ intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim]
! Local variables
real, dimension(SZIB_(G)) :: &
- du0, & ! The barotropic velocity increment that gives 0 transport [L T-1 ~> m s-1].
- duL, duR, & ! The barotropic velocity increments that give the westerly
- ! (duL) and easterly (duR) test velocities [L T-1 ~> m s-1].
- zeros, & ! An array of full of 0 transports [H L2 T-1 ~> m3 s-1 or kg s-1]
- du_CFL, & ! The velocity increment that corresponds to CFL_min [L T-1 ~> m s-1].
+ duL, duR, & ! The barotropic velocity increments that give the westerly
+ du_CFL, & ! The velocity increment that corresponds to CFL_min [L T-1 ~> m s-1].
+ ! (duL) and easterly (duR) test velocities [L T-1 ~> m s-1].
+ FAmt_L, FAmt_R, & ! The summed effective marginal face areas for the 3
+ FAmt_0, & ! test velocities [H L ~> m2 or kg m-1].
+ uhtot_L, & ! The summed transport with the westerly (uhtot_L) and
+ uhtot_R ! and easterly (uhtot_R) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real :: &
u_L, u_R, & ! The westerly (u_L), easterly (u_R), and zero-barotropic
u_0, & ! transport (u_0) layer test velocities [L T-1 ~> m s-1].
duhdu_L, & ! The effective layer marginal face areas with the westerly
duhdu_R, & ! (_L), easterly (_R), and zero-barotropic (_0) test
duhdu_0, & ! velocities [H L ~> m2 or kg m-1].
uh_L, uh_R, & ! The layer transports with the westerly (_L), easterly (_R),
- uh_0, & ! and zero-barotropic (_0) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
- FAmt_L, FAmt_R, & ! The summed effective marginal face areas for the 3
- FAmt_0, & ! test velocities [H L ~> m2 or kg m-1].
- uhtot_L, & ! The summed transport with the westerly (uhtot_L) and
- uhtot_R ! and easterly (uhtot_R) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
+ uh_0 ! and zero-barotropic (_0) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
real :: FA_0 ! The effective face area with 0 barotropic transport [L H ~> m2 or kg m-1].
real :: FA_avg ! The average effective face area [L H ~> m2 or kg m-1], nominally given by
! the realized transport divided by the barotropic velocity.
@@ -1313,99 +1527,94 @@ subroutine set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0,
real :: CFL_min ! A minimal increment in the CFL to try to ensure that the
! flow is truly upwind [nondim]
real :: Idt ! The inverse of the time step [T-1 ~> s-1].
- logical :: domore
- integer :: i, k, nz
+ integer :: i, j, k, nz
nz = GV%ke ; Idt = 1.0 / dt
min_visc_rem = 0.1 ; CFL_min = 1e-6
- ! Diagnose the zero-transport correction, du0.
- do I=ish-1,ieh ; zeros(I) = 0.0 ; enddo
- call zonal_flux_adjust(u, h_in, h_W, h_E, zeros, uh_tot_0, duhdu_tot_0, du0, &
- du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, &
- j, ish, ieh, do_I, por_face_areaU)
-
- ! Determine the westerly- and easterly- fluxes. Choose a sufficiently
- ! negative velocity correction for the easterly-flux, and a sufficiently
- ! positive correction for the westerly-flux.
- domore = .false.
- do I=ish-1,ieh
- if (do_I(I)) domore = .true.
- du_CFL(I) = (CFL_min * Idt) * G%dxCu(I,j)
- duR(I) = min(0.0,du0(I) - du_CFL(I))
- duL(I) = max(0.0,du0(I) + du_CFL(I))
- FAmt_L(I) = 0.0 ; FAmt_R(I) = 0.0 ; FAmt_0(I) = 0.0
- uhtot_L(I) = 0.0 ; uhtot_R(I) = 0.0
- enddo
+ !$omp target enter data map(alloc: duL, duR, du_CFL, FAmt_L, FAmT_R, FAmt_0, uhtot_L, uhtot_R)
+
+ !$omp target teams loop private(duL, duR, du_CFL, FAmt_L, FAmt_R, FAmt_0, uhtot_L, uhtot_R)
+ do j=jsh,jeh
+ ! Determine the westerly- and easterly- fluxes. Choose a sufficiently
+ ! negative velocity correction for the easterly-flux, and a sufficiently
+ ! positive correction for the westerly-flux.
+ do concurrent (I=ish-1:ieh)
+ du_CFL(I) = (CFL_min * Idt) * G%dxCu(I,j)
+ duR(I) = min(0.0,du0(I,j) - du_CFL(I))
+ duL(I) = max(0.0,du0(I,j) + du_CFL(I))
+ FAmt_L(I) = 0.0 ; FAmt_R(I) = 0.0 ; FAmt_0(I) = 0.0
+ uhtot_L(I) = 0.0 ; uhtot_R(I) = 0.0
+ enddo
- if (.not.domore) then
- do k=1,nz ; do I=ish-1,ieh
- BT_cont%FA_u_W0(I,j) = 0.0 ; BT_cont%FA_u_WW(I,j) = 0.0
- BT_cont%FA_u_E0(I,j) = 0.0 ; BT_cont%FA_u_EE(I,j) = 0.0
- BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0
+ do k=1,nz ; do concurrent (I=ish-1:ieh, do_I(I,j)) DO_LOCALITY(local(visc_rem_lim))
+ visc_rem_lim = max(visc_rem(I,j,k), min_visc_rem*visc_rem_max(I,j))
+ if (visc_rem_lim > 0.0) then ! This is almost always true for ocean points.
+ if (u(I,j,k) + duR(I)*visc_rem_lim > -du_CFL(I)*visc_rem(I,j,k)) &
+ duR(I) = -(u(I,j,k) + du_CFL(I)*visc_rem(I,j,k)) / visc_rem_lim
+ if (u(I,j,k) + duL(I)*visc_rem_lim < du_CFL(I)*visc_rem(I,j,k)) &
+ duL(I) = -(u(I,j,k) - du_CFL(I)*visc_rem(I,j,k)) / visc_rem_lim
+ endif
enddo ; enddo
- return
- endif
- do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then
- visc_rem_lim = max(visc_rem(I,k), min_visc_rem*visc_rem_max(I))
- if (visc_rem_lim > 0.0) then ! This is almost always true for ocean points.
- if (u(I,j,k) + duR(I)*visc_rem_lim > -du_CFL(I)*visc_rem(I,k)) &
- duR(I) = -(u(I,j,k) + du_CFL(I)*visc_rem(I,k)) / visc_rem_lim
- if (u(I,j,k) + duL(I)*visc_rem_lim < du_CFL(I)*visc_rem(I,k)) &
- duL(I) = -(u(I,j,k) - du_CFL(I)*visc_rem(I,k)) / visc_rem_lim
- endif
- endif ; enddo ; enddo
-
- do k=1,nz
- do I=ish-1,ieh ; if (do_I(I)) then
- u_L(I) = u(I,j,k) + duL(I) * visc_rem(I,k)
- u_R(I) = u(I,j,k) + duR(I) * visc_rem(I,k)
- u_0(I) = u(I,j,k) + du0(I) * visc_rem(I,k)
- endif ; enddo
- call zonal_flux_layer(u_0, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_0, duhdu_0, &
- visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k))
- call zonal_flux_layer(u_L, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_L, duhdu_L, &
- visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k))
- call zonal_flux_layer(u_R, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_R, duhdu_R, &
- visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k))
- do I=ish-1,ieh ; if (do_I(I)) then
- FAmt_0(I) = FAmt_0(I) + duhdu_0(I)
- FAmt_L(I) = FAmt_L(I) + duhdu_L(I)
- FAmt_R(I) = FAmt_R(I) + duhdu_R(I)
- uhtot_L(I) = uhtot_L(I) + uh_L(I)
- uhtot_R(I) = uhtot_R(I) + uh_R(I)
- endif ; enddo
- enddo
- do I=ish-1,ieh ; if (do_I(I)) then
- FA_0 = FAmt_0(I) ; FA_avg = FAmt_0(I)
- if ((duL(I) - du0(I)) /= 0.0) &
- FA_avg = uhtot_L(I) / (duL(I) - du0(I))
- if (FA_avg > max(FA_0, FAmt_L(I))) then ; FA_avg = max(FA_0, FAmt_L(I))
- elseif (FA_avg < min(FA_0, FAmt_L(I))) then ; FA_0 = FA_avg ; endif
-
- BT_cont%FA_u_W0(I,j) = FA_0 ; BT_cont%FA_u_WW(I,j) = FAmt_L(I)
- if (abs(FA_0-FAmt_L(I)) <= 1e-12*FA_0) then ; BT_cont%uBT_WW(I,j) = 0.0 ; else
- BT_cont%uBT_WW(I,j) = (1.5 * (duL(I) - du0(I))) * &
- ((FAmt_L(I) - FA_avg) / (FAmt_L(I) - FA_0))
- endif
+ do k=1,nz ; do concurrent (I=ish-1:ieh, do_I(I,j)) &
+ & DO_LOCALITY(local(u_0, u_L, u_R, uh_0, uh_L, uh_R, duhdu_0, duhdu_L, duhdu_R))
+ u_L = u(I,j,k) + duL(I) * visc_rem(I,j,k)
+ u_R = u(I,j,k) + duR(I) * visc_rem(I,j,k)
+ u_0 = u(I,j,k) + du0(I,j) * visc_rem(I,j,k)
+ call flux_elem(u_0, h_in(I,j,k), h_in(I+1,j,k), h_W(I,j,k), h_W(I+1,j,k), h_E(I,j,k), &
+ h_E(I+1,j,k), uh_0, duhdu_0, visc_rem(I,j,k), G%dy_Cu(I,j), &
+ G%IareaT(I,j), G%IareaT(I+1,j), G%IdxT(I,j), G%IdxT(i+1,j), dt, G, GV, &
+ US, CS%vol_CFL, por_face_areaU(I,j,k))
+ call flux_elem(u_L, h_in(I,j,k), h_in(I+1,j,k), h_W(I,j,k), h_W(I+1,j,k), h_E(I,j,k), &
+ h_E(I+1,j,k), uh_L, duhdu_L, visc_rem(I,j,k), G%dy_Cu(I,j), &
+ G%IareaT(I,j), G%IareaT(I+1,j), G%IdxT(I,j), G%IdxT(i+1,j), dt, G, GV, &
+ US, CS%vol_CFL, por_face_areaU(I,j,k))
+ call flux_elem(u_R, h_in(I,j,k), h_in(I+1,j,k), h_W(I,j,k), h_W(I+1,j,k), h_E(I,j,k), &
+ h_E(I+1,j,k), uh_R, duhdu_R, visc_rem(I,j,k), G%dy_Cu(I,j), &
+ G%IareaT(I,j), G%IareaT(I+1,j), G%IdxT(I,j), G%IdxT(i+1,j), dt, G, GV, &
+ US, CS%vol_CFL, por_face_areaU(I,j,k))
+ FAmt_0(I) = FAmt_0(I) + duhdu_0
+ FAmt_L(I) = FAmt_L(I) + duhdu_L
+ FAmt_R(I) = FAmt_R(I) + duhdu_R
+ uhtot_L(I) = uhtot_L(I) + uh_L
+ uhtot_R(I) = uhtot_R(I) + uh_R
+ enddo ; enddo
- FA_0 = FAmt_0(I) ; FA_avg = FAmt_0(I)
- if ((duR(I) - du0(I)) /= 0.0) &
- FA_avg = uhtot_R(I) / (duR(I) - du0(I))
- if (FA_avg > max(FA_0, FAmt_R(I))) then ; FA_avg = max(FA_0, FAmt_R(I))
- elseif (FA_avg < min(FA_0, FAmt_R(I))) then ; FA_0 = FA_avg ; endif
+ do concurrent (I=ish-1:ieh) DO_LOCALITY(local(FA_0, FA_avg))
+ if (do_I(I,j)) then
+ FA_0 = FAmt_0(I) ; FA_avg = FAmt_0(I)
+ if ((duL(I) - du0(I,j)) /= 0.0) &
+ FA_avg = uhtot_L(I) / (duL(I) - du0(I,j))
+ if (FA_avg > max(FA_0, FAmt_L(I))) then ; FA_avg = max(FA_0, FAmt_L(I))
+ elseif (FA_avg < min(FA_0, FAmt_L(I))) then ; FA_0 = FA_avg ; endif
+
+ BT_cont%FA_u_W0(I,j) = FA_0 ; BT_cont%FA_u_WW(I,j) = FAmt_L(I)
+ if (abs(FA_0-FAmt_L(I)) <= 1e-12*FA_0) then ; BT_cont%uBT_WW(I,j) = 0.0 ; else
+ BT_cont%uBT_WW(I,j) = (1.5 * (duL(I) - du0(I,j))) * &
+ ((FAmt_L(I) - FA_avg) / (FAmt_L(I) - FA_0))
+ endif
- BT_cont%FA_u_E0(I,j) = FA_0 ; BT_cont%FA_u_EE(I,j) = FAmt_R(I)
- if (abs(FAmt_R(I) - FA_0) <= 1e-12*FA_0) then ; BT_cont%uBT_EE(I,j) = 0.0 ; else
- BT_cont%uBT_EE(I,j) = (1.5 * (duR(I) - du0(I))) * &
- ((FAmt_R(I) - FA_avg) / (FAmt_R(I) - FA_0))
- endif
- else
- BT_cont%FA_u_W0(I,j) = 0.0 ; BT_cont%FA_u_WW(I,j) = 0.0
- BT_cont%FA_u_E0(I,j) = 0.0 ; BT_cont%FA_u_EE(I,j) = 0.0
- BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0
- endif ; enddo
+ FA_0 = FAmt_0(I) ; FA_avg = FAmt_0(I)
+ if ((duR(I) - du0(I,j)) /= 0.0) &
+ FA_avg = uhtot_R(I) / (duR(I) - du0(I,j))
+ if (FA_avg > max(FA_0, FAmt_R(I))) then ; FA_avg = max(FA_0, FAmt_R(I))
+ elseif (FA_avg < min(FA_0, FAmt_R(I))) then ; FA_0 = FA_avg ; endif
+
+ BT_cont%FA_u_E0(I,j) = FA_0 ; BT_cont%FA_u_EE(I,j) = FAmt_R(I)
+ if (abs(FAmt_R(I) - FA_0) <= 1e-12*FA_0) then ; BT_cont%uBT_EE(I,j) = 0.0 ; else
+ BT_cont%uBT_EE(I,j) = (1.5 * (duR(I) - du0(I,j))) * &
+ ((FAmt_R(I) - FA_avg) / (FAmt_R(I) - FA_0))
+ endif
+ else
+ BT_cont%FA_u_W0(I,j) = 0.0 ; BT_cont%FA_u_WW(I,j) = 0.0
+ BT_cont%FA_u_E0(I,j) = 0.0 ; BT_cont%FA_u_EE(I,j) = 0.0
+ BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0
+ endif
+ enddo
+ enddo
+
+ !$omp target exit data map(release: duL, duR, du_CFL, FAmt_L, FAmT_R, FAmt_0, uhtot_L, uhtot_R)
end subroutine set_zonal_BT_cont
@@ -1451,20 +1660,16 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p
!! transports [L T-1 ~> m s-1].
! Local variables
- real, dimension(SZI_(G),SZK_(GV)) :: &
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: &
dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1].
- real, dimension(SZI_(G)) :: &
+ real, dimension(SZI_(G),SZJB_(G)) :: &
dv, & ! Corrective barotropic change in the velocity to give vhbt [L T-1 ~> m s-1].
dv_min_CFL, & ! Lower limit on dv correction to avoid CFL violations [L T-1 ~> m s-1]
dv_max_CFL, & ! Upper limit on dv correction to avoid CFL violations [L T-1 ~> m s-1]
dvhdv_tot_0, & ! Summed partial derivative of vh with v [H L ~> m2 or kg m-1].
vh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1].
visc_rem_max ! The column maximum of visc_rem [nondim]
- logical, dimension(SZI_(G)) :: do_I
- real, dimension(SZI_(G)) :: FAvi ! A list of sums of meridional face areas [H L ~> m2 or kg m-1].
- real :: FA_v ! A sum of meridional face areas [H L ~> m2 or kg m-1].
- real, dimension(SZI_(G),SZK_(GV)) :: &
- visc_rem ! A 2-D copy of visc_rem_v or an array of 1's [nondim]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: visc_rem_v_tmp ! A copy of visc_rem_v or an array of 1's [nondim]
real :: I_vrm ! 1.0 / visc_rem_max [nondim]
real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by
! the time step [T-1 ~> s-1].
@@ -1475,8 +1680,7 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p
integer :: i, j, k, ish, ieh, jsh, jeh, n, nz
integer :: l_seg ! The OBC segment number
logical :: use_visc_rem, set_BT_cont
- logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals
- logical :: simple_OBC_pt(SZI_(G)) ! Indicates points in a row with specified transport OBCs
+ logical :: local_specified_BC, local_open_BC, any_simple_OBC ! OBC-related logicals
call cpu_clock_begin(id_clock_correct)
@@ -1484,15 +1688,12 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p
set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont))
- local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false.
+ local_specified_BC = .false. ; local_open_BC = .false.
if (associated(OBC)) then ; if (OBC%OBC_pe) then
local_specified_BC = OBC%specified_v_BCs_exist_globally
- local_Flather_OBC = OBC%Flather_v_BCs_exist_globally
local_open_BC = OBC%open_v_BCs_exist_globally
endif ; endif
- if (present(dv_cor)) dv_cor(:,:) = 0.0
-
if (present(LB_in)) then
LB = LB_in
else
@@ -1504,178 +1705,312 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p
I_dt = 1.0 / dt
if (CS%aggress_adjust) CFL_dt = I_dt
- if (.not.use_visc_rem) visc_rem(:,:) = 1.0
- !$OMP parallel do default(shared) private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, &
- !$OMP dvhdv_tot_0,FAvi,visc_rem_max,I_vrm,dv_lim,dy_N,dy_S, &
- !$OMP simple_OBC_pt,any_simple_OBC,l_seg) &
- !$OMP firstprivate(visc_rem)
- do J=jsh-1,jeh
- do i=ish,ieh ; do_I(i) = .true. ; enddo
- ! This sets vh and dvhdv.
- do k=1,nz
- if (use_visc_rem) then ; do i=ish,ieh
- visc_rem(i,k) = visc_rem_v(i,J,k)
- enddo ; endif
- call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), &
- vh(:,J,k), dvhdv(:,k), visc_rem(:,k), &
- dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC)
- 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)
- if (OBC%segment(l_seg)%specified) vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k)
- endif ; enddo
- endif
- enddo ! k-loop
+ !$omp target enter data &
+ !$omp map(alloc: dvhdv, dv, dv_min_CFL, dv_max_CFL, dvhdv_tot_0, vh_tot_0, visc_rem_max, &
+ !$omp visc_rem_v_tmp)
+
+ do concurrent (J=jsh-1:jeh)
+
+ if (present(dv_cor)) then
+ do concurrent (i=ish:ieh)
+ dv_cor(i,J) = 0.0
+ enddo
+ endif
+
+ ! this is expensive
+ if (.not.use_visc_rem) then
+ do concurrent (k=1:nz, i=G%isd:G%ied)
+ visc_rem_v_tmp(i,J,k) = 1.0
+ enddo
+ else
+ do concurrent (k=1:nz, i=G%isd:G%ied)
+ visc_rem_v_tmp(i,J,k) = visc_rem_v(i,J,k)
+ enddo
+ endif
+
+ do concurrent (k=1:nz, i=ish:ieh)
+ call flux_elem(v(i,J,k), h_in(i,J,k), h_in(i,J+1,k), h_S(i,J,k), h_S(i,J+1,k), h_N(i,J,k), &
+ h_N(i,J+1,k), vh(i,J,k), dvhdv(i,J,k), visc_rem_v_tmp(i,J,k), G%dx_Cv(i,J), &
+ G%IareaT(i,J), G%IareaT(i,J+1), G%IdyT(i,J), G%IdyT(i,J+1), dt, G, GV, US, &
+ CS%vol_CFL, por_face_areaV(i,J,k))
+ enddo
+ if (local_open_BC) then
+ do concurrent (k=1:nz, i=ish:ieh)
+ ! untested!
+ call flux_elem_OBC(v(i,J,k), h_in(i,J,k), h_in(i,J+1,k), vh(i,J,k), dvhdv(i,J,k), &
+ visc_rem_v_tmp(i,J,k), G, GV, por_face_areaV(i,J,k), &
+ G%dx_Cv(i,J), OBC, OBC%segnum_v(i,J))
+ enddo
+ endif
+
+ ! untested!
+ if (local_specified_BC) then
+ do concurrent (k=1:nz, i=ish:ieh, OBC%segnum_v(i,J) /= 0)
+ 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)
+ enddo
+ endif
if (present(vhbt) .or. set_BT_cont) then
if (use_visc_rem .and. CS%use_visc_rem_max) then
- visc_rem_max(:) = 0.0
- do k=1,nz ; do i=ish,ieh
- visc_rem_max(i) = max(visc_rem_max(i), visc_rem(i,k))
+ do concurrent (i=ish:ieh)
+ visc_rem_max(i,J) = 0.0
+ enddo
+ do k=1,nz ; do concurrent (i=ish:ieh)
+ visc_rem_max(i,J) = max(visc_rem_max(i,J), visc_rem_v_tmp(i,J,k))
enddo ; enddo
else
- visc_rem_max(:) = 1.0
+ do concurrent (i=ish:ieh)
+ visc_rem_max(i,J) = 1.0
+ enddo
endif
! Set limits on dv that will keep the CFL number between -1 and 1.
! This should be adequate to keep the root bracketed in all cases.
- do i=ish,ieh
+ do concurrent (i=ish:ieh)
I_vrm = 0.0
- if (visc_rem_max(i) > 0.0) I_vrm = 1.0 / visc_rem_max(i)
+ if (visc_rem_max(i,j) > 0.0) I_vrm = 1.0 / visc_rem_max(i,j)
if (CS%vol_CFL) then
dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(i,J), 1000.0*G%dyT(i,j))
dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(i,J), 1000.0*G%dyT(i,j+1))
else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif
- dv_max_CFL(i) = 2.0 * (CFL_dt * dy_S) * I_vrm
- dv_min_CFL(i) = -2.0 * (CFL_dt * dy_N) * I_vrm
- vh_tot_0(i) = 0.0 ; dvhdv_tot_0(i) = 0.0
+ dv_max_CFL(i,j) = 2.0 * (CFL_dt * dy_S) * I_vrm
+ dv_min_CFL(i,j) = -2.0 * (CFL_dt * dy_N) * I_vrm
+ vh_tot_0(i,j) = 0.0 ; dvhdv_tot_0(i,j) = 0.0
enddo
- do k=1,nz ; do i=ish,ieh
- dvhdv_tot_0(i) = dvhdv_tot_0(i) + dvhdv(i,k)
- vh_tot_0(i) = vh_tot_0(i) + vh(i,J,k)
+ do k=1,nz ; do concurrent (i=ish:ieh)
+ dvhdv_tot_0(i,j) = dvhdv_tot_0(i,j) + dvhdv(i,j,k)
+ vh_tot_0(i,j) = vh_tot_0(i,j) + vh(i,J,k)
enddo ; enddo
if (use_visc_rem) then
if (CS%aggress_adjust) then
- do k=1,nz ; do i=ish,ieh
+ ! untested
+ do k=1,nz ; do concurrent (i=ish:ieh)
if (CS%vol_CFL) then
- dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j))
- dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1))
- else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif
+ dy_S = ratio_max(G%areaT(i,J), G%dx_Cv(i,J), 1000.0*G%dyT(i,J))
+ dy_N = ratio_max(G%areaT(i,J+1), G%dx_Cv(i,J), 1000.0*G%dyT(i,J+1))
+ else ; dy_S = G%dyT(i,J) ; dy_N = G%dyT(i,J+1) ; endif
dv_lim = 0.499*((dy_S*I_dt - v(i,J,k)) + MIN(0.0,v(i,J-1,k)))
- if (dv_max_CFL(i) * visc_rem(i,k) > dv_lim) &
- dv_max_CFL(i) = dv_lim / visc_rem(i,k)
+ if (dv_max_CFL(i,J) * visc_rem_v_tmp(i,J,k) > dv_lim) &
+ dv_max_CFL(i,J) = dv_lim / visc_rem_v_tmp(i,J,k)
dv_lim = 0.499*((-dy_N*CFL_dt - v(i,J,k)) + MAX(0.0,v(i,J+1,k)))
- if (dv_min_CFL(i) * visc_rem(i,k) < dv_lim) &
- dv_min_CFL(i) = dv_lim / visc_rem(i,k)
+ if (dv_min_CFL(i,J) * visc_rem_v_tmp(i,J,k) < dv_lim) &
+ dv_min_CFL(i,J) = dv_lim / visc_rem_v_tmp(i,J,k)
enddo ; enddo
else
- do k=1,nz ; do i=ish,ieh
+ do k=1,nz ; do concurrent (i=ish:ieh)
if (CS%vol_CFL) then
- dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j))
- dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1))
- else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif
- if (dv_max_CFL(i) * visc_rem(i,k) > dy_S*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) &
- dv_max_CFL(i) = (dy_S*CFL_dt - v(i,J,k)) / visc_rem(i,k)
- if (dv_min_CFL(i) * visc_rem(i,k) < -dy_N*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) &
- dv_min_CFL(i) = -(dy_N*CFL_dt + v(i,J,k)) / visc_rem(i,k)
+ dy_S = ratio_max(G%areaT(i,J), G%dx_Cv(i,J), 1000.0*G%dyT(i,J))
+ dy_N = ratio_max(G%areaT(i,J+1), G%dx_Cv(i,J), 1000.0*G%dyT(i,J+1))
+ else ; dy_S = G%dyT(i,J) ; dy_N = G%dyT(i,J+1) ; endif
+ if (dv_max_CFL(i,J) * visc_rem_v_tmp(i,J,k) > dy_S*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) &
+ dv_max_CFL(i,J) = (dy_S*CFL_dt - v(i,J,k)) / visc_rem_v_tmp(i,J,k)
+ if (dv_min_CFL(i,J) * visc_rem_v_tmp(i,J,k) < -dy_N*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) &
+ dv_min_CFL(i,J) = -(dy_N*CFL_dt + v(i,J,k)) / visc_rem_v_tmp(i,J,k)
enddo ; enddo
- endif
+ endif ! CS%agress_adjust
else
if (CS%aggress_adjust) then
- do k=1,nz ; do i=ish,ieh
+ ! untested
+ do k=1,nz ; do concurrent (i=ish:ieh)
if (CS%vol_CFL) then
- dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j))
- dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1))
- else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif
- dv_max_CFL(i) = min(dv_max_CFL(i), 0.499 * &
+ dy_S = ratio_max(G%areaT(i,J), G%dx_Cv(i,J), 1000.0*G%dyT(i,J))
+ dy_N = ratio_max(G%areaT(i,J+1), G%dx_Cv(i,J), 1000.0*G%dyT(i,J+1))
+ else ; dy_S = G%dyT(i,J) ; dy_N = G%dyT(i,J+1) ; endif
+ dv_max_CFL(i,J) = min(dv_max_CFL(i,J), 0.499 * &
((dy_S*I_dt - v(i,J,k)) + MIN(0.0,v(i,J-1,k))) )
- dv_min_CFL(i) = max(dv_min_CFL(i), 0.499 * &
+ dv_min_CFL(i,J) = max(dv_min_CFL(i,J), 0.499 * &
((-dy_N*I_dt - v(i,J,k)) + MAX(0.0,v(i,J+1,k))) )
enddo ; enddo
else
- do k=1,nz ; do i=ish,ieh
+ do k=1,nz ; do concurrent (i=ish:ieh)
if (CS%vol_CFL) then
- dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j))
- dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1))
- else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif
- dv_max_CFL(i) = min(dv_max_CFL(i), dy_S*CFL_dt - v(i,J,k))
- dv_min_CFL(i) = max(dv_min_CFL(i), -(dy_N*CFL_dt + v(i,J,k)))
+ dy_S = ratio_max(G%areaT(i,J), G%dx_Cv(i,J), 1000.0*G%dyT(i,J))
+ dy_N = ratio_max(G%areaT(i,J+1), G%dx_Cv(i,J), 1000.0*G%dyT(i,J+1))
+ else ; dy_S = G%dyT(i,J) ; dy_N = G%dyT(i,J+1) ; endif
+ dv_max_CFL(i,J) = min(dv_max_CFL(i,J), dy_S*CFL_dt - v(i,J,k))
+ dv_min_CFL(i,J) = max(dv_min_CFL(i,J), -(dy_N*CFL_dt + v(i,J,k)))
enddo ; enddo
- endif
- endif
- do i=ish,ieh
- dv_max_CFL(i) = max(dv_max_CFL(i),0.0)
- dv_min_CFL(i) = min(dv_min_CFL(i),0.0)
+ endif ! CS%agress_adjust
+ endif ! use_visc_rem
+ do concurrent (i=ish:ieh)
+ dv_max_CFL(i,J) = max(dv_max_CFL(i,J),0.0)
+ dv_min_CFL(i,J) = min(dv_min_CFL(i,J),0.0)
enddo
+ endif ! present(vhbt) .or. set_BT_cont
- 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)
-
- ! 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
- do_I(i) = .not.simple_OBC_pt(i)
- any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(i)
- enddo ; else ; do i=ish,ieh
- do_I(i) = .true.
- enddo ; endif
- endif
+ enddo
- if (present(vhbt)) then
- ! Find dv and vh.
- call meridional_flux_adjust(v, h_in, h_S, h_N, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, &
- dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, &
- j, ish, ieh, do_I, por_face_areaV, vh, OBC=OBC)
+ call present_vhbt_or_set_BT_cont(v, h_in, h_S, h_N, vh_tot_0, dvhdv_tot_0, dv, dv_max_CFL, &
+ dv_min_CFL, visc_rem_v_tmp, visc_rem_max, por_face_areaV, vhbt, &
+ vh, v_cor, dv_cor, BT_cont, dt, G, GV, US, CS, OBC, LB)
- 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)
- endif ; enddo ; endif
- enddo ; endif ! v-corrected
+ !$omp target exit data &
+ !$omp map(release: dvhdv, dv, dv_min_CFL, dv_max_CFL, dvhdv_tot_0, vh_tot_0, &
+ !$omp visc_rem_max, visc_rem_v_tmp)
- if (present(dv_cor)) then
- do i=ish,ieh ; dv_cor(i,J) = dv(i) ; enddo
- endif
+ call cpu_clock_end(id_clock_correct)
- endif
+end subroutine meridional_mass_flux
- if (set_BT_cont) then
- call set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0,&
- dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, &
- visc_rem_max, J, ish, ieh, do_I, por_face_areaV)
- if (any_simple_OBC) then
- do i=ish,ieh
- if (simple_OBC_pt(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J)
+
+subroutine present_vhbt_or_set_BT_cont(v, h_in, h_S, h_N, vh_tot_0, dvhdv_tot_0, dv, dv_max_CFL, &
+ dv_min_CFL, visc_rem_v, visc_rem_max, por_face_areaV, vhbt, &
+ vh, v_cor, dv_cor, BT_cont, dt, G, GV, US, CS, OBC, LB)
+
+ type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
+ intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_S !< South edge thickness in the reconstruction [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_N !< North edge thickness in the reconstruction [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: vh_tot_0 !< Summed transport with no barotropic correction
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: dvhdv_tot_0 !< Summed partial derivative of vh with v
+ !! [H L ~> m2 or kg m-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(out) :: dv !< Corrective barotropic change in the velocity to give vhbt
+ !! [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: dv_max_CFL !< Upper limit on dv correction to avoid CFL violations
+ !! [L T-1 ~> m s-1]
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: dv_min_CFL !< Lower limit on dv correction to avoid CFL violations
+ !! [L T-1 ~> m s-1]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
+ intent(inout) :: vh !< Volume flux through meridional faces = v*h*dx
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: visc_rem_v !< Both the fraction of the momentum
+ !! originally in a layer that remains after a time-step of viscosity,
+ !! and the fraction of a time-step's worth of a barotropic acceleration
+ !! that a layer experiences after viscosity is applied [nondim].
+ !! Visc_rem_v is between 0 (at the bottom) and 1 (far above the bottom).
+ real, dimension(SZI_(G),SZJB_(G)), intent(in) :: visc_rem_max !< The column maximum of visc_rem [nondim]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
+ intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
+ optional, intent(inout) :: v_cor !< The meridional velocities (v with a barotropic correction)
+ !! that give vhbt as the depth-integrated transport [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ optional, intent(out) :: dv_cor !< The meridional velocity increments from v that give
+ !! vhbt as the depth-integrated transports [L T-1 ~> m s-1].
+ type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the
+ !! effective open face areas as a function of barotropic flow.
+ real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt !< The summed volume flux through meridional
+ !! faces [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, intent(in) :: dt !< Time increment [T ~> s].
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
+ type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure.
+ type(cont_loop_bounds_type), intent(in) :: LB !< Loop boundary variable.
+ ! Local variables
+ logical, dimension(SZI_(G),SZJB_(G)) :: do_I
+ logical, dimension(SZI_(G),SZJB_(G)) :: simple_OBC_pt ! Indicates points in a row with specified transport OBCs
+ type(OBC_segment_type), pointer :: segment => NULL()
+ real :: FAvi, FA_v ! A sum of meridional face areas [H L ~> m2 or kg m-1].
+ logical :: set_BT_cont
+ logical :: any_simple_OBC, local_specified_BC, local_Flather_OBC, local_open_BC ! OBC-related logicals
+ integer :: l_seg, i, j, k, n, ish, ieh, jsh, jeh, nz
+
+ ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke
+
+ set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont))
+
+ local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false.
+ if (associated(OBC)) then ; if (OBC%OBC_pe) then
+ local_specified_BC = OBC%specified_u_BCs_exist_globally
+ local_Flather_OBC = OBC%Flather_u_BCs_exist_globally
+ local_open_BC = OBC%open_u_BCs_exist_globally
+ endif ; endif
+
+ if (present(vhbt) .or. set_BT_cont) then
+ !$omp target enter data map(alloc: do_I, simple_OBC_pt)
+ any_simple_OBC = .false.
+ if (local_specified_BC .or. local_Flather_OBC) then
+ do concurrent (j=jsh-1:jeh, i=ish:ieh)
+ l_seg = abs(OBC%segnum_v(i,J))
+
+ ! Avoid reconciling barotropic/baroclinic transports if transport is specified
+ simple_OBC_pt(i,J) = .false.
+ if (l_seg /= 0) simple_OBC_pt(i,J) = OBC%segment(l_seg)%specified
+ do_I(i,J) = .not.simple_OBC_pt(i,J)
+ any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(i,J)
+ enddo
+ else
+ do concurrent (J=jsh-1:jeh, i=ish:ieh)
+ do_I(i,J) = .true.
+ enddo
+ endif ! local_specified_BC .or. local_Flather_OBC
+
+ if (present(vhbt)) then
+ ! Find dv and vh.
+ call meridional_flux_adjust(v, h_in, h_S, h_N, vh_tot_0, dvhdv_tot_0, dv, &
+ dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem_v, &
+ ish, ieh, jsh, jeh, do_I, por_face_areaV, vhbt, vh, OBC=OBC)
+
+ do concurrent (J=jsh-1:jeh)
+ if (present(v_cor)) then
+ do concurrent (k=1:nz, i=ish:ieh)
+ v_cor(i,J,k) = v(i,J,k) + dv(i,J) * visc_rem_v(i,J,k)
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)
- 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)
- BT_cont%FA_v_SS(i,J) = FAvi(i) ; BT_cont%FA_v_NN(i,J) = FAvi(i)
- BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0
- endif ; enddo
- endif
- endif ! set_BT_cont
+ if (any_simple_OBC) then
+ ! untested
+ do concurrent (k=1:nz, i=ish:ieh, simple_OBC_pt(i,J))
+ v_cor(i,J,k) = OBC%segment(abs(OBC%segnum_v(i,J)))%normal_vel(i,J,k)
+ enddo
+ endif
+ endif ! v-corrected
- endif ! present(vhbt) or set_BT_cont
+ if (present(dv_cor)) then
+ do concurrent (i=ish:ieh)
+ dv_cor(i,J) = dv(i,J)
+ enddo
+ endif ! dv-corrected
+ enddo
+ endif
- enddo ! j-loop
+ if (set_BT_cont) then
+ ! Diagnose the zero-transport correction, dv0.
+ call meridional_flux_adjust(v, h_in, h_S, h_N, vh_tot_0, dvhdv_tot_0, dv, &
+ dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem_v, &
+ ish, ieh, jsh, jeh, do_I, por_face_areaV)
+ call set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, dv, vh_tot_0, dvhdv_tot_0, &
+ dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem_v, &
+ visc_rem_max, ish, ieh, jsh, jeh, do_I, por_face_areaV)
+
+ if (any_simple_OBC) then
+ ! untested
+ ! NOTE: simple_OBC_pt(i,j) should prevent access to segment OBC_NONE
+ do concurrent (J=jsh-1:jeh, i=ish:jeh, simple_OBC_pt(i,J))
+ segment => OBC%segment(abs(OBC%segnum_v(i,J)))
+ FAvi = GV%H_subroundoff*G%dx_Cv(i,J)
+ do k=1,nz
+ if ((abs(segment%normal_vel(i,J,k)) > 0.0) .and. (segment%specified)) &
+ FAvi = FAvi + segment%normal_trans(i,J,k) / segment%normal_vel(i,J,k)
+ enddo
+ BT_cont%FA_v_S0(i,J) = FAvi ; BT_cont%FA_v_N0(i,J) = FAvi
+ BT_cont%FA_v_SS(i,J) = FAvi ; BT_cont%FA_v_NN(i,J) = FAvi
+ BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0
+ enddo
+ endif ! any_simple_OBC
+ endif ! set_BT_cont
+ !$omp target exit data map(release: do_I, simple_OBC_pt)
+ endif ! present(vhbt) or set_BT_cont
+ ! untested - probably needs to be refactored to be performant on GPU
if (local_open_BC .and. set_BT_cont) then
do n = 1, OBC%number_of_segments
if (OBC%segment(n)%open .and. OBC%segment(n)%is_N_or_S) then
J = OBC%segment(n)%HI%JsdB
if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- do i = OBC%segment(n)%HI%Isd, OBC%segment(n)%HI%Ied
+ do concurrent (i = OBC%segment(n)%HI%Isd:OBC%segment(n)%HI%Ied)
FA_v = 0.0
do k=1,nz ; FA_v = FA_v + h_in(i,j,k)*(G%dx_Cv(i,J)*por_face_areaV(i,J,k)) ; enddo
BT_cont%FA_v_S0(i,J) = FA_v ; BT_cont%FA_v_N0(i,J) = FA_v
@@ -1683,7 +2018,7 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p
BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0
enddo
else
- do i = OBC%segment(n)%HI%Isd, OBC%segment(n)%HI%Ied
+ do concurrent (i = OBC%segment(n)%HI%Isd:OBC%segment(n)%HI%Ied)
FA_v = 0.0
do k=1,nz ; FA_v = FA_v + h_in(i,j+1,k)*(G%dx_Cv(i,J)*por_face_areaV(i,J,k)) ; enddo
BT_cont%FA_v_S0(i,J) = FA_v ; BT_cont%FA_v_N0(i,J) = FA_v
@@ -1705,9 +2040,7 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p
endif
endif ; endif
- call cpu_clock_end(id_clock_correct)
-
-end subroutine meridional_mass_flux
+end subroutine present_vhbt_or_set_BT_cont
!> Calculates the vertically integrated mass or volume fluxes through the meridional faces.
@@ -1725,7 +2058,7 @@ subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, O
!! faces [H L2 T-1 ~> m3 s-1 or kg s-1].
real, intent(in) :: dt !< Time increment [T ~> s].
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G
+ type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type
!! specifies whether, where, and what
!! open boundary conditions are used.
@@ -1733,12 +2066,10 @@ subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, O
type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure.
! Local variables
- real :: vh(SZI_(G)) ! Volume flux through meridional faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]
- real :: dvhdv(SZI_(G)) ! Partial derivative of vh with v [H L ~> m2 or kg m-1].
- logical, dimension(SZI_(G)) :: do_I
- real :: ones(SZI_(G)) ! An array of 1's [nondim]
- integer :: i, j, k, ish, ieh, jsh, jeh, nz
- logical :: local_specified_BC, OBC_in_row
+ real :: vh(SZI_(G),SZJB_(G),SZK_(GV)) ! Volume flux through meridional faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]
+ real :: dvhdv(SZI_(G),SZJB_(G),SZK_(GV)) ! Partial derivative of vh with v [H L ~> m2 or kg m-1].
+ integer :: i, j, k, ish, ieh, jsh, jeh, nz, l_seg
+ logical :: local_specified_BC, OBC_in_row(SZJB_(G))
call cpu_clock_begin(id_clock_correct)
@@ -1753,123 +2084,44 @@ subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, O
ish = G%isc ; ieh = G%iec ; jsh = G%jsc ; jeh = G%jec ; nz = GV%ke
endif
- ones(:) = 1.0 ; do_I(:) = .true.
-
vhbt(:,:) = 0.0
- !$OMP parallel do default(shared) private(vh,dvhdv,OBC_in_row)
- do J=jsh-1,jeh
- ! Determining whether there are any OBC points outside of the k-loop should be more efficient.
- OBC_in_row = .false.
- if (local_specified_BC) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then
- if (OBC%segment(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)
- endif ; enddo ; endif
-
- ! Accumulate the barotropic transport.
- do i=ish,ieh
- vhbt(i,J) = vhbt(i,J) + vh(i)
- enddo
- enddo ! k-loop
- enddo ! j-loop
- call cpu_clock_end(id_clock_correct)
+ ! 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 j=jsh-1,jeh ; 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(j) = .true.
+ endif ; enddo ; enddo
+ endif
-end subroutine meridional_BT_mass_flux
+ ! This sets vh and dvhdv.
+ do concurrent (k=1:nz, J=jsh-1:jeh, i=ish:ieh)
+ call flux_elem(v(i,J,k), h_in(i,J,k), h_in(i,J+1,k), h_S(i,J,k), h_S(i,J+1,k), &
+ h_N(i,J,k), h_N(i,J+1,k), vh(i,J,k), dvhdv(i,J,k), 1.0, G%dx_Cv(I,j), &
+ G%IareaT(i,J), G%IareaT(i,J+1), G%IdyT(i,J), G%IdyT(i,J+1), dt, G, GV, &
+ US, CS%vol_CFL, por_face_areaV(i,J,k))
+ if (local_specified_BC) &
+ call flux_elem_OBC(v(i,J,k), h_in(i,J,k), h_in(i,J+1,k), vh(i,J,k), dvhdv(i,J,k), 1.0, G, GV, &
+ por_face_areaV(i,J,k), G%dx_Cv(i,J), OBC, OBC%segnum_v(i,J))
+ enddo
+ do k=1,nz ; do j=jsh-1,jeh ; do i=ish,ieh
+ if (OBC_in_row(j) .and. 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 ; enddo ; enddo
-!> Evaluates the meridional mass or volume fluxes in a layer.
-subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, &
- ish, ieh, do_I, vol_CFL, por_face_areaV, OBC)
- type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1].
- real, dimension(SZI_(G)), intent(in) :: visc_rem !< Both the fraction of the
- !! momentum originally in a layer that remains after a time-step
- !! of viscosity, and the fraction of a time-step's worth of a barotropic
- !! acceleration that a layer experiences after viscosity is applied [nondim].
- !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom).
- real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Layer thickness used to calculate fluxes,
- !! [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_S !< South edge thickness in the reconstruction
- !! [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_N !< North edge thickness in the reconstruction
- !! [H ~> m or kg m-2].
- real, dimension(SZI_(G)), intent(inout) :: vh !< Meridional mass or volume transport
- !! [H L2 T-1 ~> m3 s-1 or kg s-1].
- real, dimension(SZI_(G)), intent(inout) :: dvhdv !< Partial derivative of vh with v
- !! [H L ~> m2 or kg m-1].
- real, intent(in) :: dt !< Time increment [T ~> s].
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- integer, intent(in) :: j !< Spatial index.
- integer, intent(in) :: ish !< Start of index range.
- integer, intent(in) :: ieh !< End of index range.
- logical, dimension(SZI_(G)), intent(in) :: do_I !< Which i values to work on.
- logical, intent(in) :: vol_CFL !< If true, rescale the
- !! ratio of face areas to the cell areas when estimating the CFL number.
- real, dimension(SZI_(G),SZJB_(G)), &
- intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim]
- type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure.
- ! Local variables
- real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]
- real :: curv_3 ! A measure of the thickness curvature over a grid length,
- ! with the same units as h, 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.
- if (present(OBC)) then ; if (associated(OBC)) then
- local_open_BC = OBC%open_v_BCs_exist_globally
- endif ; endif
+ ! Accumulate the barotropic transport.
+ do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh
+ vhbt(i,J) = vhbt(i,J) + vh(i,J,k)
+ enddo ; enddo ; enddo
- do i=ish,ieh ; if (do_I(i)) then
- if (v(i) > 0.0) then
- if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j))
- else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif
- curv_3 = (h_S(i,j) + h_N(i,j)) - 2.0*h(i,j)
- vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_N(i,j) + CFL * &
- (0.5*(h_S(i,j) - h_N(i,j)) + curv_3*(CFL - 1.5)) )
- h_marg = h_N(i,j) + CFL * ((h_S(i,j) - h_N(i,j)) + &
- 3.0*curv_3*(CFL - 1.0))
- elseif (v(i) < 0.0) then
- if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1))
- else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif
- curv_3 = (h_S(i,j+1) + h_N(i,j+1)) - 2.0*h(i,j+1)
- vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_S(i,j+1) + CFL * &
- (0.5*(h_N(i,j+1)-h_S(i,j+1)) + curv_3*(CFL - 1.5)) )
- h_marg = h_S(i,j+1) + CFL * ((h_N(i,j+1)-h_S(i,j+1)) + &
- 3.0*curv_3*(CFL - 1.0))
- else
- vh(i) = 0.0
- h_marg = 0.5 * (h_S(i,j+1) + h_N(i,j))
- endif
- dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h_marg * visc_rem(i)
- endif ; enddo
+ call cpu_clock_end(id_clock_correct)
+
+end subroutine meridional_BT_mass_flux
- 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
- 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
- vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * h(i,j+1)
- dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h(i,j+1) * visc_rem(i)
- endif
- endif
- endif
- endif ; enddo
- endif
-end subroutine merid_flux_layer
!> Sets the effective interface thickness associated with the fluxes at each meridional velocity point,
!! optionally scaling back these thicknesses to account for viscosity and fractional open areas.
@@ -1912,78 +2164,75 @@ subroutine meridional_flux_thickness(v, h, h_S, h_N, h_v, dt, G, GV, US, LB, vol
real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2].
logical :: local_open_BC
integer :: i, j, k, ish, ieh, jsh, jeh, n, nz
+ real :: dh
ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke
- !$OMP parallel do default(shared) private(CFL,curv_3,h_marg,h_avg)
- do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh
+ do concurrent (k=1:nz, J=jsh-1:jeh, i=ish:ieh)
if (v(i,J,k) > 0.0) then
if (vol_CFL) then ; CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j))
else ; CFL = v(i,J,k) * dt * G%IdyT(i,j) ; endif
curv_3 = (h_S(i,j,k) + h_N(i,j,k)) - 2.0*h(i,j,k)
- h_avg = h_N(i,j,k) + CFL * (0.5*(h_S(i,j,k) - h_N(i,j,k)) + curv_3*(CFL - 1.5))
- h_marg = h_N(i,j,k) + CFL * ((h_S(i,j,k) - h_N(i,j,k)) + &
- 3.0*curv_3*(CFL - 1.0))
+ dh = h_S(i,J,k) - h_N(i,J,k)
+ if (marginal) then
+ h_v(i,J,k) = h_N(i,j,k) + CFL * (dh + 3.0*curv_3*(CFL - 1.0))
+ else
+ h_v(i,J,k) = h_N(i,j,k) + CFL * (0.5*dh + curv_3*(CFL - 1.5))
+ endif
elseif (v(i,J,k) < 0.0) then
if (vol_CFL) then ; CFL = (-v(i,J,k)*dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1))
else ; CFL = -v(i,J,k) * dt * G%IdyT(i,j+1) ; endif
curv_3 = (h_S(i,j+1,k) + h_N(i,j+1,k)) - 2.0*h(i,j+1,k)
- h_avg = h_S(i,j+1,k) + CFL * (0.5*(h_N(i,j+1,k)-h_S(i,j+1,k)) + curv_3*(CFL - 1.5))
- h_marg = h_S(i,j+1,k) + CFL * ((h_N(i,j+1,k)-h_S(i,j+1,k)) + &
- 3.0*curv_3*(CFL - 1.0))
+ dh = h_N(i,j+1,k)-h_S(i,j+1,k)
+ if (marginal) then
+ h_v(i,J,k) = h_S(i,j+1,k) + CFL * (dh + 3.0*curv_3*(CFL - 1.0))
+ else
+ h_v(i,J,k) = h_S(i,j+1,k) + CFL * (0.5*dh + curv_3*(CFL - 1.5))
+ endif
else
- h_avg = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k))
! The choice to use the arithmetic mean here is somewhat arbitrarily, but
! it should be noted that h_S(i+1,j,k) and h_N(i,j,k) are usually the same.
- h_marg = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k))
+ h_v(i,J,k) = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k))
! h_marg = (2.0 * h_S(i,j+1,k) * h_N(i,j,k)) / &
! (h_S(i,j+1,k) + h_N(i,j,k) + GV%H_subroundoff)
endif
- if (marginal) then ; h_v(i,J,k) = h_marg
- else ; h_v(i,J,k) = h_avg ; endif
- enddo ; enddo ; enddo
-
- if (present(visc_rem_v)) then
- ! Scale back the thickness to account for the effects of viscosity and the fractional open
- ! thickness to give an appropriate non-normalized weight for each layer in determining the
- ! barotropic acceleration.
- !$OMP parallel do default(shared)
- do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh
+ if (present(visc_rem_v)) then
+ ! Scale back the thickness to account for the effects of viscosity and the fractional open
+ ! thickness to give an appropriate non-normalized weight for each layer in determining the
+ ! barotropic acceleration.
h_v(i,J,k) = h_v(i,J,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k))
- enddo ; enddo ; enddo
- else
- !$OMP parallel do default(shared)
- do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh
+ else
h_v(i,J,k) = h_v(i,J,k) * por_face_areaV(i,J,k)
- enddo ; enddo ; enddo
- endif
+ endif
+ enddo
local_open_BC = .false.
if (associated(OBC)) local_open_BC = OBC%open_v_BCs_exist_globally
+ ! untested - will need to be refactored to be performant on GPUs
if (local_open_BC) then
do n = 1, OBC%number_of_segments
if (OBC%segment(n)%open .and. OBC%segment(n)%is_N_or_S) then
J = OBC%segment(n)%HI%JsdB
if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- if (present(visc_rem_v)) then ; do k=1,nz
- do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied
- h_v(i,J,k) = h(i,j,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k))
+ if (present(visc_rem_v)) then
+ do concurrent (k=1:nz, i = OBC%segment(n)%HI%isd:OBC%segment(n)%HI%ied)
+ h_v(i,J,k) = h(i,J,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k))
enddo
- enddo ; else ; do k=1,nz
- do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied
- h_v(i,J,k) = h(i,j,k) * por_face_areaV(i,J,k)
+ else
+ do concurrent (k=1:nz, i = OBC%segment(n)%HI%isd:OBC%segment(n)%HI%ied)
+ h_v(i,J,k) = h(i,J,k) * por_face_areaV(i,J,k)
enddo
- enddo ; endif
+ endif
else
- if (present(visc_rem_v)) then ; do k=1,nz
- do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied
- h_v(i,J,k) = h(i,j+1,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k))
+ if (present(visc_rem_v)) then
+ do concurrent (k=1:nz, i = OBC%segment(n)%HI%isd:OBC%segment(n)%HI%ied)
+ h_v(i,J,k) = h(i,J+1,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k))
enddo
- enddo ; else ; do k=1,nz
- do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied
- h_v(i,J,k) = h(i,j+1,k) * por_face_areaV(i,J,k)
+ else
+ do concurrent (k=1:nz, i = OBC%segment(n)%HI%isd:OBC%segment(n)%HI%ied)
+ h_v(i,J,k) = h(i,J+1,k) * por_face_areaV(i,J,k)
enddo
- enddo ; endif
+ endif
endif
endif
enddo
@@ -1991,57 +2240,67 @@ subroutine meridional_flux_thickness(v, h, h_S, h_N, h_v, dt, G, GV, US, LB, vol
end subroutine meridional_flux_thickness
+
!> Returns the barotropic velocity adjustment that gives the desired barotropic (layer-summed) transport.
-subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vhbt, vh_tot_0, dvhdv_tot_0, &
+subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vh_tot_0, dvhdv_tot_0, &
dv, dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, &
- j, ish, ieh, do_I_in, por_face_areaV, vh_3d, OBC)
+ ish, ieh, jsh, jeh, do_I_in, por_face_areaV, vhbt, vh_3d, OBC)
type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1].
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),&
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
intent(in) :: h_S !< South edge thickness in the reconstruction [H ~> m or kg m-2].
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
intent(in) :: h_N !< North edge thickness in the reconstruction [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZK_(GV)), intent(in) :: visc_rem
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
+ intent(in) :: visc_rem
!< Both the fraction of the momentum originally
!! in a layer that remains after a time-step of viscosity, and the
!! fraction of a time-step's worth of a barotropic acceleration that
!! a layer experiences after viscosity is applied [nondim].
!! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom).
- real, dimension(SZI_(G)), intent(in) :: vhbt !< The summed volume flux through meridional faces
- !! [H L2 T-1 ~> m3 s-1 or kg s-1].
- real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value of dv [L T-1 ~> m s-1].
- real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value of dv [L T-1 ~> m s-1].
- real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport with 0 adjustment
- !! [H L2 T-1 ~> m3 s-1 or kg s-1].
- real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative of dv_err with
- !! dv at 0 adjustment [H L ~> m2 or kg m-1].
- real, dimension(SZI_(G)), intent(out) :: dv !< The barotropic velocity adjustment [L T-1 ~> m s-1].
- real, intent(in) :: dt !< Time increment [T ~> s].
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
- integer, intent(in) :: j !< Spatial index.
- integer, intent(in) :: ish !< Start of index range.
- integer, intent(in) :: ieh !< End of index range.
- logical, dimension(SZI_(G)), &
- intent(in) :: do_I_in !< A flag indicating which I values to work on.
+ real, dimension(SZI_(G),SZJB_(G)), &
+ optional, intent(in) :: vhbt !< The summed volume flux through meridional faces
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: dv_max_CFL !< Maximum acceptable value of dv [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: dv_min_CFL !< Minimum acceptable value of dv [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: vh_tot_0 !< The summed transport with 0 adjustment
+ !! [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: dvhdv_tot_0 !< The partial derivative of dv_err with
+ !! dv at 0 adjustment [H L ~> m2 or kg m-1].
+ real, dimension(SZI_(G),SZJB_(G)), &
+ intent(out) :: dv !< The barotropic velocity adjustment [L T-1 ~> m s-1].
+ real, intent(in) :: dt !< Time increment [T ~> s].
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
+ integer, intent(in) :: ish !< Start of i index range.
+ integer, intent(in) :: ieh !< End of i index range.
+ integer, intent(in) :: jsh !< Start of j index range.
+ integer, intent(in) :: jeh !< End of j index range.
+ logical, dimension(SZI_(G),SZJB_(G)), &
+ intent(in) :: do_I_in !< A flag indicating which I values to work on.
real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
- intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim]
+ intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim]
real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
- optional, intent(inout) :: vh_3d !< Volume flux through meridional
+ optional, intent(inout) :: vh_3d !< Volume flux through meridional
!! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1].
type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure.
! Local variables
real, dimension(SZI_(G),SZK_(GV)) :: &
- vh_aux, & ! An auxiliary meridional volume flux [H L2 T-1 ~> m3 s-1 or kg s-1].
- dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1].
+ vh_aux ! An auxiliary meridional volume flux [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real :: &
+ dvhdv, & ! Partial derivative of vh with v [H L ~> m2 or kg m-1].
+ v_new ! The velocity with the correction added [L T-1 ~> m s-1].
real, dimension(SZI_(G)) :: &
vh_err, & ! Difference between vhbt and the summed vh [H L2 T-1 ~> m3 s-1 or kg s-1].
vh_err_best, & ! The smallest value of vh_err found so far [H L2 T-1 ~> m3 s-1 or kg s-1].
- v_new, & ! The velocity with the correction added [L T-1 ~> m s-1].
dvhdv_tot,&! Summed partial derivative of vh with u [H L ~> m2 or kg m-1].
dv_min, & ! Lower limit on dv correction based on CFL limits and previous iterations [L T-1 ~> m s-1]
dv_max ! Upper limit on dv correction based on CFL limits and previous iterations [L T-1 ~> m s-1]
@@ -2049,159 +2308,198 @@ subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vhbt, vh_tot_0, dvhdv_tot_0
real :: ddv ! The change in dv from the previous iteration [L T-1 ~> m s-1].
real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2].
real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1].
- integer :: i, k, nz, itt, max_itts = 20
- logical :: domore, do_I(SZI_(G))
+ integer :: i, j, k, nz, itt
+ logical :: do_I(SZI_(G)), local_OBC, use_vhbt
+ integer, parameter :: max_itts = 20
+
+ local_OBC = .false.
+ if (present(OBC)) then
+ if (associated(OBC)) then
+ local_OBC = OBC%open_u_BCs_exist_globally
+ endif
+ endif
+
+ use_vhbt = present(vhbt)
nz = GV%ke
- vh_aux(:,:) = 0.0 ; dvhdv(:,:) = 0.0
+ tol_vel = CS%tol_vel
- if (present(vh_3d)) then ; do k=1,nz ; do i=ish,ieh
- vh_aux(i,k) = vh_3d(i,J,k)
- enddo ; enddo ; endif
+ ! NVIDIA needs private arrays to be alloc'ed to prevent data transfers.
+ ! GCC doesn't understand map(alloc: ...) for variables also marked private
+ !$omp target enter data map(alloc: do_I, dv_max, dv_min, dvhdv_tot, vh_err, vh_err_best, vh_aux)
- do i=ish,ieh
- dv(i) = 0.0 ; do_I(i) = do_I_in(i)
- dv_max(i) = dv_max_CFL(i) ; dv_min(i) = dv_min_CFL(i)
- vh_err(i) = vh_tot_0(i) - vhbt(i) ; dvhdv_tot(i) = dvhdv_tot_0(i)
- vh_err_best(i) = abs(vh_err(i))
- enddo
+ !$omp target teams loop &
+ !$omp private(vh_err, vh_err_best, dvhdv_tot, dv_min, dv_max, do_I, vh_aux, itt, tol_eta)
+ do J=jsh-1,jeh
- do itt=1,max_itts
- select case (itt)
- case (:1) ; tol_eta = 1e-6 * CS%tol_eta
- case (2) ; tol_eta = 1e-4 * CS%tol_eta
- case (3) ; tol_eta = 1e-2 * CS%tol_eta
- case default ; tol_eta = CS%tol_eta
- end select
- tol_vel = CS%tol_vel
-
- do i=ish,ieh
- if (vh_err(i) > 0.0) then ; dv_max(i) = dv(i)
- elseif (vh_err(i) < 0.0) then ; dv_min(i) = dv(i)
- else ; do_I(i) = .false. ; endif
+ if (present(vh_3d)) then
+ do concurrent (k=1:nz, i=ish:ieh)
+ vh_aux(i,k) = vh_3d(i,J,k)
+ enddo
+ endif
+
+ do concurrent (i=ish:ieh)
+ dv(i,J) = 0.0 ; do_I(i) = do_I_in(i,J)
+ dv_max(i) = dv_max_CFL(i,J) ; dv_min(i) = dv_min_CFL(i,J)
+ vh_err(i) = vh_tot_0(i,J)
+ if (use_vhbt) vh_err(i) = vh_err(i) - vhbt(i,J)
+ dvhdv_tot(i) = dvhdv_tot_0(i,J)
+ vh_err_best(i) = abs(vh_err(i))
enddo
- domore = .false.
- do i=ish,ieh ; if (do_I(i)) then
- if ((dt * min(G%IareaT(i,j),G%IareaT(i,j+1))*abs(vh_err(i)) > tol_eta) .or. &
- (CS%better_iter .and. ((abs(vh_err(i)) > tol_vel * dvhdv_tot(i)) .or. &
- (abs(vh_err(i)) > vh_err_best(i))) )) then
- ! Use Newton's method, provided it stays bounded. Otherwise bisect
- ! the value with the appropriate bound.
- ddv = -vh_err(i) / dvhdv_tot(i)
- dv_prev = dv(i)
- dv(i) = dv(i) + ddv
- if (abs(ddv) < 1.0e-15*abs(dv(i))) then
- do_I(i) = .false. ! ddv is small enough to quit.
- elseif (ddv > 0.0) then
- if (dv(i) >= dv_max(i)) then
- dv(i) = 0.5*(dv_prev + dv_max(i))
- if (dv_max(i) - dv_prev < 1.0e-15*abs(dv(i))) do_I(i) = .false.
- endif
- else ! dvv(i) < 0.0
- if (dv(i) <= dv_min(i)) then
- dv(i) = 0.5*(dv_prev + dv_min(i))
- if (dv_prev - dv_min(i) < 1.0e-15*abs(dv(i))) do_I(i) = .false.
+
+ do itt=1,max_itts
+ select case (itt)
+ case (:1) ; tol_eta = 1e-6 * CS%tol_eta
+ case (2) ; tol_eta = 1e-4 * CS%tol_eta
+ case (3) ; tol_eta = 1e-2 * CS%tol_eta
+ case default ; tol_eta = CS%tol_eta
+ end select
+
+ do concurrent (i=ish:ieh)
+ if (vh_err(i) > 0.0) then ; dv_max(i) = dv(i,j)
+ elseif (vh_err(i) < 0.0) then ; dv_min(i) = dv(i,j)
+ else ; do_I(i) = .false. ; endif
+ enddo
+
+ do concurrent (i=ish:ieh, do_I(i)) &
+ & DO_LOCALITY(local(ddv, dv_prev))
+ if ((dt * min(G%IareaT(i,j),G%IareaT(i,j+1))*abs(vh_err(i)) > tol_eta) .or. &
+ (CS%better_iter .and. ((abs(vh_err(i)) > tol_vel * dvhdv_tot(i)) .or. &
+ (abs(vh_err(i)) > vh_err_best(i))) )) then
+ ! Use Newton's method, provided it stays bounded. Otherwise bisect
+ ! the value with the appropriate bound.
+ ddv = -vh_err(i) / dvhdv_tot(i)
+ dv_prev = dv(i,j)
+ dv(i,j) = dv(i,j) + ddv
+ if (abs(ddv) < 1.0e-15*abs(dv(i,j))) then
+ do_I(i) = .false. ! ddv is small enough to quit.
+ elseif (ddv > 0.0) then
+ if (dv(i,j) >= dv_max(i)) then
+ dv(i,j) = 0.5*(dv_prev + dv_max(i))
+ if (dv_max(i) - dv_prev < 1.0e-15*abs(dv(i,j))) do_I(i) = .false.
+ endif
+ else ! ddv(i) < 0.0
+ if (dv(i,j) <= dv_min(i)) then
+ dv(i,j) = 0.5*(dv_prev + dv_min(i))
+ if (dv_prev - dv_min(i) < 1.0e-15*abs(dv(i,j))) do_I(i) = .false.
+ endif
endif
+ else
+ do_I(i) = .false.
endif
- if (do_I(i)) domore = .true.
- else
- do_I(i) = .false.
- endif
- endif ; enddo
- if (.not.domore) exit
-
- if ((itt < max_itts) .or. present(vh_3d)) then ; do k=1,nz
- do i=ish,ieh ; v_new(i) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo
- call merid_flux_layer(v_new, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), &
- vh_aux(:,k), dvhdv(:,k), visc_rem(:,k), &
- dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC)
- enddo ; endif
-
- if (itt < max_itts) then
- do i=ish,ieh
- vh_err(i) = -vhbt(i) ; dvhdv_tot(i) = 0.0
enddo
- do k=1,nz ; do i=ish,ieh
- vh_err(i) = vh_err(i) + vh_aux(i,k)
- dvhdv_tot(i) = dvhdv_tot(i) + dvhdv(i,k)
- enddo ; enddo
- do i=ish,ieh
- vh_err_best(i) = min(vh_err_best(i), abs(vh_err(i)))
+
+ ! Below conditional compilation is to control whether early exit happens when compiled with
+ ! OpenMP - compiling with OpenMP prevents early exit. Without OpenMP, enables early exit.
+ ! Early exit saves time on CPU, but causes other loops to be serialized on GPU.
+ !$ if (.false.) then
+ if (.not. any(do_I(ish:ieh))) exit
+ !$ endif
+
+ if ((itt < max_itts) .or. present(vh_3d)) then
+ do concurrent (i=ish:ieh)
+ vh_err(i) = 0.0 ; dvhdv_tot(i) = 0.0
+ if (use_vhbt) vh_err(i) = -vhbt(i,J)
+ enddo
+ do k=1,nz ; do concurrent (i=ish:ieh, do_I(i)) DO_LOCALITY(local(v_new, dvhdv))
+ v_new = v(i,J,k) + dv(i,j) * visc_rem(i,j,k)
+ call flux_elem(v_new, h_in(i,J,k), h_in(i,J+1,k), h_S(i,J,k), h_S(i,J+1,k), &
+ h_N(i,J,k), h_N(i,J+1,k), vh_aux(i,k), dvhdv, visc_rem(i,J,k), &
+ G%dx_Cv(i,J), G%IareaT(i,J), G%IareaT(i,J+1), G%idyT(i,J), G%IdyT(i,J+1), &
+ dt, G, GV, US, CS%vol_CFL, por_face_areaV(i,J,k))
+ if (local_OBC) &
+ call flux_elem_OBC(v_new, h_in(i,J,k), h_in(i,J+1,k), vh_aux(i,k), &
+ dvhdv, visc_rem(i,J,k), G, GV, por_face_areaV(i,J,k), &
+ G%dx_Cv(i,J), OBC, OBC%segnum_v(i,J))
+ vh_err(i) = vh_err(i) + vh_aux(i,k)
+ dvhdv_tot(i) = dvhdv_tot(i) + dvhdv
+ enddo ; enddo
+ do concurrent (i=ish:ieh, do_I(i))
+ vh_err_best(i) = min(vh_err_best(i), abs(vh_err(i)))
+ enddo
+ endif
+ enddo ! itt-loop
+
+ ! If there are any faces which have not converged to within the tolerance,
+ ! so-be-it, or else use a final upwind correction?
+ ! This never seems to happen with 20 iterations as max_itt.
+
+ if (present(vh_3d)) then
+ do concurrent (k=1:nz, i=ish:ieh)
+ vh_3d(i,J,k) = vh_aux(i,k)
enddo
endif
- enddo ! itt-loop
- ! If there are any faces which have not converged to within the tolerance,
- ! so-be-it, or else use a final upwind correction?
- ! This never seems to happen with 20 iterations as max_itt.
+ enddo ! j-loop
- if (present(vh_3d)) then ; do k=1,nz ; do i=ish,ieh
- vh_3d(i,J,k) = vh_aux(i,k)
- enddo ; enddo ; endif
+ !$omp target exit data map(release: do_I, dv_max, dv_min, dvhdv_tot, vh_err, vh_err_best, vh_aux)
end subroutine meridional_flux_adjust
+
!> Sets of a structure that describes the meridional barotropic volume or mass fluxes as a
!! function of barotropic flow to agree closely with the sum of the layer's transports.
-subroutine set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0, &
+subroutine set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, dv0, vh_tot_0, dvhdv_tot_0, &
dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, &
- visc_rem_max, j, ish, ieh, do_I, por_face_areaV)
- type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
- real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to calculate fluxes,
- !! [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the reconstruction,
- !! [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the reconstruction,
- !! [H ~> m or kg m-2].
- type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements
+ visc_rem_max, ish, ieh, jsh, jeh, do_I, por_face_areaV)
+ type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to calculate fluxes,
+ !! [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the reconstruction,
+ !! [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the reconstruction,
+ !! [H ~> m or kg m-2].
+ type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements
!! that describe the effective open face areas as a function of barotropic flow.
- real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport
+ real, dimension(SZI_(G),SZJB_(G)), intent(in) :: dv0 !< The barotropic velocity increment that
+ !! gives 0 transport [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJB_(G)), intent(in) :: vh_tot_0 !< The summed transport
!! with 0 adjustment [H L2 T-1 ~> m3 s-1 or kg s-1].
- real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative
+ real, dimension(SZI_(G),SZJB_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative
!! of du_err with dv at 0 adjustment [H L ~> m2 or kg m-1].
- real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value
- !! of dv [L T-1 ~> m s-1].
- real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value
- !! of dv [L T-1 ~> m s-1].
- real, intent(in) :: dt !< Time increment [T ~> s].
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
- real, dimension(SZI_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the
+ real, dimension(SZI_(G),SZJB_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value
+ !! of dv [L T-1 ~> m s-1].
+ real, dimension(SZI_(G),SZJB_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value
+ !! of dv [L T-1 ~> m s-1].
+ real, intent(in) :: dt !< Time increment [T ~> s].
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the
!! momentum originally in a layer that remains after a time-step
!! of viscosity, and the fraction of a time-step's worth of a barotropic
!! acceleration that a layer experiences after viscosity is applied [nondim].
!! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom).
- real, dimension(SZI_(G)), intent(in) :: visc_rem_max !< Maximum allowable visc_rem [nondim]
- integer, intent(in) :: j !< Spatial index.
- integer, intent(in) :: ish !< Start of index range.
- integer, intent(in) :: ieh !< End of index range.
- logical, dimension(SZI_(G)), intent(in) :: do_I !< A logical flag indicating
- !! which I values to work on.
- real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
- intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim]
+ real, dimension(SZI_(G),SZJB_(G)), intent(in) :: visc_rem_max !< Maximum allowable visc_rem [nondim]
+ integer, intent(in) :: ish !< Start of i index range.
+ integer, intent(in) :: ieh !< End of i index range.
+ integer, intent(in) :: jsh !< Start of j index range.
+ integer, intent(in) :: jeh !< End of j index range.
+ logical, dimension(SZI_(G),SZJB_(G)), intent(in) :: do_I !< A logical flag indicating
+ !! which I values to work on.
+ real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: por_face_areaV !< fractional open area of V-faces
+ !! [nondim]
! Local variables
real, dimension(SZI_(G)) :: &
- dv0, & ! The barotropic velocity increment that gives 0 transport [L T-1 ~> m s-1].
- dvL, dvR, & ! The barotropic velocity increments that give the southerly
- ! (dvL) and northerly (dvR) test velocities [L T-1 ~> m s-1].
- zeros, & ! An array of full of 0 transports [H L2 T-1 ~> m3 s-1 or kg s-1]
- dv_CFL, & ! The velocity increment that corresponds to CFL_min [L T-1 ~> m s-1].
- v_L, v_R, & ! The southerly (v_L), northerly (v_R), and zero-barotropic
- v_0, & ! transport (v_0) layer test velocities [L T-1 ~> m s-1].
- dvhdv_L, & ! The effective layer marginal face areas with the southerly
- dvhdv_R, & ! (_L), northerly (_R), and zero-barotropic (_0) test
- dvhdv_0, & ! velocities [H L ~> m2 or kg m-1].
- vh_L, vh_R, & ! The layer transports with the southerly (_L), northerly (_R)
- vh_0, & ! and zero-barotropic (_0) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
- FAmt_L, FAmt_R, & ! The summed effective marginal face areas for the 3
- FAmt_0, & ! test velocities [H L ~> m2 or kg m-1].
- vhtot_L, & ! The summed transport with the southerly (vhtot_L) and
- vhtot_R ! and northerly (vhtot_R) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
- real :: FA_0 ! The effective face area with 0 barotropic transport [H L ~> m2 or kg m-1].
- real :: FA_avg ! The average effective face area [H L ~> m2 or kg m-1], nominally given by
- ! the realized transport divided by the barotropic velocity.
+ dvL, dvR, & ! The barotropic velocity increments that give the southerly
+ ! (dvL) and northerly (dvR) test velocities [L T-1 ~> m s-1].
+ dv_CFL, & ! The velocity increment that corresponds to CFL_min [L T-1 ~> m s-1].
+ FAmt_L, FAmt_R, & ! The summed effective marginal face areas for the 3
+ FAmt_0, & ! test velocities [H L ~> m2 or kg m-1].
+ vhtot_L, & ! The summed transport with the southerly (vhtot_L) and
+ vhtot_R ! and northerly (vhtot_R) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real :: &
+ v_L, v_R, & ! The southerly (v_L), northerly (v_R), and zero-barotropic
+ v_0, & ! transport (v_0) layer test velocities [L T-1 ~> m s-1].
+ dvhdv_L, & ! The effective layer marginal face areas with the southerly
+ dvhdv_R, & ! (_L), northerly (_R), and zero-barotropic (_0) test
+ dvhdv_0, & ! velocities [H L ~> m2 or kg m-1].
+ vh_L, vh_R, & ! The layer transports with the southerly (_L), northerly (_R)
+ vh_0 ! and zero-barotropic (_0) test velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real :: FA_0 ! The effective face area with 0 barotropic transport [H L ~> m2 or kg m-1].
+ real :: FA_avg ! The average effective face area [H L ~> m2 or kg m-1], nominally given by
+ ! the realized transport divided by the barotropic velocity.
real :: visc_rem_lim ! The larger of visc_rem and min_visc_rem [nondim] This
! limiting is necessary to keep the inverse of visc_rem
! from leading to large CFL numbers.
@@ -2209,110 +2507,108 @@ subroutine set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0,
! in finding the barotropic velocity that changes the
! flow direction [nondim]. This is necessary to keep the inverse
! of visc_rem from leading to large CFL numbers.
- real :: CFL_min ! A minimal increment in the CFL to try to ensure that the
- ! flow is truly upwind [nondim]
- real :: Idt ! The inverse of the time step [T-1 ~> s-1].
- logical :: domore
- integer :: i, k, nz
+ real :: CFL_min ! A minimal increment in the CFL to try to ensure that the
+ ! flow is truly upwind [nondim]
+ real :: Idt ! The inverse of the time step [T-1 ~> s-1].
+ integer :: i, j, k, nz
nz = GV%ke ; Idt = 1.0 / dt
min_visc_rem = 0.1 ; CFL_min = 1e-6
- ! Diagnose the zero-transport correction, dv0.
- do i=ish,ieh ; zeros(i) = 0.0 ; enddo
- call meridional_flux_adjust(v, h_in, h_S, h_N, zeros, vh_tot_0, dvhdv_tot_0, dv0, &
- dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, &
- j, ish, ieh, do_I, por_face_areaV)
-
- ! Determine the southerly- and northerly- fluxes. Choose a sufficiently
- ! negative velocity correction for the northerly-flux, and a sufficiently
- ! positive correction for the southerly-flux.
- domore = .false.
- do i=ish,ieh ; if (do_I(i)) then
- domore = .true.
- dv_CFL(i) = (CFL_min * Idt) * G%dyCv(i,J)
- dvR(i) = min(0.0,dv0(i) - dv_CFL(i))
- dvL(i) = max(0.0,dv0(i) + dv_CFL(i))
- FAmt_L(i) = 0.0 ; FAmt_R(i) = 0.0 ; FAmt_0(i) = 0.0
- vhtot_L(i) = 0.0 ; vhtot_R(i) = 0.0
- endif ; enddo
-
- if (.not.domore) then
- do k=1,nz ; do i=ish,ieh
- BT_cont%FA_v_S0(i,J) = 0.0 ; BT_cont%FA_v_SS(i,J) = 0.0
- BT_cont%vBT_SS(i,J) = 0.0
- BT_cont%FA_v_N0(i,J) = 0.0 ; BT_cont%FA_v_NN(i,J) = 0.0
- BT_cont%vBT_NN(i,J) = 0.0
+ !$omp target enter data map(alloc: dvL, dvR, dv_CFL, FAmt_L, FAmt_R, FAmt_0, vhtot_L, vhtot_R)
+
+ !$omp target teams loop private(dvL, dvR, dv_CFL, FAmt_L, FAmt_R, FAmt_0, vhtot_L, vhtot_R)
+ do J=jsh-1,jeh
+ ! Determine the southerly- and northerly- fluxes. Choose a sufficiently
+ ! negative velocity correction for the northerly-flux, and a sufficiently
+ ! positive correction for the southerly-flux.
+ do concurrent (i=ish:ieh)
+ dv_CFL(i) = (CFL_min * Idt) * G%dyCv(i,J)
+ dvR(i) = min(0.0,dv0(i,J) - dv_CFL(i))
+ dvL(i) = max(0.0,dv0(i,J) + dv_CFL(i))
+ FAmt_L(i) = 0.0 ; FAmt_R(i) = 0.0 ; FAmt_0(i) = 0.0
+ vhtot_L(i) = 0.0 ; vhtot_R(i) = 0.0
+ enddo
+
+ ! not parallelized on k because of dvR/L are calculated per column
+ ! nvfortran do concurrent poor performance when k is inside
+ do k=1,nz ; do concurrent (i=ish:ieh, do_I(i,J)) DO_LOCALITY(local(visc_rem_lim))
+ visc_rem_lim = max(visc_rem(i,J,k), min_visc_rem*visc_rem_max(i,J))
+ if (visc_rem_lim > 0.0) then ! This is almost always true for ocean points.
+ if (v(i,J,k) + dvR(i)*visc_rem_lim > -dv_CFL(i)*visc_rem(i,J,k)) &
+ dvR(i) = -(v(i,J,k) + dv_CFL(i)*visc_rem(i,J,k)) / visc_rem_lim
+ if (v(i,J,k) + dvL(i)*visc_rem_lim < dv_CFL(i)*visc_rem(i,J,k)) &
+ dvL(i) = -(v(i,J,k) - dv_CFL(i)*visc_rem(i,J,k)) / visc_rem_lim
+ endif
enddo ; enddo
- return
- endif
- do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then
- visc_rem_lim = max(visc_rem(i,k), min_visc_rem*visc_rem_max(i))
- if (visc_rem_lim > 0.0) then ! This is almost always true for ocean points.
- if (v(i,J,k) + dvR(i)*visc_rem_lim > -dv_CFL(i)*visc_rem(i,k)) &
- dvR(i) = -(v(i,J,k) + dv_CFL(i)*visc_rem(i,k)) / visc_rem_lim
- if (v(i,J,k) + dvL(i)*visc_rem_lim < dv_CFL(i)*visc_rem(i,k)) &
- dvL(i) = -(v(i,J,k) - dv_CFL(i)*visc_rem(i,k)) / visc_rem_lim
- endif
- endif ; enddo ; enddo
- do k=1,nz
- do i=ish,ieh ; if (do_I(i)) then
- v_L(i) = v(I,j,k) + dvL(i) * visc_rem(i,k)
- v_R(i) = v(I,j,k) + dvR(i) * visc_rem(i,k)
- v_0(i) = v(I,j,k) + dv0(i) * visc_rem(i,k)
- endif ; enddo
- call merid_flux_layer(v_0, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_0, dvhdv_0, &
- visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k))
- call merid_flux_layer(v_L, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_L, dvhdv_L, &
- visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k))
- call merid_flux_layer(v_R, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_R, dvhdv_R, &
- visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k))
- do i=ish,ieh ; if (do_I(i)) then
- FAmt_0(i) = FAmt_0(i) + dvhdv_0(i)
- FAmt_L(i) = FAmt_L(i) + dvhdv_L(i)
- FAmt_R(i) = FAmt_R(i) + dvhdv_R(i)
- vhtot_L(i) = vhtot_L(i) + vh_L(i)
- vhtot_R(i) = vhtot_R(i) + vh_R(i)
- endif ; enddo
+ do k=1,nz ; do concurrent (i=ish:ieh, do_I(i,j)) &
+ & DO_LOCALITY(local(v_0, v_L, v_R, dvhdv_0, dvhdv_L, dvhdv_R, vh_0, vh_L, vh_R))
+ v_L = v(I,J,k) + dvL(i) * visc_rem(i,J,k)
+ v_R = v(I,J,k) + dvR(i) * visc_rem(i,J,k)
+ v_0 = v(I,J,k) + dv0(i,J) * visc_rem(i,J,k)
+ call flux_elem(v_0, h_in(i,J,k), h_in(i,J+1,k), h_S(i,J,k), h_S(i,J+1,k), &
+ h_N(i,J,k), h_N(i,J+1,k), vh_0, dvhdv_0, visc_rem(i,J,k), &
+ G%dx_Cv(i,J), G%IareaT(i,J), G%IareaT(i,J+1), G%IdyT(i,J), &
+ G%IdyT(i,J+1), dt, G, GV, US, CS%vol_CFL, por_face_areaV(i,J,k))
+ call flux_elem(v_L, h_in(i,J,k), h_in(i,J+1,k), h_S(i,J,k), h_S(i,J+1,k), &
+ h_N(i,J,k), h_N(i,J+1,k), vh_L, dvhdv_L, visc_rem(i,J,k), &
+ G%dx_Cv(i,J), G%IareaT(i,J), G%IareaT(i,J+1), G%IdyT(i,J), &
+ G%IdyT(i,J+1), dt, G, GV, US, CS%vol_CFL, por_face_areaV(i,J,k))
+ call flux_elem(v_R, h_in(i,J,k), h_in(i,J+1,k), h_S(i,J,k), h_S(i,J+1,k), &
+ h_N(i,J,k), h_N(i,J+1,k), vh_R, dvhdv_R, visc_rem(i,J,k), &
+ G%dx_Cv(i,J), G%IareaT(i,J), G%IareaT(i,J+1), G%IdyT(i,J), &
+ G%IdyT(i,J+1), dt, G, GV, US, CS%vol_CFL, por_face_areaV(i,J,k))
+ FAmt_0(i) = FAmt_0(i) + dvhdv_0
+ FAmt_L(i) = FAmt_L(i) + dvhdv_L
+ FAmt_R(i) = FAmt_R(i) + dvhdv_R
+ vhtot_L(i) = vhtot_L(i) + vh_L
+ vhtot_R(i) = vhtot_R(i) + vh_R
+ enddo ; enddo
+
+ do concurrent (i=ish:ieh) DO_LOCALITY(local(FA_0, FA_Avg))
+ if (do_I(i,j)) then
+ FA_0 = FAmt_0(i) ; FA_avg = FAmt_0(i)
+ if ((dvL(i) - dv0(i,J)) /= 0.0) &
+ FA_avg = vhtot_L(i) / (dvL(i) - dv0(i,J))
+ if (FA_avg > max(FA_0, FAmt_L(i))) then ; FA_avg = max(FA_0, FAmt_L(i))
+ elseif (FA_avg < min(FA_0, FAmt_L(i))) then ; FA_0 = FA_avg ; endif
+ BT_cont%FA_v_S0(i,J) = FA_0 ; BT_cont%FA_v_SS(i,J) = FAmt_L(i)
+ if (abs(FA_0-FAmt_L(i)) <= 1e-12*FA_0) then ; BT_cont%vBT_SS(i,J) = 0.0 ; else
+ BT_cont%vBT_SS(i,J) = (1.5 * (dvL(i) - dv0(i,J))) * &
+ ((FAmt_L(i) - FA_avg) / (FAmt_L(i) - FA_0))
+ endif
+
+ FA_0 = FAmt_0(i) ; FA_avg = FAmt_0(i)
+ if ((dvR(i) - dv0(i,j)) /= 0.0) &
+ FA_avg = vhtot_R(i) / (dvR(i) - dv0(i,j))
+ if (FA_avg > max(FA_0, FAmt_R(i))) then ; FA_avg = max(FA_0, FAmt_R(i))
+ elseif (FA_avg < min(FA_0, FAmt_R(i))) then ; FA_0 = FA_avg ; endif
+ BT_cont%FA_v_N0(i,J) = FA_0 ; BT_cont%FA_v_NN(i,J) = FAmt_R(i)
+ if (abs(FAmt_R(i) - FA_0) <= 1e-12*FA_0) then ; BT_cont%vBT_NN(i,J) = 0.0 ; else
+ BT_cont%vBT_NN(i,J) = (1.5 * (dvR(i) - dv0(i,j))) * &
+ ((FAmt_R(i) - FA_avg) / (FAmt_R(i) - FA_0))
+ endif
+ else
+ BT_cont%FA_v_S0(i,J) = 0.0 ; BT_cont%FA_v_SS(i,J) = 0.0
+ BT_cont%FA_v_N0(i,J) = 0.0 ; BT_cont%FA_v_NN(i,J) = 0.0
+ BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0
+ endif
+ enddo
enddo
- do i=ish,ieh ; if (do_I(i)) then
- FA_0 = FAmt_0(i) ; FA_avg = FAmt_0(i)
- if ((dvL(i) - dv0(i)) /= 0.0) &
- FA_avg = vhtot_L(i) / (dvL(i) - dv0(i))
- if (FA_avg > max(FA_0, FAmt_L(i))) then ; FA_avg = max(FA_0, FAmt_L(i))
- elseif (FA_avg < min(FA_0, FAmt_L(i))) then ; FA_0 = FA_avg ; endif
- BT_cont%FA_v_S0(i,J) = FA_0 ; BT_cont%FA_v_SS(i,J) = FAmt_L(i)
- if (abs(FA_0-FAmt_L(i)) <= 1e-12*FA_0) then ; BT_cont%vBT_SS(i,J) = 0.0 ; else
- BT_cont%vBT_SS(i,J) = (1.5 * (dvL(i) - dv0(i))) * &
- ((FAmt_L(i) - FA_avg) / (FAmt_L(i) - FA_0))
- endif
- FA_0 = FAmt_0(i) ; FA_avg = FAmt_0(i)
- if ((dvR(i) - dv0(i)) /= 0.0) &
- FA_avg = vhtot_R(i) / (dvR(i) - dv0(i))
- if (FA_avg > max(FA_0, FAmt_R(i))) then ; FA_avg = max(FA_0, FAmt_R(i))
- elseif (FA_avg < min(FA_0, FAmt_R(i))) then ; FA_0 = FA_avg ; endif
- BT_cont%FA_v_N0(i,J) = FA_0 ; BT_cont%FA_v_NN(i,J) = FAmt_R(i)
- if (abs(FAmt_R(i) - FA_0) <= 1e-12*FA_0) then ; BT_cont%vBT_NN(i,J) = 0.0 ; else
- BT_cont%vBT_NN(i,J) = (1.5 * (dvR(i) - dv0(i))) * &
- ((FAmt_R(i) - FA_avg) / (FAmt_R(i) - FA_0))
- endif
- else
- BT_cont%FA_v_S0(i,J) = 0.0 ; BT_cont%FA_v_SS(i,J) = 0.0
- BT_cont%FA_v_N0(i,J) = 0.0 ; BT_cont%FA_v_NN(i,J) = 0.0
- BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0
- endif ; enddo
+ !$omp target exit data map(release: dvL, dvR, dv_CFL, FAmt_L, FAmt_R, FAmt_0, vhtot_L, vhtot_R)
end subroutine set_merid_BT_cont
!> Calculates left/right edge values for PPM reconstruction.
-subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_2nd, OBC)
+subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, GV, LB, h_min, monotonic, simple_2nd, OBC)
type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_W !< West edge thickness in the reconstruction,
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h_W !< West edge thickness in the reconstruction,
!! [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_E !< East edge thickness in the reconstruction,
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h_E !< East edge thickness in the reconstruction,
!! [H ~> m or kg m-2].
type(cont_loop_bounds_type), intent(in) :: LB !< Active loop bounds structure.
real, intent(in) :: h_min !< The minimum thickness
@@ -2324,15 +2620,16 @@ subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_
!! arithmetic mean thicknesses as the default edge values
!! for a simple 2nd order scheme.
type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure.
+ integer :: k !< vertical grid index
! Local variables with useful mnemonic names.
- real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes per grid point [H ~> m or kg m-2]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: slp ! The slopes per grid point [H ~> m or kg m-2]
real, parameter :: oneSixth = 1./6. ! [nondim]
real :: h_ip1, h_im1 ! Neighboring thicknesses or sensibly extrapolated values [H ~> m or kg m-2]
real :: dMx, dMn ! The difference between the local thickness and the maximum (dMx) or
! minimum (dMn) of the surrounding values [H ~> m or kg m-2]
character(len=256) :: mesg
- integer :: i, j, isl, iel, jsl, jel, n, stencil
+ integer :: i, j, isl, iel, jsl, jel, nz, n, stencil
logical :: local_open_BC
type(OBC_segment_type), pointer :: segment => NULL()
@@ -2341,114 +2638,121 @@ subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_
local_open_BC = OBC%open_u_BCs_exist_globally
endif
- isl = LB%ish-1 ; iel = LB%ieh+1 ; jsl = LB%jsh ; jel = LB%jeh
+ isl = LB%ish-1 ; iel = LB%ieh+1 ; jsl = LB%jsh ; jel = LB%jeh ; nz = GV%ke
! This is the stencil of the reconstruction, not the scheme overall.
stencil = 2 ; if (simple_2nd) stencil = 1
if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then
write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", &
- & "x-halo that needs to be increased by ",i2,".")') &
+ & "x-halo that needs to be increased by ",I0,".")') &
stencil + max(G%isd-isl,iel-G%ied)
call MOM_error(FATAL,mesg)
endif
if ((jsl < G%jsd) .or. (jel > G%jed)) then
write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", &
- & "y-halo that needs to be increased by ",i2,".")') &
+ & "y-halo that needs to be increased by ",I0,".")') &
max(G%jsd-jsl,jel-G%jed)
call MOM_error(FATAL,mesg)
endif
+ !$omp target enter data map(alloc: slp)
+
if (simple_2nd) then
- do j=jsl,jel ; do i=isl,iel
- h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j)
- h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j)
- h_W(i,j) = 0.5*( h_im1 + h_in(i,j) )
- h_E(i,j) = 0.5*( h_ip1 + h_in(i,j) )
- enddo ; enddo
+ ! untested
+ do concurrent (k =1:nz, j=jsl:jel, i=isl:iel)
+ h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j,k) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j,k)
+ h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j,k) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j,k)
+ h_W(i,j,k) = 0.5*( h_im1 + h_in(i,j,k) )
+ h_E(i,j,k) = 0.5*( h_ip1 + h_in(i,j,k) )
+ enddo
else
- do j=jsl,jel ; do i=isl-1,iel+1
+ do concurrent (k=1:nz, j=jsl:jel, i=isl-1:iel+1)
if ((G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) == 0.0) then
- slp(i,j) = 0.0
+ slp(i,j,k) = 0.0
else
! This uses a simple 2nd order slope.
- slp(i,j) = 0.5 * (h_in(i+1,j) - h_in(i-1,j))
+ slp(i,j,k) = 0.5 * (h_in(i+1,j,k) - h_in(i-1,j,k))
! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132)
- dMx = max(h_in(i+1,j), h_in(i-1,j), h_in(i,j)) - h_in(i,j)
- dMn = h_in(i,j) - min(h_in(i+1,j), h_in(i-1,j), h_in(i,j))
- slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn))
+ dMx = max(h_in(i+1,j,k), h_in(i-1,j,k), h_in(i,j,k)) - h_in(i,j,k)
+ dMn = h_in(i,j,k) - min(h_in(i+1,j,k), h_in(i-1,j,k), h_in(i,j,k))
+ slp(i,j,k) = sign(1.,slp(i,j,k)) * min(abs(slp(i,j,k)), 2. * min(dMx, dMn))
! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j))
endif
- enddo ; enddo
+ enddo
if (local_open_BC) then
+ ! untested
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
- slp(i,j) = 0.0
+ do concurrent (k=1:nz, j=segment%HI%jsd:segment%HI%jed)
+ slp(i+1,j,k) = 0.0
+ slp(i,j,k) = 0.0
enddo
endif
enddo
endif
- do j=jsl,jel ; do i=isl,iel
+ do concurrent (k=1:nz, j=jsl:jel, i=isl:iel)
! Neighboring values should take into account any boundaries. The 3
! following sets of expressions are equivalent.
! h_im1 = h_in(i-1,j,k) ; if (G%mask2dT(i-1,j) < 0.5) h_im1 = h_in(i,j)
! h_ip1 = h_in(i+1,j,k) ; if (G%mask2dT(i+1,j) < 0.5) h_ip1 = h_in(i,j)
- h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j)
- h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j)
+ h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j,k) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j,k)
+ h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j,k) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j,k)
! Left/right values following Eq. B2 in Lin 1994, MWR (132)
- h_W(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) )
- h_E(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) )
- enddo ; enddo
+ h_W(i,j,k) = 0.5*( h_im1 + h_in(i,j,k) ) + oneSixth*( slp(i-1,j,k) - slp(i,j,k) )
+ h_E(i,j,k) = 0.5*( h_ip1 + h_in(i,j,k) ) + oneSixth*( slp(i,j,k) - slp(i+1,j,k) )
+ enddo
endif
if (local_open_BC) then
+ ! untested
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 j=segment%HI%jsd,segment%HI%jed
- h_W(i+1,j) = h_in(i,j)
- h_E(i+1,j) = h_in(i,j)
- h_W(i,j) = h_in(i,j)
- h_E(i,j) = h_in(i,j)
+ do concurrent (k=1:nz, j=segment%HI%jsd:segment%HI%jed)
+ h_W(i+1,j,k) = h_in(i,j,k)
+ h_E(i+1,j,k) = h_in(i,j,k)
+ h_W(i,j,k) = h_in(i,j,k)
+ h_E(i,j,k) = h_in(i,j,k)
enddo
elseif (segment%direction == OBC_DIRECTION_W) then
I=segment%HI%IsdB
- do j=segment%HI%jsd,segment%HI%jed
- h_W(i,j) = h_in(i+1,j)
- h_E(i,j) = h_in(i+1,j)
- h_W(i+1,j) = h_in(i+1,j)
- h_E(i+1,j) = h_in(i+1,j)
+ do concurrent (k=1:nz, j=segment%HI%jsd:segment%HI%jed)
+ h_W(i,j,k) = h_in(i+1,j,k)
+ h_E(i,j,k) = h_in(i+1,j,k)
+ h_W(i+1,j,k) = h_in(i+1,j,k)
+ h_E(i+1,j,k) = h_in(i+1,j,k)
enddo
endif
enddo
endif
if (monotonic) then
- call PPM_limit_CW84(h_in, h_W, h_E, G, isl, iel, jsl, jel)
+ ! untested
+ call PPM_limit_CW84(h_in, h_W, h_E, G, GV, isl, iel, jsl, jel, nz)
else
- call PPM_limit_pos(h_in, h_W, h_E, h_min, G, isl, iel, jsl, jel)
+ call PPM_limit_pos(h_in, h_W, h_E, h_min, G, GV, isl, iel, jsl, jel, nz)
endif
- return
+ !$omp target exit data map(release: slp)
+
end subroutine PPM_reconstruction_x
!> Calculates left/right edge values for PPM reconstruction.
-subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_2nd, OBC)
+subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, GV, LB, h_min, monotonic, simple_2nd, OBC)
type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_S !< South edge thickness in the reconstruction,
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h_S !< South edge thickness in the reconstruction,
!! [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_N !< North edge thickness in the reconstruction,
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h_N !< North edge thickness in the reconstruction,
!! [H ~> m or kg m-2].
type(cont_loop_bounds_type), intent(in) :: LB !< Active loop bounds structure.
real, intent(in) :: h_min !< The minimum thickness
@@ -2460,15 +2764,16 @@ subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_
!! arithmetic mean thicknesses as the default edge values
!! for a simple 2nd order scheme.
type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure.
+ integer :: k !< vertical grid index
! Local variables with useful mnemonic names.
- real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes per grid point [H ~> m or kg m-2]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: slp ! The slopes per grid point [H ~> m or kg m-2]
real, parameter :: oneSixth = 1./6. ! [nondim]
real :: h_jp1, h_jm1 ! Neighboring thicknesses or sensibly extrapolated values [H ~> m or kg m-2]
real :: dMx, dMn ! The difference between the local thickness and the maximum (dMx) or
! minimum (dMn) of the surrounding values [H ~> m or kg m-2]
character(len=256) :: mesg
- integer :: i, j, isl, iel, jsl, jel, n, stencil
+ integer :: i, j, isl, iel, jsl, jel, nz, n, stencil
logical :: local_open_BC
type(OBC_segment_type), pointer :: segment => NULL()
@@ -2477,162 +2782,175 @@ subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_
local_open_BC = OBC%open_v_BCs_exist_globally
endif
- isl = LB%ish ; iel = LB%ieh ; jsl = LB%jsh-1 ; jel = LB%jeh+1
+ isl = LB%ish ; iel = LB%ieh ; jsl = LB%jsh-1 ; jel = LB%jeh+1 ; nz = G%ke
! This is the stencil of the reconstruction, not the scheme overall.
stencil = 2 ; if (simple_2nd) stencil = 1
if ((isl < G%isd) .or. (iel > G%ied)) then
write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", &
- & "x-halo that needs to be increased by ",i2,".")') &
+ & "x-halo that needs to be increased by ",I0,".")') &
max(G%isd-isl,iel-G%ied)
call MOM_error(FATAL,mesg)
endif
if ((jsl-stencil < G%jsd) .or. (jel+stencil > G%jed)) then
write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", &
- & "y-halo that needs to be increased by ",i2,".")') &
+ & "y-halo that needs to be increased by ",I0,".")') &
stencil + max(G%jsd-jsl,jel-G%jed)
call MOM_error(FATAL,mesg)
endif
+ !$omp target enter data map(alloc: slp)
+
if (simple_2nd) then
- do j=jsl,jel ; do i=isl,iel
- h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j)
- h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j)
- h_S(i,j) = 0.5*( h_jm1 + h_in(i,j) )
- h_N(i,j) = 0.5*( h_jp1 + h_in(i,j) )
- enddo ; enddo
+ ! untested
+ do concurrent (k=1:nz, j=jsl:jel, i=isl:iel)
+ h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1,k) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j,k)
+ h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1,k) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j,k)
+ h_S(i,j,k) = 0.5*( h_jm1 + h_in(i,j,k) )
+ h_N(i,j,k) = 0.5*( h_jp1 + h_in(i,j,k) )
+ enddo
else
- do j=jsl-1,jel+1 ; do i=isl,iel
+ do concurrent (k=1:nz, j=jsl-1:jel+1, i=isl:iel)
if ((G%mask2dT(i,j-1) * G%mask2dT(i,j) * G%mask2dT(i,j+1)) == 0.0) then
- slp(i,j) = 0.0
+ slp(i,j,k) = 0.0
else
! This uses a simple 2nd order slope.
- slp(i,j) = 0.5 * (h_in(i,j+1) - h_in(i,j-1))
+ slp(i,j,k) = 0.5 * (h_in(i,j+1,k) - h_in(i,j-1,k))
! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132)
- dMx = max(h_in(i,j+1), h_in(i,j-1), h_in(i,j)) - h_in(i,j)
- dMn = h_in(i,j) - min(h_in(i,j+1), h_in(i,j-1), h_in(i,j))
- slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn))
+ dMx = max(h_in(i,j+1,k), h_in(i,j-1,k), h_in(i,j,k)) - h_in(i,j,k)
+ dMn = h_in(i,j,k) - min(h_in(i,j+1,k), h_in(i,j-1,k), h_in(i,j,k))
+ slp(i,j,k) = sign(1.,slp(i,j,k)) * min(abs(slp(i,j,k)), 2. * min(dMx, dMn))
! * (G%mask2dT(i,j-1) * G%mask2dT(i,j) * G%mask2dT(i,j+1))
endif
- enddo ; enddo
+ enddo
if (local_open_BC) then
+ ! untested
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
- slp(i,j) = 0.0
+ do concurrent (k=1:nz, i=segment%HI%isd:segment%HI%ied)
+ slp(i,j+1,k) = 0.0
+ slp(i,j,k) = 0.0
enddo
endif
enddo
endif
- do j=jsl,jel ; do i=isl,iel
+ do concurrent (k=1:nz, j=jsl:jel, i=isl:iel)
! Neighboring values should take into account any boundaries. The 3
! following sets of expressions are equivalent.
- h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j)
- h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j)
+ h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1,k) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j,k)
+ h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1,k) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j,k)
! Left/right values following Eq. B2 in Lin 1994, MWR (132)
- h_S(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + oneSixth*( slp(i,j-1) - slp(i,j) )
- h_N(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i,j+1) )
- enddo ; enddo
+ h_S(i,j,k) = 0.5*( h_jm1 + h_in(i,j,k) ) + oneSixth*( slp(i,j-1,k) - slp(i,j,k) )
+ h_N(i,j,k) = 0.5*( h_jp1 + h_in(i,j,k) ) + oneSixth*( slp(i,j,k) - slp(i,j+1,k) )
+ enddo
endif
if (local_open_BC) then
+ ! untested
do n=1, OBC%number_of_segments
segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
if (segment%direction == OBC_DIRECTION_N) then
J=segment%HI%JsdB
- do i=segment%HI%isd,segment%HI%ied
- h_S(i,j+1) = h_in(i,j)
- h_N(i,j+1) = h_in(i,j)
- h_S(i,j) = h_in(i,j)
- h_N(i,j) = h_in(i,j)
+ do concurrent (k=1:nz, i=segment%HI%isd:segment%HI%ied)
+ h_S(i,j+1,k) = h_in(i,j,k)
+ h_N(i,j+1,k) = h_in(i,j,k)
+ h_S(i,j,k) = h_in(i,j,k)
+ h_N(i,j,k) = h_in(i,j,k)
enddo
elseif (segment%direction == OBC_DIRECTION_S) then
J=segment%HI%JsdB
- do i=segment%HI%isd,segment%HI%ied
- h_S(i,j) = h_in(i,j+1)
- h_N(i,j) = h_in(i,j+1)
- h_S(i,j+1) = h_in(i,j+1)
- h_N(i,j+1) = h_in(i,j+1)
+ do concurrent (k=1:nz, i=segment%HI%isd:segment%HI%ied)
+ h_S(i,j,k) = h_in(i,j+1,k)
+ h_N(i,j,k) = h_in(i,j+1,k)
+ h_S(i,j+1,k) = h_in(i,j+1,k)
+ h_N(i,j+1,k) = h_in(i,j+1,k)
enddo
endif
enddo
endif
if (monotonic) then
- call PPM_limit_CW84(h_in, h_S, h_N, G, isl, iel, jsl, jel)
+ ! untested
+ call PPM_limit_CW84(h_in, h_S, h_N, G, GV, isl, iel, jsl, jel, nz)
else
- call PPM_limit_pos(h_in, h_S, h_N, h_min, G, isl, iel, jsl, jel)
+ call PPM_limit_pos(h_in, h_S, h_N, h_min, G, GV, isl, iel, jsl, jel, nz)
endif
- return
+ !$omp target exit data map(release: slp)
+
end subroutine PPM_reconstruction_y
!> This subroutine limits the left/right edge values of the PPM reconstruction
!! to give a reconstruction that is positive-definite. Here this is
!! reinterpreted as giving a constant thickness if the mean thickness is less
!! than h_min, with a minimum of h_min otherwise.
-subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie)
- type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2].
- real, intent(in) :: h_min !< The minimum thickness
+subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, GV, iis, iie, jis, jie, nz)
+ type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(inout) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
+ intent(inout) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2].
+ real, intent(in) :: h_min !< The minimum thickness
!! that can be obtained by a concave parabolic fit [H ~> m or kg m-2]
- integer, intent(in) :: iis !< Start of i index range.
- integer, intent(in) :: iie !< End of i index range.
- integer, intent(in) :: jis !< Start of j index range.
- integer, intent(in) :: jie !< End of j index range.
+ integer, intent(in) :: iis !< Start of i index range.
+ integer, intent(in) :: iie !< End of i index range.
+ integer, intent(in) :: jis !< Start of j index range.
+ integer, intent(in) :: jie !< End of j index range.
+ integer, intent(in) :: nz !< End of k index range.
! Local variables
real :: curv ! The grid-normalized curvature of the three thicknesses [H ~> m or kg m-2]
real :: dh ! The difference between the edge thicknesses [H ~> m or kg m-2]
real :: scale ! A scaling factor to reduce the curvature of the fit [nondim]
- integer :: i,j
+ integer :: i,j,k
- do j=jis,jie ; do i=iis,iie
+ do concurrent (k=1:nz, j=jis:jie, i=iis:iie)
! This limiter prevents undershooting minima within the domain with
! values less than h_min.
- curv = 3.0*((h_L(i,j) + h_R(i,j)) - 2.0*h_in(i,j))
+ curv = 3.0*((h_L(i,j,k) + h_R(i,j,k)) - 2.0*h_in(i,j,k))
if (curv > 0.0) then ! Only minima are limited.
- dh = h_R(i,j) - h_L(i,j)
+ dh = h_R(i,j,k) - h_L(i,j,k)
if (abs(dh) < curv) then ! The parabola's minimum is within the cell.
- if (h_in(i,j) <= h_min) then
- h_L(i,j) = h_in(i,j) ; h_R(i,j) = h_in(i,j)
- elseif (12.0*curv*(h_in(i,j) - h_min) < (curv**2 + 3.0*dh**2)) then
+ if (h_in(i,j,k) <= h_min) then
+ h_L(i,j,k) = h_in(i,j,k) ; h_R(i,j,k) = h_in(i,j,k)
+ elseif (12.0*curv*(h_in(i,j,k) - h_min) < (curv**2 + 3.0*dh**2)) then
! The minimum value is h_in - (curv^2 + 3*dh^2)/(12*curv), and must
! be limited in this case. 0 < scale < 1.
- scale = 12.0*curv*(h_in(i,j) - h_min) / (curv**2 + 3.0*dh**2)
- h_L(i,j) = h_in(i,j) + scale*(h_L(i,j) - h_in(i,j))
- h_R(i,j) = h_in(i,j) + scale*(h_R(i,j) - h_in(i,j))
+ scale = 12.0*curv*(h_in(i,j,k) - h_min) / (curv**2 + 3.0*dh**2)
+ h_L(i,j,k) = h_in(i,j,k) + scale*(h_L(i,j,k) - h_in(i,j,k))
+ h_R(i,j,k) = h_in(i,j,k) + scale*(h_R(i,j,k) - h_in(i,j,k))
endif
endif
endif
- enddo ; enddo
+ enddo
end subroutine PPM_limit_pos
!> This subroutine limits the left/right edge values of the PPM reconstruction
!! according to the monotonic prescription of Colella and Woodward, 1984.
-subroutine PPM_limit_CW84(h_in, h_L, h_R, G, iis, iie, jis, jie)
+subroutine PPM_limit_CW84(h_in, h_L, h_R, G, GV, iis, iie, jis, jie, nz)
type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure.
- real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the reconstruction,
+ type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure.
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2].
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_L !< Left thickness in the reconstruction,
!! [H ~> m or kg m-2].
- real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the reconstruction,
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_R !< Right thickness in the reconstruction,
!! [H ~> m or kg m-2].
integer, intent(in) :: iis !< Start of i index range.
integer, intent(in) :: iie !< End of i index range.
integer, intent(in) :: jis !< Start of j index range.
integer, intent(in) :: jie !< End of j index range.
+ integer, intent(in) :: nz !< End of k index range.
! Local variables
real :: h_i ! A copy of the cell-average layer thickness [H ~> m or kg m-2]
@@ -2640,29 +2958,29 @@ subroutine PPM_limit_CW84(h_in, h_L, h_R, G, iis, iie, jis, jie)
real :: RLdiff2 ! The squared difference between the input edge values [H2 ~> m2 or kg2 m-4]
real :: RLmean ! The average of the input edge thicknesses [H ~> m or kg m-2]
real :: FunFac ! A curious product of the thickness slope and curvature [H2 ~> m2 or kg2 m-4]
- integer :: i, j
+ integer :: i, j, k
- do j=jis,jie ; do i=iis,iie
+ ! untested
+ do concurrent (k=1:nz, j=jis:jie, i=iis:iie)
! This limiter monotonizes the parabola following
! Colella and Woodward, 1984, Eq. 1.10
- h_i = h_in(i,j)
- if ( ( h_R(i,j) - h_i ) * ( h_i - h_L(i,j) ) <= 0. ) then
- h_L(i,j) = h_i ; h_R(i,j) = h_i
+ h_i = h_in(i,j,k)
+ if ( ( h_R(i,j,k) - h_i ) * ( h_i - h_L(i,j,k) ) <= 0. ) then
+ h_L(i,j,k) = h_i ; h_R(i,j,k) = h_i
else
- RLdiff = h_R(i,j) - h_L(i,j) ! Difference of edge values
- RLmean = 0.5 * ( h_R(i,j) + h_L(i,j) ) ! Mean of edge values
+ RLdiff = h_R(i,j,k) - h_L(i,j,k) ! Difference of edge values
+ RLmean = 0.5 * ( h_R(i,j,k) + h_L(i,j,k) ) ! Mean of edge values
FunFac = 6. * RLdiff * ( h_i - RLmean ) ! Some funny factor
RLdiff2 = RLdiff * RLdiff ! Square of difference
- if ( FunFac > RLdiff2 ) h_L(i,j) = 3. * h_i - 2. * h_R(i,j)
- if ( FunFac < -RLdiff2 ) h_R(i,j) = 3. * h_i - 2. * h_L(i,j)
+ if ( FunFac > RLdiff2 ) h_L(i,j,k) = 3. * h_i - 2. * h_R(i,j,k)
+ if ( FunFac < -RLdiff2 ) h_R(i,j,k) = 3. * h_i - 2. * h_L(i,j,k)
endif
- enddo ; enddo
+ enddo
- return
end subroutine PPM_limit_CW84
!> Return the maximum ratio of a/b or maxrat.
-function ratio_max(a, b, maxrat) result(ratio)
+pure function ratio_max(a, b, maxrat) result(ratio)
real, intent(in) :: a !< Numerator, in arbitrary units [A]
real, intent(in) :: b !< Denominator, in arbitrary units [B]
real, intent(in) :: maxrat !< Maximum value of ratio [A B-1]
@@ -2676,23 +2994,33 @@ function ratio_max(a, b, maxrat) result(ratio)
end function ratio_max
!> Initializes continuity_ppm_cs
-subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS)
+subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS, OBC)
type(time_type), target, intent(in) :: Time !< The current model time.
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure.
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(param_file_type), intent(in) :: param_file !< A structure indicating
!! the open file to parse for model parameter values.
type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to
!! regulate diagnostic output.
type(continuity_PPM_CS), intent(inout) :: CS !< Module's control structure.
+ type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure.
+ logical :: local_open_BC, use_h_marg_min
+ type(OBC_segment_type), pointer :: segment => NULL()
+ integer :: n
!> This include declares and sets the variable "version".
# include "version_variable.h"
character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name.
+ character(len=256) :: mesg
CS%initialized = .true.
+ local_open_BC = .false.
+ if (associated(OBC)) then
+ local_open_BC = OBC%open_u_BCs_exist_globally
+ endif
+
! Read all relevant parameters and write them to the model log.
call log_version(param_file, mdl, version, "")
call get_param(param_file, mdl, "MONOTONIC_CONTINUITY", CS%monotonic, &
@@ -2750,12 +3078,36 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS)
"If true, use the marginal face areas from the continuity "//&
"solver for use as the weights in the barotropic solver. "//&
"Otherwise use the transport averaged areas.", default=.true.)
+ call get_param(param_file, mdl, "CONT_USE_H_MARG_MIN", use_h_marg_min, &
+ "If true, the marginal thickness used and returned from continuity "//&
+ "is bounded from below by a sub-roundoff value. Otherwise the "//&
+ "minimum is 0.", default=.false.)
CS%diag => diag
+ !$omp target update to(CS)
id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE)
id_clock_update = cpu_clock_id('(Ocean continuity update)', grain=CLOCK_ROUTINE)
id_clock_correct = cpu_clock_id('(Ocean continuity correction)', grain=CLOCK_ROUTINE)
+ if (use_h_marg_min) then
+ CS%h_marg_min = GV%H_subroundoff
+ else
+ CS%h_marg_min = 0.
+ endif
+
+ if (local_open_BC) then
+ do n=1, OBC%number_of_segments
+ segment => OBC%segment(n)
+ if (associated(segment%h_Reg)) then
+ if (.not. allocated(segment%h_Reg%h_res)) then
+ write(mesg,'("In MOM_continuity_PPM, continuity_PPM_init called with ", &
+ & "badly configured h_res.")')
+ call MOM_error(FATAL, mesg)
+ endif
+ endif
+ enddo
+ endif
+
end subroutine continuity_PPM_init
!> continuity_PPM_stencil returns the continuity solver stencil size
diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90
index 2638718594..bb398d9f00 100644
--- a/src/core/MOM_density_integrals.F90
+++ b/src/core/MOM_density_integrals.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides integrals of density
module MOM_density_integrals
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS, only : EOS_type
use MOM_EOS, only : EOS_quadrature, EOS_domain
use MOM_EOS, only : analytic_int_density_dz
@@ -678,8 +680,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom
Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom
else
- Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k)
- Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k)
+ Ttl = T_t(i,j,k) ; Tbl = T_b(i,j,k) ; Ttr = T_t(i+1,j,k) ; Tbr = T_b(i+1,j,k)
+ Stl = S_t(i,j,k) ; Sbl = S_b(i,j,k) ; Str = S_t(i+1,j,k) ; Sbr = S_b(i+1,j,k)
endif
do m=2,4
@@ -790,8 +792,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, &
Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom
Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom
else
- Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k)
- Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k)
+ Ttl = T_t(i,j,k) ; Tbl = T_b(i,j,k) ; Ttr = T_t(i,j+1,k) ; Tbr = T_b(i,j+1,k)
+ Stl = S_t(i,j,k) ; Sbl = S_b(i,j,k) ; Str = S_t(i,j+1,k) ; Sbr = S_b(i,j+1,k)
endif
do m=2,4
@@ -1122,10 +1124,10 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom
Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom
else
- Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k)
- Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k)
- Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k)
- Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k)
+ Ttl = T_t(i,j,k) ; Tbl = T_b(i,j,k) ; Ttr = T_t(i+1,j,k) ; Tbr = T_b(i+1,j,k)
+ Tml = tv%T(i,j,k) ; Tmr = tv%T(i+1,j,k)
+ Stl = S_t(i,j,k) ; Sbl = S_b(i,j,k) ; Str = S_t(i+1,j,k) ; Sbr = S_b(i+1,j,k)
+ Sml = tv%S(i,j,k) ; Smr = tv%S(i+1,j,k)
endif
do m=2,4
@@ -1234,10 +1236,10 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, &
Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom
Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom
else
- Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k)
- Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k)
- Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k)
- Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k)
+ Ttl = T_t(i,j,k) ; Tbl = T_b(i,j,k) ; Ttr = T_t(i,j+1,k) ; Tbr = T_b(i,j+1,k)
+ Tml = tv%T(i,j,k) ; Tmr = tv%T(i,j+1,k)
+ Stl = S_t(i,j,k) ; Sbl = S_b(i,j,k) ; Str = S_t(i,j+1,k) ; Sbr = S_b(i,j+1,k)
+ Sml = tv%S(i,j,k) ; Smr = tv%S(i,j+1,k)
endif
do m=2,4
@@ -1474,8 +1476,8 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d
Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB
halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0)
ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo
- if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif
- if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif
+ if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif
+ if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif
do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false.
if (present(MassWghtInterp)) then
diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90
index 40d1888595..51ef44a30c 100644
--- a/src/core/MOM_dynamics_split_RK2.F90
+++ b/src/core/MOM_dynamics_split_RK2.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Time step the adiabatic dynamic core of MOM using RK2 method.
module MOM_dynamics_split_RK2
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type
use MOM_variables, only : BT_cont_type, alloc_bt_cont_type, dealloc_bt_cont_type
use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs
@@ -34,7 +36,7 @@ module MOM_dynamics_split_RK2
use MOM_restart, only : query_initialized, set_initialized, save_restart
use MOM_restart, only : only_read_from_restarts
use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS
-use MOM_time_manager, only : time_type, time_type_to_real, operator(+)
+use MOM_time_manager, only : time_type, operator(+)
use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/)
use MOM_ALE, only : ALE_CS, ALE_remap_velocities
@@ -45,12 +47,12 @@ module MOM_dynamics_split_RK2
use MOM_continuity, only : continuity, continuity_CS
use MOM_continuity, only : continuity_init, continuity_stencil
use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS
-use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end
+use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil
use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS
use MOM_debugging, only : check_redundant
use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS
use MOM_grid, only : ocean_grid_type
-use MOM_harmonic_analysis, only : harmonic_analysis_CS
+use MOM_harmonic_analysis, only : HA_init, harmonic_analysis_CS
use MOM_hor_index, only : hor_index_type
use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS, hor_visc_vel_stencil
use MOM_hor_visc, only : hor_visc_init, hor_visc_end
@@ -60,6 +62,8 @@ module MOM_dynamics_split_RK2
use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds
use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query
use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp
+use MOM_open_boundary, only : copy_thickness_reservoirs
+use MOM_open_boundary, only : update_segment_thickness_reservoirs
use MOM_PressureForce, only : PressureForce, PressureForce_CS
use MOM_PressureForce, only : PressureForce_init
use MOM_set_visc, only : set_viscous_ML, set_visc_CS
@@ -157,6 +161,9 @@ module MOM_dynamics_split_RK2
logical :: BT_use_layer_fluxes !< If true, use the summed layered fluxes plus
!! an adjustment due to a changed barotropic
!! velocity in the barotropic continuity equation.
+ logical :: BT_adj_corr_mass_src !< If true, recalculates the barotropic mass source after
+ !! predictor step. This should make little difference in the
+ !! deep ocean but appears to help for vanished layers.
logical :: split_bottom_stress !< If true, provide the bottom stress
!! calculated by the vertical viscosity to the
!! barotropic solver.
@@ -169,6 +176,7 @@ module MOM_dynamics_split_RK2
!! of restart files.
logical :: calculate_SAL !< If true, calculate self-attraction and loading.
logical :: use_tides !< If true, tidal forcing is enabled.
+ logical :: use_HA !< If true, perform inline harmonic analysis.
logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D
!! variables that are needed to reproduce across restarts,
!! similarly to what is done with the primary state variables.
@@ -181,7 +189,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
@@ -409,6 +418,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
! in the corrector step (not the predict)
integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
integer :: cont_stencil, obc_stencil, vel_stencil
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! temporary copy of Layer thickness [H ~> m or kg m-2]
+ integer :: cor_stencil
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
@@ -421,12 +432,19 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
showCallTree = callTree_showQuery()
if (showCallTree) call callTree_enter("step_MOM_dyn_split_RK2(), MOM_dynamics_split_RK2.F90")
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=G%jsd,G%jed ; do i=G%isdB,G%iedB ; up(i,j,k) = 0.0 ; enddo ; enddo
- do j=G%jsdB,G%jedB ; do i=G%isd,G%ied ; vp(i,j,k) = 0.0 ; enddo ; enddo
- do j=G%jsd,G%jed ; do i=G%isd,G%ied ; hp(i,j,k) = h(i,j,k) ; enddo ; enddo
+ !$omp target enter data map(alloc: u_bc_accel, v_bc_accel, eta_pred, uh_in, vh_in)
+ !$omp target enter data map(alloc: up, vp, hp, dz, h_tmp)
+
+ do concurrent (k=1:nz, j=G%jsd:G%jed, I=G%IsdB:G%IedB)
+ up(I,j,k) = 0.0
+ enddo
+ do concurrent (k=1:nz, J=G%JsdB:G%JedB, i=G%isd:G%ied)
+ vp(i,J,k) = 0.0
enddo
+ do concurrent (k=1:nz, j=G%jsd:G%jed, i=G%isd:G%ied)
+ hp(i,j,k) = h(i,j,k)
+ enddo
+ ! TODO: hp needs accurate +/-2 halos.
! Update CFL truncation value as function of time
call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US)
@@ -448,6 +466,10 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
else
p_surf => forces%p_surf
endif
+ ! TODO: This should probably be resolved in step_MOM, if not higher. But
+ ! p_surf setup is a bit complicated, and may even depend on the driver, so
+ ! for now we alloc/delete in the dynamic core step.
+ !$omp target enter data map(to: p_surf) if (associated(p_surf))
if (associated(CS%OBC)) then
if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h)
@@ -475,6 +497,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
cont_stencil = continuity_stencil(CS%continuity_CSp)
obc_stencil = 2
+ cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv)
if (associated(CS%OBC)) then
if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3
endif
@@ -484,14 +507,15 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, &
To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil))
call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil))
- call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2)
- call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=vel_stencil)
- call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=vel_stencil)
-
call create_group_pass(CS%pass_uv, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil))
- call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil))
- call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=vel_stencil)
- call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=vel_stencil)
+
+ call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=cor_stencil)
+ call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,vel_stencil))
+ call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,vel_stencil))
+ call create_group_pass(CS%pass_h, h, g%domain, halo=max(cor_stencil,cont_stencil))
+ call create_group_pass(CS%pass_av_uvh, u_av, v_av, g%domain, halo=max(cor_stencil,vel_stencil))
+ call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,vel_stencil))
+
call cpu_clock_end(id_clock_pass)
!--- end set up for group halo pass
@@ -499,9 +523,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
! pbce = dM/deta
if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag)
call cpu_clock_begin(id_clock_pres)
+
call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, &
CS%ALE_CSp, CS%ADp, p_surf, CS%pbce, CS%eta_PF)
+
if (dyn_p_surf) then
+ !$omp target update from(CS%eta_PF)
pres_to_eta = 1.0 / (GV%g_Earth * GV%H_to_RZ)
!$OMP parallel do default(shared)
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
@@ -514,6 +541,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
Use_Stokes_PGF = associated(Waves)
if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF
if (Use_Stokes_PGF) then
+ !$omp target update from(h, u_inst, v_inst, CS%PFu, CS%PFv)
call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1)
call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves)
@@ -541,17 +569,23 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then
call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local)
endif ; endif
- if (associated(CS%OBC) .and. CS%debug_OBC) &
+
+ if (associated(CS%OBC) .and. CS%debug_OBC) then
+ !$omp target update from (CS%PFu, CS%PFv)
call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv)
+ endif
- if (G%nonblocking_updates) &
+ if (G%nonblocking_updates) then
+ !$omp target update from(eta)
call start_group_pass(CS%pass_eta, G%Domain, clock=id_clock_pass)
+ endif
! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av
if (.not.CS%CAu_pred_stored) then
! Calculate a predictor-step estimate of the Coriolis and momentum advection terms,
! if it was not already stored from the end of the previous time step.
call cpu_clock_begin(id_clock_Cor)
+ !$omp target update to(u_av, v_av, h_av, uh, vh)
call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, &
G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves)
call cpu_clock_end(id_clock_Cor)
@@ -560,21 +594,26 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
! u_bc_accel = CAu + PFu + diffu(u[n-1])
call cpu_clock_begin(id_clock_btforce)
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js,je ; do I=Isq,Ieq
- u_bc_accel(I,j,k) = (CS%CAu_pred(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k)
- enddo ; enddo
- do J=Jsq,Jeq ; do i=is,ie
- v_bc_accel(i,J,k) = (CS%CAv_pred(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k)
- enddo ; enddo
+
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
+ u_bc_accel(I,j,k) = (CS%CAu_pred(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k)
+ enddo
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie)
+ v_bc_accel(i,J,k) = (CS%CAv_pred(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k)
enddo
+
if (associated(CS%OBC)) then
+ !$omp target update from(u_bc_accel, v_bc_accel)
call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel)
+ !$omp target update to(u_bc_accel, v_bc_accel)
endif
call cpu_clock_end(id_clock_btforce)
if (CS%debug) then
+ !$omp target update from(CS%CAu_pred, CS%CAv_pred)
+ !$omp target update from(CS%PFu, CS%PFv, CS%pbce)
+ !$omp target update from(CS%diffu, CS%diffv)
+ !$omp target update from(u_bc_accel, v_bc_accel)
call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, &
CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, &
symmetric=sym)
@@ -587,44 +626,50 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
endif
call cpu_clock_begin(id_clock_vertvisc)
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js,je ; do I=Isq,Ieq
- up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * u_bc_accel(I,j,k))
- enddo ; enddo
- do J=Jsq,Jeq ; do i=is,ie
- vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * v_bc_accel(i,J,k))
- enddo ; enddo
+
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
+ up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * u_bc_accel(I,j,k))
+ enddo
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie)
+ vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * v_bc_accel(i,J,k))
enddo
call enable_averages(dt, Time_local, CS%diag)
+ ! NOTE: this is on CPU and conditionally called (using `if (..) return`)
+ ! It contains GPU/CPU data transfers for [uv]_inst and visc fields.
call set_viscous_ML(u_inst, v_inst, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp)
call disable_averaging(CS%diag)
if (CS%debug) then
+ !$omp target update from(up, vp)
call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s)
endif
- call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1)
+
+ call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1, do_offload=.true.)
+
call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix)
call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp)
+
call cpu_clock_end(id_clock_vertvisc)
if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)")
-
call cpu_clock_begin(id_clock_pass)
if (G%nonblocking_updates) then
call complete_group_pass(CS%pass_eta, G%Domain)
+ !$omp target update to(eta)
+ !$omp target update from(CS%visc_rem_u, CS%visc_rem_v)
call start_group_pass(CS%pass_visc_rem, G%Domain)
else
- call do_group_pass(CS%pass_eta, G%Domain)
- call do_group_pass(CS%pass_visc_rem, G%Domain)
+ call do_group_pass(CS%pass_eta, G%Domain, omp_offload=.true.)
+ call do_group_pass(CS%pass_visc_rem, G%Domain, omp_offload=.true.)
endif
call cpu_clock_end(id_clock_pass)
call cpu_clock_begin(id_clock_btcalc)
! Calculate the relative layer weights for determining barotropic quantities.
- if (.not.BT_cont_BT_thick) &
+ if (.not.BT_cont_BT_thick) then
call btcalc(h, G, GV, CS%barotropic_CSp, OBC=CS%OBC)
+ endif
call bt_mass_source(h, eta, .true., G, GV, CS%barotropic_CSp)
SpV_avg(:,:) = 0.0
@@ -636,24 +681,32 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
endif
call cpu_clock_end(id_clock_btcalc)
- if (G%nonblocking_updates) &
+ if (G%nonblocking_updates) then
call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass)
+ !$omp target update to(CS%visc_rem_u, CS%visc_rem_v)
+ endif
+
+ if (associated(CS%OBC)) &
+ call copy_thickness_reservoirs(CS%OBC, G, GV)
! u_accel_bt = layer accelerations due to barotropic solver
if (associated(CS%BT_cont) .or. CS%BT_use_layer_fluxes) then
call cpu_clock_begin(id_clock_continuity)
call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, &
visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, BT_cont=CS%BT_cont)
+
call cpu_clock_end(id_clock_continuity)
if (BT_cont_BT_thick) then
+
call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, &
OBC=CS%OBC)
+
endif
if (showCallTree) call callTree_wayPoint("done with continuity[BT_cont] (step_MOM_dyn_split_RK2)")
endif
if (CS%BT_use_layer_fluxes) then
- uh_ptr => uh_in ; vh_ptr => vh_in; u_ptr => u_inst ; v_ptr => v_inst
+ uh_ptr => uh_in ; vh_ptr => vh_in ; u_ptr => u_inst ; v_ptr => v_inst
endif
call cpu_clock_begin(id_clock_btstep)
@@ -666,6 +719,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, eta=eta)
endif
endif
+
if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90")
! This is the predictor step call to btstep.
! The CS%ADp argument here stores the weights for certain integrated diagnostics.
@@ -673,6 +727,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, &
CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, &
eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr)
+
if (showCallTree) call callTree_leave("btstep()")
call cpu_clock_end(id_clock_btstep)
@@ -680,27 +735,34 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
dt_pred = dt * CS%be
call cpu_clock_begin(id_clock_mom_update)
- !$OMP parallel do default(shared)
- do k=1,nz
- do J=Jsq,Jeq ; do i=is,ie
- vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt_pred * &
- (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k)))
- enddo ; enddo
- do j=js,je ; do I=Isq,Ieq
- up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt_pred * &
- (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k)))
- enddo ; enddo
+ do concurrent (k=1:nz, J=Jsq:Jeq,i=is:ie)
+ vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt_pred * &
+ (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k)))
+ enddo
+
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
+ up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt_pred * &
+ (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k)))
enddo
+
call cpu_clock_end(id_clock_mom_update)
if (CS%debug) then
+ !$omp target update from(CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv)
+ !$omp target update from(CS%diffu, CS%diffv, CS%pbce)
+ !$omp target update from(CS%u_accel_bt, CS%v_accel_bt)
+ call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, &
+ CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym)
+
+ !$omp target update from(up, vp, h, uh, vh)
call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s)
call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS)
call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, &
symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T)
-! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1)
- call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, &
- CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym)
+
+ ! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1)
+
+ !$omp target update from(u_inst, v_inst)
call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, &
symmetric=sym)
if (debug_redundant) then
@@ -717,6 +779,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
endif
if (CS%fpmix) then
+ !$omp target update from(up, vp)
uold(:,:,:) = 0.0
vold(:,:,:) = 0.0
do k = 1, nz
@@ -733,7 +796,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
enddo
endif
- call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1)
+ call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1, do_offload=.true.)
+
call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, &
CS%OBC, VarMix)
@@ -745,33 +809,42 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
! lFPpost must be false in the predictor step to avoid averaging into the diagnostics
lFPpost = .false.
+ !$omp target update from(up, vp, h)
call vertFPmix(up, vp, uold, vold, hbl, h, forces, dt_pred, lFPpost, CS%Cemp_NL, &
G, GV, US, CS%vertvisc_CSp, CS%OBC, waves=waves)
+ !$omp target update to (up, vp)
+
call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, &
GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, fpmix=CS%fpmix, waves=waves)
else
call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, &
GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves)
+
endif
if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)")
if (G%nonblocking_updates) then
call cpu_clock_end(id_clock_vertvisc)
+ !$omp target update from(up, vp)
call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass)
call cpu_clock_begin(id_clock_vertvisc)
endif
+
if (CS%visc_rem_dt_bug) then
call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp)
else
call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp)
endif
+
call cpu_clock_end(id_clock_vertvisc)
- call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass)
+ call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass, omp_offload=.true.)
+
if (G%nonblocking_updates) then
call complete_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass)
+ !$omp target update to(up, vp)
else
- call do_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass)
+ call do_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass, omp_offload=.true.)
endif
! uh = u_av * h
@@ -781,11 +854,13 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, &
u_cor=u_av, v_cor=v_av, BT_cont=CS%BT_cont)
call cpu_clock_end(id_clock_continuity)
+
if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)")
- call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass)
+ call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass, omp_offload=.true.)
if (associated(CS%OBC)) then
+ !$omp target update from(u_av, v_av)
if (CS%debug) &
call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s)
@@ -795,19 +870,17 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
if (CS%debug) &
call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s)
+ !$omp target update to(u_av, v_av)
+
! These should be done with a pass that excludes uh & vh.
! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass)
- endif
-
- if (G%nonblocking_updates) then
- call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass)
+ call pass_vector(u_av, v_av, G%Domain, halo=max(cor_stencil,vel_stencil), clock=id_clock_pass)
endif
! h_av = (h + hp)/2
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
+ do concurrent (k=1:nz, j=js-cor_stencil:je+cor_stencil, i=is-cor_stencil:ie+cor_stencil)
h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k))
- enddo ; enddo ; enddo
+ enddo
! The correction phase of the time step starts here.
call enable_averages(dt, Time_local, CS%diag)
@@ -816,18 +889,19 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
! used in the next call to btstep. This call is at this point so that
! hp can be changed if CS%begw /= 0.
! eta_cor = ... (hidden inside CS%barotropic_CSp)
- call cpu_clock_begin(id_clock_btcalc)
- call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp)
- call cpu_clock_end(id_clock_btcalc)
+ if (CS%BT_adj_corr_mass_src) then
+ call cpu_clock_begin(id_clock_btcalc)
+ call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp)
+ call cpu_clock_end(id_clock_btcalc)
+ endif
if (CS%begw /= 0.0) then
! hp <- (1-begw)*h_in + begw*hp
! Back up hp to the value it would have had after a time-step of
! begw*dt. hp is not used again until recalculated by continuity.
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1
+ do concurrent (k=1:nz, j=js-2:je+2, i=is-2:ie+2)
hp(i,j,k) = (1.0-CS%begw)*h(i,j,k) + CS%begw*hp(i,j,k)
- enddo ; enddo ; enddo
+ enddo
! PFu = d/dx M(hp,T,S)
! pbce = dM/deta
@@ -840,6 +914,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
Use_Stokes_PGF = associated(Waves)
if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF
if (Use_Stokes_PGF) then
+ !$omp target update from(CS%PFu, CS%PFv, h)
call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1)
call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves)
if (.not.Waves%Passive_Stokes_PGF) then
@@ -860,8 +935,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2)")
endif
- if (G%nonblocking_updates) &
- call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass)
+ ! TODO: Move p_surf handling outside of this function
+ !$omp target exit data map(delete: p_surf) if (associated(p_surf))
if (BT_cont_BT_thick) then
call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, &
@@ -870,7 +945,9 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
endif
if (CS%debug) then
+ !$omp target update from(up, vp, hp, uh, vh)
call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym)
+ !$omp target update from(u_av, v_av, h_av)
call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s)
call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS)
! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US)
@@ -886,6 +963,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, &
OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, &
ADp=CS%ADp, hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v, STOCH=STOCH)
+
call cpu_clock_end(id_clock_horvisc)
if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)")
@@ -894,27 +972,34 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, &
G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves)
call cpu_clock_end(id_clock_Cor)
+
if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)")
! Calculate the momentum forcing terms for the barotropic equations.
! u_bc_accel = CAu + PFu + diffu(u[n-1])
call cpu_clock_begin(id_clock_btforce)
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js,je ; do I=Isq,Ieq
- u_bc_accel(I,j,k) = (CS%Cau(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k)
- enddo ; enddo
- do J=Jsq,Jeq ; do i=is,ie
- v_bc_accel(i,J,k) = (CS%Cav(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k)
- enddo ; enddo
+
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
+ u_bc_accel(I,j,k) = (CS%Cau(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k)
+ enddo
+
+ do concurrent (k=1:nz, J=Jsq:Jeq,i=is:ie)
+ v_bc_accel(i,J,k) = (CS%Cav(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k)
enddo
+
if (associated(CS%OBC)) then
+ !$omp target update from(u_bc_accel, v_bc_accel)
call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel)
+ !$omp target update to(u_bc_accel, v_bc_accel)
endif
call cpu_clock_end(id_clock_btforce)
if (CS%debug) then
+ !$omp target update from(CS%CAu, CS%CAv)
+ !$omp target update from(CS%PFu, CS%PFv, CS%pbce)
+ !$omp target update from(CS%diffu, CS%diffv)
+ !$omp target update from(u_bc_accel, v_bc_accel)
call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, &
CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, &
symmetric=sym)
@@ -939,42 +1024,52 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, &
CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, &
eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av)
+
if (CS%id_deta_dt>0) then
+ !$omp target update from(eta, eta_pred)
do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo
endif
- do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo
+
+ do concurrent (j=js:je, i=is:ie)
+ eta(i,j) = eta_pred(i,j)
+ enddo
call cpu_clock_end(id_clock_btstep)
if (showCallTree) call callTree_leave("btstep()")
if (CS%debug .and. debug_redundant) then
+ !$omp target update from(CS%u_accel_bt, CS%v_accel_bt)
call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2)
endif
! u = u + dt*( u_bc_accel + u_accel_bt )
call cpu_clock_begin(id_clock_mom_update)
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js,je ; do I=Isq,Ieq
- u_inst(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * &
- (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k)))
- enddo ; enddo
- do J=Jsq,Jeq ; do i=is,ie
- v_inst(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * &
- (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k)))
- enddo ; enddo
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq)
+ u_inst(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * &
+ (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k)))
+ enddo
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie)
+ v_inst(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * &
+ (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k)))
enddo
call cpu_clock_end(id_clock_mom_update)
if (CS%debug) then
+ !$omp target update from(CS%CAu, CS%CAv)
+ !$omp target update from(CS%PFu, CS%PFv, CS%pbce)
+ !$omp target update from(CS%diffu, CS%diffv)
+ !$omp target update from(CS%u_accel_bt, CS%v_accel_bt)
+ call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, &
+ CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, &
+ symmetric=sym)
+
+ !$omp target update from(u_inst, v_inst, h, uh, vh)
call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s)
call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS)
call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, &
symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T)
- ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1)
- call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, &
- CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, &
- symmetric=sym)
+
+ ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1)
endif
! u <- u + dt d/dz visc d/dz u
@@ -982,6 +1077,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
call cpu_clock_begin(id_clock_vertvisc)
if (CS%fpmix) then
+ !$omp target update from(u_inst, v_inst)
uold(:,:,:) = 0.0
vold(:,:,:) = 0.0
do k = 1, nz
@@ -998,88 +1094,109 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
enddo
endif
- call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1)
+ call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1, do_offload=.true.)
+
call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix)
if (CS%fpmix) then
lFPpost = .true.
+ !$omp target update from(u_inst, v_inst, h)
call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, lFPpost, CS%Cemp_NL, &
G, GV, US, CS%vertvisc_CSp, CS%OBC, Waves=Waves)
+ !$omp target update to(u_inst, v_inst)
+
call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, &
CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, fpmix=CS%fpmix, waves=waves)
-
else
call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, &
CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves)
endif
if (G%nonblocking_updates) then
+ !$omp target update from(u_inst, v_inst)
call cpu_clock_end(id_clock_vertvisc)
call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass)
call cpu_clock_begin(id_clock_vertvisc)
endif
call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp)
+
call cpu_clock_end(id_clock_vertvisc)
if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)")
! Later, h_av = (h_in + h_out)/2, but for now use h_av to store h_in.
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
+ do concurrent (k=1:nz, j=js-cor_stencil:je+cor_stencil, i=is-cor_stencil:ie+cor_stencil)
h_av(i,j,k) = h(i,j,k)
- enddo ; enddo ; enddo
+ enddo
+
+ call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass, omp_offload=.true.)
- call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass)
if (G%nonblocking_updates) then
call complete_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass)
+ !$omp target update to(u_inst, v_inst)
else
- call do_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass)
+ call do_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass, omp_offload=.true.)
endif
! uh = u_av * h
! h = h + dt * div . uh
! u_av and v_av adjusted so their mass transports match uhbt and vhbt.
call cpu_clock_begin(id_clock_continuity)
- call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, &
+ do concurrent (k=1:nz, j=G%jsd:G%jed, i=G%isd:G%ied)
+ h_tmp(i,j,k) = h(i,j,k)
+ enddo
+
+ call continuity(u_inst, v_inst, h_tmp, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, &
uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, &
u_cor=u_av, v_cor=v_av)
call cpu_clock_end(id_clock_continuity)
- call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass)
+
+ call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass, omp_offload=.true.)
+
+
! Whenever thickness changes let the diag manager know, target grids
! for vertical remapping may need to be regenerated.
call diag_update_remap_grids(CS%diag)
if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)")
if (G%nonblocking_updates) then
+ !$omp target update from(u_av, v_av, uh, vh)
call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass)
else
- call do_group_pass(CS%pass_av_uvh, G%domain, clock=id_clock_pass)
+ call do_group_pass(CS%pass_av_uvh, G%domain, clock=id_clock_pass, omp_offload=.true.)
endif
if (associated(CS%OBC)) then
!### I suspect that there is a bug here when u_inst is compared with a previous value of u_av
! to estimate the dominant outward group velocity, but a fix is not available yet.
+ !$omp target update from(u_inst, v_inst)
call radiation_open_bdry_conds(CS%OBC, u_inst, u_old_rad_OBC, v_inst, v_old_rad_OBC, G, GV, US, dt)
endif
! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in.
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
+ do concurrent (k=1:nz, j=js-cor_stencil:je+cor_stencil, i=is-cor_stencil:ie+cor_stencil)
h_av(i,j,k) = 0.5*(h_av(i,j,k) + h(i,j,k))
- enddo ; enddo ; enddo
+ enddo
- if (G%nonblocking_updates) &
+ if (G%nonblocking_updates) then
call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass)
+ !$omp target update to(u_av, v_av, uh, vh)
+ endif
- !$OMP parallel do default(shared)
- do k=1,nz
- do j=js-2,je+2 ; do I=Isq-2,Ieq+2
- uhtr(I,j,k) = uhtr(I,j,k) + uh(I,j,k)*dt
- enddo ; enddo
- do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2
- vhtr(i,J,k) = vhtr(i,J,k) + vh(i,J,k)*dt
- enddo ; enddo
+ do concurrent (k=1:nz, j=js-cor_stencil:je+cor_stencil, I=Isq-cor_stencil:Ieq+cor_stencil)
+ uhtr(I,j,k) = uhtr(I,j,k) + uh(I,j,k) * dt
+ enddo
+
+ do concurrent (k=1:nz, J=Jsq-cor_stencil:Jeq+cor_stencil, i=is-cor_stencil:ie+cor_stencil)
+ vhtr(i,J,k) = vhtr(i,J,k) + vh(i,J,k) * dt
enddo
+ !$omp target exit data map(release: u_bc_accel, v_bc_accel, eta_pred, uh_in, vh_in)
+ !$omp target exit data map(delete: hp, up, vp, dz, h_tmp)
+
+ if (associated(CS%OBC)) then
+ call update_segment_thickness_reservoirs(G, GV, uhtr, vhtr, h, CS%OBC)
+ endif
+
if (CS%store_CAu) then
! Calculate a predictor-step estimate of the Coriolis and momentum advection terms
! for use in the next time step, possibly after it has been vertically remapped.
@@ -1133,6 +1250,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
call post_data(CS%id_veffA, veffA, CS%diag)
endif
+ !$omp target exit data map(delete: up, vp)
+
! Diagnostics of the fractional thicknesses times momentum budget terms
! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option.
! The code is retained for debugging purposes in the future.
@@ -1194,6 +1313,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f
if (CS%debug) then
call MOM_state_chksum("Corrector ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym)
+ !$omp target update from(u_av, v_av)
call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s)
call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, unscale=GV%H_to_MKS)
! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US)
@@ -1211,7 +1331,7 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_C
type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(param_file_type), intent(in) :: param_file !< parameter file
- type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure
+ type(MOM_dyn_split_RK2_CS), intent(inout) :: CS !< module control structure
type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure
real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), &
target, intent(inout) :: uh !< zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1]
@@ -1227,27 +1347,25 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_C
isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke
IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB
- ! This is where a control structure specific to this module would be allocated.
- if (associated(CS)) then
- call MOM_error(WARNING, "register_restarts_dyn_split_RK2 called with an associated "// &
- "control structure.")
- return
- endif
- allocate(CS)
-
+ ! TODO: Are these initializations necessary? If not, then we can do
+ ! map(alloc:) rather than map(to:)
ALLOC_(CS%diffu(IsdB:IedB,jsd:jed,nz)) ; CS%diffu(:,:,:) = 0.0
ALLOC_(CS%diffv(isd:ied,JsdB:JedB,nz)) ; CS%diffv(:,:,:) = 0.0
+ !$omp target enter data map(to: CS%diffu, CS%diffv)
ALLOC_(CS%CAu(IsdB:IedB,jsd:jed,nz)) ; CS%CAu(:,:,:) = 0.0
ALLOC_(CS%CAv(isd:ied,JsdB:JedB,nz)) ; CS%CAv(:,:,:) = 0.0
+ !$omp target enter data map(to: CS%CAu, CS%CAv)
ALLOC_(CS%CAu_pred(IsdB:IedB,jsd:jed,nz)) ; CS%CAu_pred(:,:,:) = 0.0
ALLOC_(CS%CAv_pred(isd:ied,JsdB:JedB,nz)) ; CS%CAv_pred(:,:,:) = 0.0
+ !$omp target enter data map(to: CS%CAu_pred, CS%CAv_pred)
ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0
ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0
-
+ !$omp target enter data map(to: CS%PFu, CS%PFv)
ALLOC_(CS%eta(isd:ied,jsd:jed)) ; CS%eta(:,:) = 0.0
ALLOC_(CS%u_av(IsdB:IedB,jsd:jed,nz)) ; CS%u_av(:,:,:) = 0.0
ALLOC_(CS%v_av(isd:ied,JsdB:JedB,nz)) ; CS%v_av(:,:,:) = 0.0
ALLOC_(CS%h_av(isd:ied,jsd:jed,nz)) ; CS%h_av(:,:,:) = GV%Angstrom_H
+ !$omp target enter data map(to: CS%eta, CS%u_av, CS%v_av, CS%h_av)
thickness_units = get_thickness_units(GV)
flux_units = get_flux_units(GV)
@@ -1346,7 +1464,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, &
VarMix, MEKE, thickness_diffuse_CSp, &
OBC, update_OBC_CSp, ALE_CSp, set_visc, &
- visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil)
+ visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil, dyn_h_stencil)
type(ocean_grid_type), intent(inout) :: G !< ocean grid structure
type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
@@ -1392,6 +1510,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics
integer, intent(out) :: cont_stencil !< The stencil for thickness
!! from the continuity solver.
+ integer, intent(out) :: dyn_h_stencil !< The stencil for thickness for the
+ !! the dynamics based on the continuity
+ !! solver and Coriolis scheme.
! local variables
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! A temporary copy of the layer thicknesses [H ~> m or kg m-2]
@@ -1402,10 +1523,14 @@ 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 :: cor_stencil
integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz
integer :: IsdB, IedB, JsdB, JedB
+ integer :: nc ! Number of tidal constituents to be harmonically analyzed
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
@@ -1426,9 +1551,15 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
"If true, apply tidal momentum forcing.", default=.false.)
call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, &
"If true, calculate self-attraction and loading.", default=CS%use_tides)
+ call get_param(param_file, mdl, "USE_HA", CS%use_HA, &
+ "If true, perform inline harmonic analysis.", default=.false.)
+ call get_param(param_file, mdl, "HA_N_CONST", nc, &
+ "Number of tidal constituents to be harmonically analyzed.", &
+ default=0, do_not_log=.not.CS%use_HA)
+ if (nc<=0) CS%use_HA = .false.
call get_param(param_file, mdl, "BE", CS%be, &
"If SPLIT is true, BE determines the relative weighting "//&
- "of a 2nd-order Runga-Kutta baroclinic time stepping "//&
+ "of a 2nd-order Runga-Kutta baroclinic time stepping "//&
"scheme (0.5) and a backward Euler scheme (1) that is "//&
"used for the Coriolis and inertial terms. BE may be "//&
"from 0.5 to 1, but instability may occur near 0.5. "//&
@@ -1451,6 +1582,11 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
"If true, use the summed layered fluxes plus an "//&
"adjustment due to the change in the barotropic velocity "//&
"in the barotropic continuity equation.", default=.true.)
+ call get_param(param_file, mdl, "BT_ADJ_CORR_MASS_SRC", CS%BT_adj_corr_mass_src, &
+ "If true, recalculates the barotropic mass source after "//&
+ "predictor step. This should make little difference in the "//&
+ "deep ocean but appears to help for vanished layers. If false, "//&
+ "uses the same mass source as from the predictor step.", default=.true.)
call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, &
"If true, calculate the Coriolis accelerations at the end of each "//&
"timestep for use in the predictor step of the next split RK2 timestep.", &
@@ -1473,14 +1609,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=.false.)
call get_param(param_file, mdl, "VISC_REM_TIMESTEP_BUG", CS%visc_rem_dt_bug, &
"If true, recover a bug that uses dt_pred rather than dt in "//&
"vertvisc_remnant() at the end of predictor stage for the following "//&
@@ -1489,16 +1630,20 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0)
allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0)
+ !$omp target enter data map(to: CS%taux_bot, CS%tauy_bot)
ALLOC_(CS%uhbt(IsdB:IedB,jsd:jed)) ; CS%uhbt(:,:) = 0.0
ALLOC_(CS%vhbt(isd:ied,JsdB:JedB)) ; CS%vhbt(:,:) = 0.0
+ !$omp target enter data map(alloc: CS%uhbt, CS%vhbt)
ALLOC_(CS%visc_rem_u(IsdB:IedB,jsd:jed,nz)) ; CS%visc_rem_u(:,:,:) = 0.0
ALLOC_(CS%visc_rem_v(isd:ied,JsdB:JedB,nz)) ; CS%visc_rem_v(:,:,:) = 0.0
+ !$omp target enter data map(alloc: CS%visc_rem_u, CS%visc_rem_v)
ALLOC_(CS%eta_PF(isd:ied,jsd:jed)) ; CS%eta_PF(:,:) = 0.0
ALLOC_(CS%pbce(isd:ied,jsd:jed,nz)) ; CS%pbce(:,:,:) = 0.0
-
+ !$omp target enter data map(alloc: CS%pbce, CS%eta_PF)
ALLOC_(CS%u_accel_bt(IsdB:IedB,jsd:jed,nz)) ; CS%u_accel_bt(:,:,:) = 0.0
ALLOC_(CS%v_accel_bt(isd:ied,JsdB:JedB,nz)) ; CS%v_accel_bt(:,:,:) = 0.0
+ !$omp target enter data map(alloc: CS%u_accel_bt, CS%v_accel_bt)
ALLOC_(CS%PFu_Stokes(IsdB:IedB,jsd:jed,nz)) ; CS%PFu_Stokes(:,:,:) = 0.0
ALLOC_(CS%PFv_Stokes(isd:ied,JsdB:JedB,nz)) ; CS%PFv_Stokes(:,:,:) = 0.0
@@ -1541,19 +1686,30 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', grain=CLOCK_ROUTINE)
- call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp)
+ !$omp target enter data map(alloc: CS%continuity_CSp)
+ call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC)
cont_stencil = continuity_stencil(CS%continuity_CSp)
call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv)
- if (CS%calculate_SAL) call SAL_init(G, GV, US, param_file, CS%SAL_CSp)
- if (CS%use_tides) then
- call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp)
+ cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv)
+ dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv))
+ if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp, restart_CS)
+ if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp)
+ if (CS%use_HA) then
+ call HA_init(Time, US, param_file, nc, CS%HA_CSp)
HA_CSp => CS%HA_CSp
else
HA_CSp => NULL()
endif
+
+ !$omp target enter data map(alloc: CS%PressureForce_CSp)
call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, &
CS%SAL_CSp, CS%tides_CSp)
+
+ !$omp target enter data map(alloc: CS%hor_visc)
call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp)
+
+ allocate(CS%vertvisc_CSp)
+ !$omp target enter data map(alloc: CS%vertvisc_CSp)
call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, &
ntrunc, CS%vertvisc_CSp, CS%fpmix)
CS%set_visc_CSp => set_visc
@@ -1580,19 +1736,23 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
CS%eta(i,j) = CS%eta(i,j) + h(i,j,k)
enddo ; enddo ; enddo
call set_initialized(CS%eta, trim(eta_rest_name), restart_CS)
+ !$omp target update to(CS%eta)
endif
! Copy eta into an output array.
do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo
+ !$omp target enter data map (alloc: CS%barotropic_CSp)
call barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, &
CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, &
CS%OBC, CS%SAL_CSp, HA_CSp)
if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. &
.not. query_initialized(CS%diffv, "diffv", restart_CS)) then
+ !$omp target update to(u, v, h, uh, vh)
call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, &
tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, &
hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v)
+ !$omp target update from(CS%diffu, CS%diffv)
call set_initialized(CS%diffu, "diffu", restart_CS)
call set_initialized(CS%diffv, "diffv", restart_CS)
endif
@@ -1605,6 +1765,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
call set_initialized(CS%v_av, "v2", restart_CS)
endif
+ !$omp target enter data map(alloc: h_tmp )
if (CS%store_CAu) then
if (query_initialized(CS%CAu_pred, "CAu", restart_CS) .and. &
query_initialized(CS%CAv_pred, "CAv", restart_CS)) then
@@ -1619,17 +1780,21 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
if (read_uv .and. read_h2) then
call pass_var(CS%h_av, G%Domain, clock=id_clock_pass_init)
else
- do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo
+ do concurrent (k=1:nz, j=jsd:jed, i=isd:ied)
+ h_tmp(i,j,k) = h(i,j,k)
+ enddo
call continuity(CS%u_av, CS%v_av, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv)
call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init)
- do k=1,nz ; do j=jsd,jed ; do i=isd,ied
+ do concurrent (k=1:nz, j=jsd:jed, i=isd:ied)
CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k))
- enddo ; enddo ; enddo
+ enddo
endif
- call pass_vector(CS%u_av, CS%v_av, G%Domain, halo=2, clock=id_clock_pass_init, complete=.false.)
- call pass_vector(uh, vh, G%Domain, halo=2, clock=id_clock_pass_init, complete=.true.)
+ call pass_vector(CS%u_av, CS%v_av, G%Domain, halo=cor_stencil, clock=id_clock_pass_init, complete=.false.)
+ call pass_vector(uh, vh, G%Domain, halo=cor_stencil, clock=id_clock_pass_init, complete=.true.)
+ !$omp target update to(CS%u_av, CS%v_av, CS%h_av, uh, vh)
call CorAdCalc(CS%u_av, CS%v_av, CS%h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%ADp, &
G, GV, US, CS%CoriolisAdv, pbv) !, Waves=Waves)
+ !$omp target update from(CS%CAu_pred, CS%CAv_pred)
CS%CAu_pred_stored = .true.
endif
else
@@ -1659,6 +1824,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p
endif
endif
endif
+ !$omp target exit data map(delete: h_tmp )
call cpu_clock_begin(id_clock_pass_init)
call create_group_pass(pass_av_h_uvh, CS%u_av, CS%v_av, G%Domain, halo=2)
if (CS%CAu_pred_stored) then
@@ -1877,20 +2043,27 @@ end subroutine initialize_dyn_split_RK2
subroutine end_dyn_split_RK2(CS)
type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure
+ !$omp target exit data map(delete: CS%barotropic_CSp)
call barotropic_end(CS%barotropic_CSp)
call vertvisc_end(CS%vertvisc_CSp)
deallocate(CS%vertvisc_CSp)
call hor_visc_end(CS%hor_visc)
+ !$omp target exit data map(delete: CS%hor_visc)
+
if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp)
if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp)
call CoriolisAdv_end(CS%CoriolisAdv)
DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv)
+ !$omp target exit data map(delete: CS%diffu, CS%diffv)
DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv)
+ !$omp target exit data map(delete: CS%CAu, CS%CAv)
DEALLOC_(CS%CAu_pred) ; DEALLOC_(CS%CAv_pred)
+ !$omp target exit data map(delete: CS%CAu_pred, CS%CAv_pred)
DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv)
+ !$omp target exit data map(delete: CS%PFu, CS%PFv)
if (associated(CS%taux_bot)) deallocate(CS%taux_bot)
if (associated(CS%tauy_bot)) deallocate(CS%tauy_bot)
@@ -1899,7 +2072,9 @@ subroutine end_dyn_split_RK2(CS)
DEALLOC_(CS%visc_rem_u) ; DEALLOC_(CS%visc_rem_v)
DEALLOC_(CS%eta) ; DEALLOC_(CS%eta_PF) ; DEALLOC_(CS%pbce)
+ !$omp target exit data map(delete: CS%eta, CS%eta_PF, CS%pbce)
DEALLOC_(CS%h_av) ; DEALLOC_(CS%u_av) ; DEALLOC_(CS%v_av)
+ !$omp target exit data map(delete: CS%u_av, CS%v_av, CS%h_av)
call dealloc_BT_cont_type(CS%BT_cont)
deallocate(CS%AD_pred)
diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90
index 7896000a28..e9ccb46cc1 100644
--- a/src/core/MOM_dynamics_split_RK2b.F90
+++ b/src/core/MOM_dynamics_split_RK2b.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Time step the adiabatic dynamic core of MOM using RK2 method with greater use of the
!! time-filtered velocities and less inheritance of tedencies from the previous step in the
!! predictor step than in the original MOM_dyanmics_split_RK2.
module MOM_dynamics_split_RK2b
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type
use MOM_variables, only : BT_cont_type, alloc_bt_cont_type, dealloc_bt_cont_type
use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs
@@ -35,7 +37,7 @@ module MOM_dynamics_split_RK2b
use MOM_restart, only : query_initialized, set_initialized, save_restart
use MOM_restart, only : only_read_from_restarts
use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS
-use MOM_time_manager, only : time_type, time_type_to_real, operator(+)
+use MOM_time_manager, only : time_type, operator(+)
use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/)
use MOM_ALE, only : ALE_CS, ALE_remap_velocities
@@ -46,10 +48,10 @@ module MOM_dynamics_split_RK2b
use MOM_continuity, only : continuity, continuity_CS
use MOM_continuity, only : continuity_init, continuity_stencil
use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS
-use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end
+use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil
use MOM_debugging, only : check_redundant
use MOM_grid, only : ocean_grid_type
-use MOM_harmonic_analysis, only : harmonic_analysis_CS
+use MOM_harmonic_analysis, only : HA_init, harmonic_analysis_CS
use MOM_hor_index, only : hor_index_type
use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS
use MOM_hor_visc, only : hor_visc_init, hor_visc_end
@@ -59,6 +61,8 @@ module MOM_dynamics_split_RK2b
use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds
use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query
use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp
+use MOM_open_boundary, only : copy_thickness_reservoirs
+use MOM_open_boundary, only : update_segment_thickness_reservoirs
use MOM_PressureForce, only : PressureForce, PressureForce_CS
use MOM_PressureForce, only : PressureForce_init
use MOM_set_visc, only : set_viscous_ML, set_visc_CS
@@ -73,7 +77,7 @@ module MOM_dynamics_split_RK2b
use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix
use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units
use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units
-use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF
+use MOM_wave_interface, only : wave_parameters_CS, Stokes_PGF
implicit none ; private
@@ -154,12 +158,16 @@ module MOM_dynamics_split_RK2b
!! effective summed open face areas as a function
!! of barotropic flow.
+ logical :: BT_adj_corr_mass_src !< If true, recalculates the barotropic mass source after
+ !! predictor step. This should make little difference in the
+ !! deep ocean but appears to help for vanished layers.
logical :: split_bottom_stress !< If true, provide the bottom stress
!! calculated by the vertical viscosity to the
!! barotropic solver.
logical :: dtbt_use_bt_cont !< If true, use BT_cont to calculate DTBT.
logical :: calculate_SAL !< If true, calculate self-attraction and loading.
logical :: use_tides !< If true, tidal forcing is enabled.
+ logical :: use_HA !< If true, perform inline harmonic analysis.
logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D
!! variables that are needed to reproduce across restarts,
!! similarly to what is done with the primary state variables.
@@ -171,7 +179,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
@@ -362,10 +371,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1]
! GMM, TODO: make these allocatable?
- real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix
- ! [L T-1 ~> m s-1]
- real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! v-velocity before vert_visc is applied, for fpmix
- ! [L T-1 ~> m s-1]
+ ! real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix
+ ! ! [L T-1 ~> m s-1]
+ ! real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! v-velocity before vert_visc is applied, for fpmix
+ ! ! [L T-1 ~> m s-1]
real :: pres_to_eta ! A factor that converts pressures to the units of eta
! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1]
real, pointer, dimension(:,:) :: &
@@ -385,7 +394,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
uh_ptr => NULL(), & ! A pointer to a zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1]
vh_ptr => NULL() ! A pointer to a meridional volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1]
- real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2]
+ ! real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2]
real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s].
real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1]
logical :: dyn_p_surf
@@ -398,6 +407,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
integer :: cont_stencil, obc_stencil
+ integer :: cor_stencil
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
@@ -462,6 +472,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
cont_stencil = continuity_stencil(CS%continuity_CSp)
obc_stencil = 2
+ cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv)
if (associated(CS%OBC)) then
if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3
endif
@@ -472,24 +483,24 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil))
call create_group_pass(CS%pass_uv_inst, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil))
- call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2)
- call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil))
- call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil))
+ call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=cor_stencil)
+ call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil))
+ call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil))
- call create_group_pass(CS%pass_hp_uhvh, hp, G%Domain, halo=2)
- call create_group_pass(CS%pass_hp_uhvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil))
+ call create_group_pass(CS%pass_hp_uhvh, hp, G%Domain, halo=cor_stencil)
+ call create_group_pass(CS%pass_hp_uhvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil))
+ if (cor_stencil > 2) then
+ call create_group_pass(CS%pass_hp_uhvh, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil))
+ call create_group_pass(CS%pass_hp_uhvh, h, G%Domain, halo=cor_stencil)
+ endif
- call create_group_pass(CS%pass_h_uv, h, G%Domain, halo=max(2,cont_stencil))
- call create_group_pass(CS%pass_h_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil))
- call create_group_pass(CS%pass_h_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil))
+ call create_group_pass(CS%pass_h_uv, h, G%Domain, halo=max(cor_stencil,cont_stencil))
+ call create_group_pass(CS%pass_h_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil))
+ call create_group_pass(CS%pass_h_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil))
call cpu_clock_end(id_clock_pass)
!--- end set up for group halo pass
- if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then
- call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local)
- endif ; endif
-
! This calculates the transports and averaged thicknesses that will be used for the
! predictor version of the Coriolis scheme.
call cpu_clock_begin(id_clock_continuity)
@@ -533,6 +544,9 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
call disable_averaging(CS%diag)
if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2b)")
+ if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then
+ call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local)
+ endif ; endif
if (associated(CS%OBC) .and. CS%debug_OBC) &
call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv)
@@ -544,7 +558,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
endif
!$OMP parallel do default(shared)
- do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
+ do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil
h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k))
enddo ; enddo ; enddo
@@ -657,6 +671,9 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
call cpu_clock_end(id_clock_mom_update)
call do_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass)
+ if (associated(CS%OBC)) &
+ call copy_thickness_reservoirs(CS%OBC, G, GV)
+
! u_accel_bt = layer accelerations due to barotropic solver
call cpu_clock_begin(id_clock_continuity)
call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, &
@@ -788,6 +805,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass)
if (associated(CS%OBC)) then
+
if (CS%debug) &
call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s)
@@ -799,7 +817,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
! h_av = (h + hp)/2
!$OMP parallel do default(shared)
- do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
+ do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil
h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k))
enddo ; enddo ; enddo
@@ -810,9 +828,11 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
! used in the next call to btstep. This call is at this point so that
! hp can be changed if CS%begw /= 0.
! eta_cor = ... (hidden inside CS%barotropic_CSp)
- call cpu_clock_begin(id_clock_btcalc)
- call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp)
- call cpu_clock_end(id_clock_btcalc)
+ if (CS%BT_adj_corr_mass_src) then
+ call cpu_clock_begin(id_clock_btcalc)
+ call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp)
+ call cpu_clock_end(id_clock_btcalc)
+ endif
if (CS%begw /= 0.0) then
! hp <- (1-begw)*h_in + begw*hp
@@ -1039,6 +1059,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc
enddo ; enddo
enddo
+ if (associated(CS%OBC)) then
+ call update_segment_thickness_reservoirs(G, GV, uhtr, vhtr, h, CS%OBC)
+ endif
+
! if (CS%fpmix) then
! if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag)
! if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag)
@@ -1164,7 +1188,6 @@ subroutine register_restarts_dyn_split_RK2b(HI, GV, US, param_file, CS, restart_
real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), &
target, intent(inout) :: vh !< merid volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1]
- character(len=40) :: mdl = "MOM_dynamics_split_RK2b" ! This module's name.
type(vardesc) :: vd(2)
character(len=48) :: thickness_units, flux_units
@@ -1247,7 +1270,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US,
diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, &
VarMix, MEKE, thickness_diffuse_CSp, &
OBC, update_OBC_CSp, ALE_CSp, set_visc, &
- visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil)
+ visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil, dyn_h_stencil)
type(ocean_grid_type), intent(inout) :: G !< ocean grid structure
type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
@@ -1293,19 +1316,23 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US,
type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics
integer, intent(out) :: cont_stencil !< The stencil for thickness
!! from the continuity solver.
+ integer, intent(out) :: dyn_h_stencil !< The stencil for thickness for the
+ !! dynamics based on the continuity
+ !! solver and Coriolis scheme.
! local variables
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! A temporary copy of the layer thicknesses [H ~> m or kg m-2]
character(len=40) :: mdl = "MOM_dynamics_split_RK2b" ! This module's name.
! This include declares and sets the variable "version".
# include "version_variable.h"
character(len=48) :: thickness_units, flux_units, eta_rest_name
logical :: debug_truncations
- logical :: 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
integer :: IsdB, IedB, JsdB, JedB
+ integer :: nc ! Number of tidal constituents to be harmonically analyzed
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
@@ -1326,9 +1353,15 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US,
"If true, apply tidal momentum forcing.", default=.false.)
call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, &
"If true, calculate self-attraction and loading.", default=CS%use_tides)
+ call get_param(param_file, mdl, "USE_HA", CS%use_HA, &
+ "If true, perform inline harmonic analysis.", default=.false.)
+ call get_param(param_file, mdl, "HA_N_CONST", nc, &
+ "Number of tidal constituents to be harmonically analyzed.", &
+ default=0, do_not_log=.not.CS%use_HA)
+ if (nc<=0) CS%use_HA = .false.
call get_param(param_file, mdl, "BE", CS%be, &
"If SPLIT is true, BE determines the relative weighting "//&
- "of a 2nd-order Runga-Kutta baroclinic time stepping "//&
+ "of a 2nd-order Runga-Kutta baroclinic time stepping "//&
"scheme (0.5) and a backward Euler scheme (1) that is "//&
"used for the Coriolis and inertial terms. BE may be "//&
"from 0.5 to 1, but instability may occur near 0.5. "//&
@@ -1347,6 +1380,11 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US,
call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, &
"If true, provide the bottom stress calculated by the "//&
"vertical viscosity to the barotropic solver.", default=.false.)
+ call get_param(param_file, mdl, "BT_ADJ_CORR_MASS_SRC", CS%BT_adj_corr_mass_src, &
+ "If true, recalculates the barotropic mass source after "//&
+ "predictor step. This should make little difference in the "//&
+ "deep ocean but appears to help for vanished layers. If false, "//&
+ "uses the same mass source as from the predictor step.", default=.true.)
! call get_param(param_file, mdl, "FPMIX", CS%fpmix, &
! "If true, apply profiles of momentum flux magnitude and direction.", &
! default=.false.)
@@ -1359,14 +1397,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=.false.)
call get_param(param_file, mdl, "VISC_REM_TIMESTEP_BUG", CS%visc_rem_dt_bug, &
"If true, recover a bug that uses dt_pred rather than dt in "//&
"vertvisc_remnant() at the end of predictor stage for the following "//&
@@ -1424,12 +1467,14 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US,
! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt
! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av
- call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp)
+ call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC)
cont_stencil = continuity_stencil(CS%continuity_CSp)
call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv)
- if (CS%calculate_SAL) call SAL_init(G, GV, US, param_file, CS%SAL_CSp)
- if (CS%use_tides) then
- call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp)
+ dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv))
+ if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp, restart_CS)
+ if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp)
+ if (CS%use_HA) then
+ call HA_init(Time, US, param_file, nc, CS%HA_CSp)
HA_CSp => CS%HA_CSp
else
HA_CSp => NULL()
@@ -1437,6 +1482,8 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US,
call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, &
CS%SAL_CSp, CS%tides_CSp)
call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp)
+
+ allocate(CS%vertvisc_CSp)
call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, &
ntrunc, CS%vertvisc_CSp)
CS%set_visc_CSp => set_visc
diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90
index bce0c4026a..6117704b8f 100644
--- a/src/core/MOM_dynamics_unsplit.F90
+++ b/src/core/MOM_dynamics_unsplit.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Time steps the ocean dynamics with an unsplit quasi 3rd order scheme
module MOM_dynamics_unsplit
-! This file is part of MOM6. See LICENSE.md for the license.
-
!********+*********+*********+*********+*********+*********+*********+**
!* *
!* By Robert Hallberg, 1993-2012 *
@@ -74,7 +76,7 @@ module MOM_dynamics_unsplit
use MOM_barotropic, only : barotropic_CS
use MOM_boundary_update, only : update_OBC_data, update_OBC_CS
use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil
-use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS
+use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS, CoriolisAdv_stencil
use MOM_debugging, only : check_redundant
use MOM_grid, only : ocean_grid_type
use MOM_hor_index, only : hor_index_type
@@ -240,13 +242,15 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, &
real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s].
logical :: dyn_p_surf
integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
+ integer :: cor_stencil ! Stencil size for Coriolis schemes [nondim]
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
dt_pred = dt / 3.0
+ cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv)
- h_av(:,:,:) = 0; hp(:,:,:) = 0
- up(:,:,:) = 0; upp(:,:,:) = 0
- vp(:,:,:) = 0; vpp(:,:,:) = 0
+ h_av(:,:,:) = 0 ; hp(:,:,:) = 0
+ up(:,:,:) = 0 ; upp(:,:,:) = 0
+ vp(:,:,:) = 0 ; vpp(:,:,:) = 0
dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end)
if (dyn_p_surf) then
@@ -278,7 +282,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, &
call pass_var(hp, G%Domain, clock=id_clock_pass)
call pass_vector(uh, vh, G%Domain, clock=id_clock_pass)
- call enable_averages(0.5*dt, Time_local-real_to_time(0.5*US%T_to_s*dt), CS%diag)
+ call enable_averages(0.5*dt, Time_local-real_to_time(0.5*dt, unscale=US%T_to_s), CS%diag)
! Here the first half of the thickness fluxes are offered for averaging.
if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag)
if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag)
@@ -288,7 +292,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, &
! u = u + dt diffu
call cpu_clock_begin(id_clock_mom_update)
do k=1,nz
- do j=js-2,je+2 ; do i=is-2,ie+2
+ do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil
h_av(i,j,k) = (h(i,j,k) + hp(i,j,k)) * 0.5
enddo ; enddo
do j=js,je ; do I=Isq,Ieq
@@ -370,7 +374,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, &
call pass_vector(uh, vh, G%Domain, clock=id_clock_pass)
! h_av <- (hp + h_av)/2
- do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
+ do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil
h_av(i,j,k) = (hp(i,j,k) + h_av(i,j,k)) * 0.5
enddo ; enddo ; enddo
@@ -459,7 +463,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, &
! h_av = (h + hp)/2
do k=1,nz
- do j=js-2,je+2 ; do i=is-2,ie+2
+ do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil
h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k))
enddo ; enddo
do j=js-2,je+2 ; do I=Isq-2,Ieq+2
@@ -576,10 +580,10 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS)
end subroutine register_restarts_dyn_unsplit
!> Initialize parameters and allocate memory associated with the unsplit dynamics module.
-subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS, &
+subroutine initialize_dyn_unsplit(u, v, h, tv, Time, G, GV, US, param_file, diag, CS, &
Accel_diag, Cont_diag, MIS, &
OBC, update_OBC_CSp, ALE_CSp, set_visc, &
- visc, dirs, ntrunc, cont_stencil)
+ visc, dirs, ntrunc, cont_stencil, dyn_h_stencil)
type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
@@ -589,6 +593,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS
intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1].
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]
+ type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type
type(time_type), target, intent(in) :: Time !< The current model time.
type(param_file_type), intent(in) :: param_file !< A structure to parse
!! for run-time parameters.
@@ -623,7 +628,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS
!! records the number of times the velocity
!! is truncated (this should be 0).
integer, intent(out) :: cont_stencil !< The stencil for thickness
- !! from the continuity solver.
+ !! from the continuity solver.
+ integer, intent(out) :: dyn_h_stencil !< The stencil for thickness
+ !! for the dynamics based on the
+ !! continuity solver and Coriolis scheme.
! This subroutine initializes all of the variables that are used by this
! dynamic core, including diagnostics and the cpu clocks.
@@ -633,9 +641,6 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS
character(len=48) :: flux_units
! This include declares and sets the variable "version".
# include "version_variable.h"
- logical :: use_correct_dt_visc
- logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly.
- logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly.
integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
@@ -654,33 +659,6 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS
call log_version(param_file, mdl, version, "")
call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, &
- "If false, use the correct timestep in the viscous terms applied in the first "//&
- "predictor step with the unsplit time stepping scheme, and in the calculation "//&
- "of the turbulent mixed layer properties for viscosity with unsplit or "//&
- "unsplit_RK2. If true, an older incorrect value is used.", &
- default=.false., do_not_log=.true.)
- ! This is used to test whether UNSPLIT_DT_VISC_BUG is being actively set.
- call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", test_value, default=.true., do_not_log=.true.)
- explicit_bug = CS%dt_visc_bug .eqv. test_value
- call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", use_correct_dt_visc, &
- "If true, use the correct timestep in the viscous terms applied in the first "//&
- "predictor step with the unsplit time stepping scheme, and in the calculation "//&
- "of the turbulent mixed layer properties for viscosity with unsplit or "//&
- "unsplit_RK2.", default=.true., do_not_log=.true.)
- call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", test_value, default=.false., do_not_log=.true.)
- explicit_fix = use_correct_dt_visc .eqv. test_value
-
- if (explicit_bug .and. explicit_fix .and. (use_correct_dt_visc .eqv. CS%dt_visc_bug)) then
- ! UNSPLIT_DT_VISC_BUG is being explicitly set, and should not be changed.
- call MOM_error(FATAL, "UNSPLIT_DT_VISC_BUG and FIX_UNSPLIT_DT_VISC_BUG are both being set "//&
- "with inconsistent values. FIX_UNSPLIT_DT_VISC_BUG is an obsolete "//&
- "parameter and should be removed.")
- elseif (explicit_fix) then
- call MOM_error(WARNING, "FIX_UNSPLIT_DT_VISC_BUG is an obsolete parameter. "//&
- "Use UNSPLIT_DT_VISC_BUG instead (noting that it has the opposite sense).")
- CS%dt_visc_bug = .not.use_correct_dt_visc
- endif
- call log_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, &
"If false, use the correct timestep in the viscous terms applied in the first "//&
"predictor step with the unsplit time stepping scheme, and in the calculation "//&
"of the turbulent mixed layer properties for viscosity with unsplit or "//&
@@ -707,14 +685,17 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS
Accel_diag%PFu => CS%PFu ; Accel_diag%PFv => CS%PFv
Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv
- call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp)
+ call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC)
cont_stencil = continuity_stencil(CS%continuity_CSp)
call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv)
- if (CS%calculate_SAL) call SAL_init(G, GV, US, param_file, CS%SAL_CSp)
+ dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv))
+ if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp)
if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp)
call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, &
CS%SAL_CSp, CS%tides_CSp)
call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc)
+
+ allocate(CS%vertvisc_CSp)
call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, &
ntrunc, CS%vertvisc_CSp)
CS%set_visc_CSp => set_visc
diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90
index dd3df7bb3a..552b3e0c03 100644
--- a/src/core/MOM_dynamics_unsplit_RK2.F90
+++ b/src/core/MOM_dynamics_unsplit_RK2.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Time steps the ocean dynamics with an unsplit quasi 2nd order Runge-Kutta scheme
module MOM_dynamics_unsplit_RK2
-! This file is part of MOM6. See LICENSE.md for the license.
-
!********+*********+*********+*********+*********+*********+*********+**
!* *
!* By Alistair Adcroft and Robert Hallberg, 2010-2012 *
@@ -66,14 +68,14 @@ module MOM_dynamics_unsplit_RK2
use MOM_error_handler, only : MOM_set_verbosity
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
use MOM_get_input, only : directories
-use MOM_time_manager, only : time_type, time_type_to_real, operator(+)
+use MOM_time_manager, only : time_type, operator(+)
use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/)
use MOM_ALE, only : ALE_CS
use MOM_boundary_update, only : update_OBC_data, update_OBC_CS
use MOM_barotropic, only : barotropic_CS
use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil
-use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS
+use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS, CoriolisAdv_stencil
use MOM_debugging, only : check_redundant
use MOM_grid, only : ocean_grid_type
use MOM_hor_index, only : hor_index_type
@@ -252,11 +254,13 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt,
real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s]
logical :: dyn_p_surf
integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
+ integer :: cor_stencil ! Stencil size for Coriolis schemes [nondim]
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
dt_pred = dt * CS%BE
+ cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv)
- h_av(:,:,:) = 0; hp(:,:,:) = 0
+ h_av(:,:,:) = 0 ; hp(:,:,:) = 0
up(:,:,:) = 0
vp(:,:,:) = 0
@@ -292,12 +296,15 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt,
! and could/should be optimized out. -AJA
call continuity(u_in, v_in, h_in, hp, uh, vh, dt_pred, G, GV, US, CS%continuity_CSp, CS%OBC, pbv)
call cpu_clock_end(id_clock_continuity)
- call pass_var(hp, G%Domain, clock=id_clock_pass)
- call pass_vector(uh, vh, G%Domain, clock=id_clock_pass)
+ call pass_var(hp, G%Domain, halo=cor_stencil, clock=id_clock_pass)
+ call pass_vector(uh, vh, G%Domain, halo=cor_stencil, clock=id_clock_pass)
+ if (cor_stencil > 2) then
+ call pass_vector(u_in, v_in, G%Domain, halo=cor_stencil, clock=id_clock_pass)
+ endif
! h_av = (h + hp)/2 (used in PV denominator)
call cpu_clock_begin(id_clock_mom_update)
- do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
+ do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil
h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5
enddo ; enddo ; enddo
call cpu_clock_end(id_clock_mom_update)
@@ -366,7 +373,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt,
call pass_vector(uh, vh, G%Domain, clock=id_clock_pass)
! h_av <- (h + hp)/2 (centered at n-1/2)
- do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
+ do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil
h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5
enddo ; enddo ; enddo
@@ -526,16 +533,17 @@ subroutine register_restarts_dyn_unsplit_RK2(HI, GV, param_file, CS)
end subroutine register_restarts_dyn_unsplit_RK2
!> Initialize parameters and allocate memory associated with the unsplit RK2 dynamics module.
-subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag, CS, &
+subroutine initialize_dyn_unsplit_RK2(u, v, h, tv, Time, G, GV, US, param_file, diag, CS, &
Accel_diag, Cont_diag, MIS, &
OBC, update_OBC_CSp, ALE_CSp, set_visc, &
- visc, dirs, ntrunc, cont_stencil)
+ visc, dirs, ntrunc, cont_stencil, dyn_h_stencil)
type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1].
real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1].
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]
+ type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type
type(time_type), target, intent(in) :: Time !< The current model time.
type(param_file_type), intent(in) :: param_file !< A structure to parse
!! for run-time parameters.
@@ -571,6 +579,9 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag
!! velocity is truncated (this should be 0).
integer, intent(out) :: cont_stencil !< The stencil for
!! thickness from the continuity solver.
+ integer, intent(out) :: dyn_h_stencil !< The stencil for
+ !! thickness for the dynamics based on the
+ !! continuity solver and Coriolis scheme.
! This subroutine initializes all of the variables that are used by this
! dynamic core, including diagnostics and the cpu clocks.
@@ -580,9 +591,6 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag
character(len=48) :: flux_units
! This include declares and sets the variable "version".
# include "version_variable.h"
- logical :: use_correct_dt_visc
- logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly.
- logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly.
integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
@@ -601,7 +609,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag
call log_version(param_file, mdl, version, "")
call get_param(param_file, mdl, "BE", CS%be, &
"If SPLIT is true, BE determines the relative weighting "//&
- "of a 2nd-order Runga-Kutta baroclinic time stepping "//&
+ "of a 2nd-order Runga-Kutta baroclinic time stepping "//&
"scheme (0.5) and a backward Euler scheme (1) that is "//&
"used for the Coriolis and inertial terms. BE may be "//&
"from 0.5 to 1, but instability may occur near 0.5. "//&
@@ -617,33 +625,6 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag
units="nondim", default=0.0)
call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, &
- "If false, use the correct timestep in the viscous terms applied in the first "//&
- "predictor step with the unsplit time stepping scheme, and in the calculation "//&
- "of the turbulent mixed layer properties for viscosity with unsplit or "//&
- "unsplit_RK2. If true, an older incorrect value is used.", &
- default=.false., do_not_log=.true.)
- ! This is used to test whether UNSPLIT_DT_VISC_BUG is being explicitly set.
- call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", test_value, default=.true., do_not_log=.true.)
- explicit_bug = CS%dt_visc_bug .eqv. test_value
- call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", use_correct_dt_visc, &
- "If true, use the correct timestep in the viscous terms applied in the first "//&
- "predictor step with the unsplit time stepping scheme, and in the calculation "//&
- "of the turbulent mixed layer properties for viscosity with unsplit or "//&
- "unsplit_RK2.", default=.true., do_not_log=.true.)
- call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", test_value, default=.false., do_not_log=.true.)
- explicit_fix = use_correct_dt_visc .eqv. test_value
-
- if (explicit_bug .and. explicit_fix .and. (use_correct_dt_visc .eqv. CS%dt_visc_bug)) then
- ! UNSPLIT_DT_VISC_BUG is being explicitly set, and should not be changed.
- call MOM_error(FATAL, "UNSPLIT_DT_VISC_BUG and FIX_UNSPLIT_DT_VISC_BUG are both being set "//&
- "with inconsistent values. FIX_UNSPLIT_DT_VISC_BUG is an obsolete "//&
- "parameter and should be removed.")
- elseif (explicit_fix) then
- call MOM_error(WARNING, "FIX_UNSPLIT_DT_VISC_BUG is an obsolete parameter. "//&
- "Use UNSPLIT_DT_VISC_BUG instead (noting that it has the opposite sense).")
- CS%dt_visc_bug = .not.use_correct_dt_visc
- endif
- call log_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, &
"If false, use the correct timestep in the viscous terms applied in the first "//&
"predictor step with the unsplit time stepping scheme, and in the calculation "//&
"of the turbulent mixed layer properties for viscosity with unsplit or "//&
@@ -670,14 +651,17 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag
Accel_diag%PFu => CS%PFu ; Accel_diag%PFv => CS%PFv
Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv
- call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp)
+ call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC)
cont_stencil = continuity_stencil(CS%continuity_CSp)
call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv)
- if (CS%calculate_SAL) call SAL_init(G, GV, US, param_file, CS%SAL_CSp)
+ dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv))
+ if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp)
if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp)
call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, &
CS%SAL_CSp, CS%tides_CSp)
call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc)
+
+ allocate(CS%vertvisc_CSp)
call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, &
ntrunc, CS%vertvisc_CSp)
CS%set_visc_CSp => set_visc
diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90
index f91d958fe8..d21eb78128 100644
--- a/src/core/MOM_forcing_type.F90
+++ b/src/core/MOM_forcing_type.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module implements boundary forcing for MOM6.
module MOM_forcing_type
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair
use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_destructor
use MOM_coupler_types, only : coupler_type_increment_data, coupler_type_initialized
@@ -133,6 +135,10 @@ module MOM_forcing_type
frunoff_glc => NULL(), & !< frozen river glacier runoff entering ocean [R Z T-1 ~> kg m-2 s-1]
seaice_melt => NULL() !< snow/seaice melt (positive) or formation (negative) [R Z T-1 ~> kg m-2 s-1]
+ ! carbon content associated with water crossing ocean surface
+ real, pointer, dimension(:,:) :: &
+ carbon_content_lrunoff => NULL() !< carbon content associated with liquid runoff [R Z T-1 ~> kg m-2 s-1]
+
! Integrated water mass fluxes into the ocean, used for passive tracer sources [H ~> m or kg m-2]
real, pointer, dimension(:,:) :: &
netMassIn => NULL(), & !< Sum of water mass fluxes into the ocean integrated over a
@@ -368,6 +374,7 @@ module MOM_forcing_type
integer :: id_heat_added = -1, id_heat_content_massin = -1
integer :: id_hfrainds = -1, id_hfrunoffds = -1
integer :: id_seaice_melt_heat = -1
+ integer :: id_carbon_content_lrunoff = -1
! global area integrated heat flux diagnostic handles
integer :: id_total_net_heat_coupler = -1, id_total_net_heat_surface = -1
@@ -1183,10 +1190,10 @@ 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
+ integer :: i, j, is, ie, js, je, hs
hs = 0 ; if (present(halo)) hs = max(halo, 0)
is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs
@@ -1228,6 +1235,8 @@ subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_units)
enddo ; enddo
endif
+ !$omp target update to(U_star)
+
end subroutine find_ustar_fluxes
@@ -1248,10 +1257,10 @@ 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
+ integer :: i, j, is, ie, js, je, hs
hs = 0 ; if (present(halo)) hs = max(halo, 0)
is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs
@@ -1263,13 +1272,13 @@ subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_unit
if (associated(forces%ustar) .and. (GV%Boussinesq .or. .not.associated(forces%tau_mag))) then
if (Z_T_units) then
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie) !do j=js,je ; do i=is,ie
U_star(i,j) = forces%ustar(i,j)
- enddo ; enddo
+ enddo
else
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie) !do j=js,je ; do i=is,ie
U_star(i,j) = GV%Z_to_H * forces%ustar(i,j)
- enddo ; enddo
+ enddo
endif
elseif (allocated(tv%SpV_avg)) then
if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, &
@@ -1277,20 +1286,20 @@ subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_unit
if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, &
"find_ustar_mech called in non-Boussinesq mode with insufficient valid values of SpV_avg.")
if (Z_T_units) then
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
U_star(i,j) = sqrt(forces%tau_mag(i,j) * tv%SpV_avg(i,j,1))
- enddo ; enddo
+ enddo
else
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
U_star(i,j) = GV%RZ_to_H * sqrt(forces%tau_mag(i,j) / tv%SpV_avg(i,j,1))
- enddo ; enddo
+ enddo
endif
else
I_rho = GV%Z_to_H * GV%RZ_to_H
if (Z_T_units) I_rho = GV%H_to_Z * GV%RZ_to_H ! == 1.0 / GV%Rho0
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
U_star(i,j) = sqrt(forces%tau_mag(i,j) * I_rho)
- enddo ; enddo
+ enddo
endif
end subroutine find_ustar_mech_forcing
@@ -1392,7 +1401,7 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift)
call hchksum(fluxes%heat_content_frunoff_glc, mesg//" fluxes%heat_content_frunoff_glc", G%HI, &
haloshift=hshift, unscale=US%QRZ_T_to_W_m2)
if (associated(fluxes%heat_content_lprec)) &
- call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, &
+ call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, &
haloshift=hshift, unscale=US%QRZ_T_to_W_m2)
if (associated(fluxes%heat_content_fprec)) &
call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec", G%HI, &
@@ -1540,7 +1549,7 @@ end subroutine forcing_SinglePointPrint
!> Register members of the forcing type for diagnostics
subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, use_berg_fluxes, use_waves, &
- use_cfcs, use_glc_runoff)
+ use_cfcs, use_glc_runoff, use_carbon_runoff)
type(time_type), intent(in) :: Time !< time type
type(diag_ctrl), intent(inout) :: diag !< diagnostic control type
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
@@ -1550,6 +1559,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles,
logical, optional, intent(in) :: use_waves !< If true, allow wave forcing diagnostics
logical, optional, intent(in) :: use_cfcs !< If true, allow cfc related diagnostics
logical, optional, intent(in) :: use_glc_runoff !< If true, allow separate glacial runoff diagnostics
+ logical, optional, intent(in) :: use_carbon_runoff !< If true, allow separate carbon runoff diagnostics
! Clock for forcing diagnostics
handles%id_clock_forcing=cpu_clock_id('(Ocean forcing diagnostics)', grain=CLOCK_ROUTINE)
@@ -1578,7 +1588,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 +1596,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 +1605,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 +1613,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 +1791,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, &
@@ -1848,6 +1860,14 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles,
'W m-2', conversion=US%QRZ_T_to_W_m2, &
standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water')
+ if (present(use_carbon_runoff)) then
+ if (use_carbon_runoff) then
+ handles%id_carbon_content_lrunoff = register_diag_field('ocean_model', 'carbon_content_lrunoff', &
+ diag%axesT1, Time, 'Carbon content of liquid runoff into ocean', &
+ 'kg m-2 s-1', standard_name='carbon_flux_due_to_runoff')
+ endif
+ endif
+
if (present(use_glc_runoff)) then
handles%id_heat_content_frunoff_glc = register_diag_field('ocean_model', 'heat_content_frunoff_glc', &
diag%axesT1, Time, 'Heat content (relative to 0C) of solid glacier runoff into ocean', &
@@ -2010,12 +2030,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 +2159,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 +2279,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 +2314,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
@@ -2474,6 +2494,12 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces)
wt2*flux_tmp%heat_content_frunoff_glc(i,j)
enddo ; enddo
endif
+ if (associated(fluxes%carbon_content_lrunoff) .and. associated(flux_tmp%carbon_content_lrunoff)) then
+ do j=js,je ; do i=is,ie
+ fluxes%carbon_content_lrunoff(i,j) = wt1*fluxes%carbon_content_lrunoff(i,j) + &
+ wt2*flux_tmp%carbon_content_lrunoff(i,j)
+ enddo ; enddo
+ endif
if (associated(fluxes%ustar_shelf) .and. associated(flux_tmp%ustar_shelf)) then
do i=isd,ied ; do j=jsd,jed
@@ -2960,7 +2986,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 +3002,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
@@ -2989,6 +3015,9 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h
endif
endif
+ if ((handles%id_carbon_content_lrunoff > 0) .and. associated(fluxes%carbon_content_lrunoff)) &
+ call post_data(handles%id_carbon_content_lrunoff, fluxes%carbon_content_lrunoff, diag)
+
! post diagnostics for boundary heat fluxes ====================================
if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) &
@@ -3002,8 +3031,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 +3044,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 +3310,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
@@ -3413,7 +3442,7 @@ end subroutine forcing_diagnostics
subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, &
shelf, iceberg, salt, fix_accum_bug, cfc, marbl, &
waves, shelf_sfc_accumulation, lamult, hevap, &
- ice_ncat, tau_mag)
+ ice_ncat, tau_mag, carbon)
type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields
logical, optional, intent(in) :: water !< If present and true, allocate water fluxes
@@ -3439,6 +3468,7 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, &
!! via coupler.
integer, optional, intent(in) :: ice_ncat !< number of ice categories
logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag and related fields
+ logical, optional, intent(in) :: carbon !< If present and true, allocate carbon fluxes
! Local variables
integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
@@ -3451,8 +3481,8 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, &
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
- shelf_sfc_acc=.false.
- if (present(shelf_sfc_accumulation)) shelf_sfc_acc=shelf_sfc_accumulation
+ shelf_sfc_acc = .false.
+ if (present(shelf_sfc_accumulation)) shelf_sfc_acc = shelf_sfc_accumulation
call myAlloc(fluxes%ustar,isd,ied,jsd,jed, ustar)
call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar)
@@ -3484,6 +3514,7 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, &
call myAlloc(fluxes%latent_frunoff_glc_diag,isd,ied,jsd,jed, heat)
call myAlloc(fluxes%salt_flux,isd,ied,jsd,jed, salt)
+ call myAlloc(fluxes%carbon_content_lrunoff,isd,ied,jsd,jed, carbon)
if (present(heat) .and. present(water)) then ; if (heat .and. water) then
call myAlloc(fluxes%heat_content_cond,isd,ied,jsd,jed, .true.)
@@ -3502,12 +3533,12 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, &
call myAlloc(fluxes%p_surf,isd,ied,jsd,jed, press)
! These fields should only be allocated if ice shelf is enabled.
- if (present(shelf)) then; if (shelf) then
+ if (present(shelf)) then ; if (shelf) then
call myAlloc(fluxes%frac_shelf_h,isd,ied,jsd,jed, shelf)
call myAlloc(fluxes%ustar_shelf,isd,ied,jsd,jed, shelf)
call myAlloc(fluxes%iceshelf_melt,isd,ied,jsd,jed, shelf)
if (shelf_sfc_acc) call myAlloc(fluxes%shelf_sfc_mass_flux,isd,ied,jsd,jed, shelf_sfc_acc)
- endif; endif
+ endif ; endif
!These fields should only be allocated when iceberg area is being passed through the coupler.
call myAlloc(fluxes%ustar_berg,isd,ied,jsd,jed, iceberg)
@@ -3551,14 +3582,14 @@ subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes, turns)
!! quarter turns to use on the new grid.
logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf
- logical :: do_iceberg, do_heat_added, do_buoy
+ logical :: do_iceberg, do_heat_added, do_buoy, do_carbon
logical :: even_turns ! True if turns is absent or even
call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_taumag, do_press, &
- do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy)
+ do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy, do_carbon)
call allocate_forcing_type(G, fluxes, do_water, do_heat, do_ustar, &
- do_press, do_shelf, do_iceberg, do_salt, tau_mag=do_taumag)
+ do_press, do_shelf, do_iceberg, do_salt, tau_mag=do_taumag, carbon=do_carbon)
! The following fluxes would typically be allocated by the driver
call myAlloc(fluxes%sw_vis_dir, G%isd, G%ied, G%jsd, G%jed, &
@@ -3651,7 +3682,7 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, &
call myAlloc(forces%mass_berg,isd,ied,jsd,jed, iceberg)
!These fields should only be allocated when waves
- if (present(waves)) then; if (waves) then;
+ if (present(waves)) then ; if (waves) then
if (.not. present(num_stk_bands)) then
call MOM_error(FATAL,"Requested to &
&initialize with waves, but no waves are present.")
@@ -3688,7 +3719,7 @@ end subroutine allocate_mech_forcing_from_ref
!> Return flags indicating which groups of forcings are allocated
subroutine get_forcing_groups(fluxes, water, heat, ustar, tau_mag, press, shelf, &
- iceberg, salt, heat_added, buoy)
+ iceberg, salt, heat_added, buoy, carbon)
type(forcing), intent(in) :: fluxes !< Reference flux fields
logical, intent(out) :: water !< True if fluxes contains water-based fluxes
logical, intent(out) :: heat !< True if fluxes contains heat-based fluxes
@@ -3700,6 +3731,7 @@ subroutine get_forcing_groups(fluxes, water, heat, ustar, tau_mag, press, shelf,
logical, intent(out) :: salt !< True if fluxes contains salt flux
logical, intent(out) :: heat_added !< True if fluxes contains explicit heat
logical, intent(out) :: buoy !< True if fluxes contains buoyancy fluxes
+ logical, optional, intent(out) :: carbon !< True if fluxes contains carbon fluxes
! NOTE: heat, salt, heat_added, and buoy would typically depend on each other
! to some degree. But since this would be enforced at the driver level,
@@ -3716,6 +3748,7 @@ subroutine get_forcing_groups(fluxes, water, heat, ustar, tau_mag, press, shelf,
iceberg = associated(fluxes%ustar_berg)
heat_added = associated(fluxes%heat_added)
buoy = associated(fluxes%buoy)
+ if (present(carbon)) carbon = associated(fluxes%carbon_content_lrunoff)
end subroutine get_forcing_groups
@@ -3796,6 +3829,7 @@ subroutine deallocate_forcing_type(fluxes)
if (associated(fluxes%latent_frunoff_diag)) deallocate(fluxes%latent_frunoff_diag)
if (associated(fluxes%latent_frunoff_glc_diag)) deallocate(fluxes%latent_frunoff_glc_diag)
if (associated(fluxes%sens)) deallocate(fluxes%sens)
+ if (associated(fluxes%carbon_content_lrunoff)) deallocate(fluxes%carbon_content_lrunoff)
if (associated(fluxes%heat_added)) deallocate(fluxes%heat_added)
if (associated(fluxes%heat_content_lrunoff)) deallocate(fluxes%heat_content_lrunoff)
if (associated(fluxes%heat_content_frunoff)) deallocate(fluxes%heat_content_frunoff)
diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90
index e0d456f9a3..94028423ba 100644
--- a/src/core/MOM_grid.F90
+++ b/src/core/MOM_grid.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides the ocean grid type
module MOM_grid
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_hor_index, only : hor_index_type, hor_index_init
use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent
use MOM_domains, only : get_global_shape, deallocate_MOM_domain
@@ -75,8 +77,8 @@ module MOM_grid
real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: &
mask2dT, & !< 0 for land points and 1 for ocean points on the h-grid [nondim].
- geoLatT, & !< The geographic latitude at q points [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].
@@ -95,6 +97,7 @@ module MOM_grid
geoLonCu, & !< The geographic longitude at u points [degrees_E] or [km] or [m].
dxCu, & !< dxCu is delta x at u points [L ~> m].
IdxCu, & !< 1/dxCu [L-1 ~> m-1].
+ IdxCu_OBCmask, & !< 1/dxCu or 0 at boundary or OBC points [L-1 ~> m-1].
dyCu, & !< dyCu is delta y at u points [L ~> m].
IdyCu, & !< 1/dyCu [L-1 ~> m-1].
dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell [L ~> m].
@@ -110,6 +113,7 @@ module MOM_grid
IdxCv, & !< 1/dxCv [L-1 ~> m-1].
dyCv, & !< dyCv is delta y at v points [L ~> m].
IdyCv, & !< 1/dyCv [L-1 ~> m-1].
+ IdyCv_OBCmask, & !< 1/dxCv or 0 at boundary or OBC points [L-1 ~> m-1].
dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell [L ~> m].
IareaCv, & !< The masked inverse areas of v-grid cells [L-2 ~> m-2].
areaCv !< The areas of the v-grid cells [L2 ~> m2].
@@ -158,7 +162,16 @@ module MOM_grid
y_ax_unit_short !< A short description of the y-axis units for documenting parameter units
real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: &
- bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m].
+ bathyT !< Ocean bottom depth, referenced to Z_ref at tracer points. bathyT is in
+ !! depth units and positive *below* Z_ref [Z ~> m].
+ real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: &
+ meanSL !< Spatially varying time mean sea level, referenced to Z_ref at tracer points.
+ !! meanSL is in height units and positive *above* Z_ref. It is used
+ !! a) as the height where p = p_atm or zero;
+ !! b) to calculate time mean thickness of the water column, where
+ !! mean thickness = max(meanSL + bathyT, 0.0).
+ !! meanSL is 2D for the consideration of a domain with spatically varying mean
+ !! height, e.g. the Great Lakes system [Z ~> m].
real :: Z_ref !< A reference value for all geometric height fields, such as bathyT [Z ~> m].
logical :: bathymetry_at_vel !< If true, there are separate values for the
@@ -352,16 +365,16 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v
G%Block(n)%jec = G%Block(n)%jsc + jend(j) - jbegin(j)
G%Block(n)%ied = G%Block(n)%iec + nihalo
G%Block(n)%jed = G%Block(n)%jec + njhalo
- G%Block(n)%IscB = G%Block(n)%isc; G%Block(n)%IecB = G%Block(n)%iec
- G%Block(n)%JscB = G%Block(n)%jsc; G%Block(n)%JecB = G%Block(n)%jec
+ G%Block(n)%IscB = G%Block(n)%isc ; G%Block(n)%IecB = G%Block(n)%iec
+ G%Block(n)%JscB = G%Block(n)%jsc ; G%Block(n)%JecB = G%Block(n)%jec
! For symmetric memory domains, the first block will have the extra point
! at the lower boundary of its computational domain.
if (G%symmetric) then
if (i==1) G%Block(n)%IscB = G%Block(n)%IscB-1
if (j==1) G%Block(n)%JscB = G%Block(n)%JscB-1
endif
- G%Block(n)%IsdB = G%Block(n)%isd; G%Block(n)%IedB = G%Block(n)%ied
- G%Block(n)%JsdB = G%Block(n)%jsd; G%Block(n)%JedB = G%Block(n)%jed
+ G%Block(n)%IsdB = G%Block(n)%isd ; G%Block(n)%IedB = G%Block(n)%ied
+ G%Block(n)%JsdB = G%Block(n)%jsd ; G%Block(n)%JedB = G%Block(n)%jed
!--- For symmetric memory domain, every block will have an extra point
!--- at the lower boundary of its data domain.
if (G%symmetric) then
@@ -433,6 +446,7 @@ subroutine set_derived_metrics(G, US)
if (G%dyCu(I,j) < 0.0) G%dyCu(I,j) = 0.0
G%IdxCu(I,j) = Adcroft_reciprocal(G%dxCu(I,j))
G%IdyCu(I,j) = Adcroft_reciprocal(G%dyCu(I,j))
+ G%IdxCu_OBCmask(I,j) = G%OBCmaskCu(I,j) * G%IdxCu(I,j) ! This may be reset if masks are reset.
enddo ; enddo
do J=JsdB,JedB ; do i=isd,ied
@@ -440,6 +454,7 @@ subroutine set_derived_metrics(G, US)
if (G%dyCv(i,J) < 0.0) G%dyCv(i,J) = 0.0
G%IdxCv(i,J) = Adcroft_reciprocal(G%dxCv(i,J))
G%IdyCv(i,J) = Adcroft_reciprocal(G%dyCv(i,J))
+ G%IdyCv_OBCmask(i,J) = G%OBCmaskCv(i,J) * G%IdyCv(i,J) ! This may be reset if masks are reset.
enddo ; enddo
do J=JsdB,JedB ; do I=IsdB,IedB
@@ -535,6 +550,7 @@ subroutine allocate_metrics(G)
ALLOC_(G%dxBu(IsdB:IedB,JsdB:JedB)) ; G%dxBu(:,:) = 0.0
ALLOC_(G%IdxT(isd:ied,jsd:jed)) ; G%IdxT(:,:) = 0.0
ALLOC_(G%IdxCu(IsdB:IedB,jsd:jed)) ; G%IdxCu(:,:) = 0.0
+ ALLOC_(G%IdxCu_OBCmask(IsdB:IedB,jsd:jed)) ; G%IdxCu_OBCmask(:,:) = 0.0
ALLOC_(G%IdxCv(isd:ied,JsdB:JedB)) ; G%IdxCv(:,:) = 0.0
ALLOC_(G%IdxBu(IsdB:IedB,JsdB:JedB)) ; G%IdxBu(:,:) = 0.0
@@ -545,6 +561,7 @@ subroutine allocate_metrics(G)
ALLOC_(G%IdyT(isd:ied,jsd:jed)) ; G%IdyT(:,:) = 0.0
ALLOC_(G%IdyCu(IsdB:IedB,jsd:jed)) ; G%IdyCu(:,:) = 0.0
ALLOC_(G%IdyCv(isd:ied,JsdB:JedB)) ; G%IdyCv(:,:) = 0.0
+ ALLOC_(G%IdyCv_OBCmask(isd:ied,JsdB:JedB)) ; G%IdyCv_OBCmask(:,:) = 0.0
ALLOC_(G%IdyBu(IsdB:IedB,JsdB:JedB)) ; G%IdyBu(:,:) = 0.0
ALLOC_(G%areaT(isd:ied,jsd:jed)) ; G%areaT(:,:) = 0.0
@@ -570,13 +587,13 @@ subroutine allocate_metrics(G)
ALLOC_(G%dx_Cv(isd:ied,JsdB:JedB)) ; G%dx_Cv(:,:) = 0.0
ALLOC_(G%dy_Cu(IsdB:IedB,jsd:jed)) ; G%dy_Cu(:,:) = 0.0
- ALLOC_(G%porous_DminU(IsdB:IedB,jsd:jed)); G%porous_DminU(:,:) = 0.0
- ALLOC_(G%porous_DmaxU(IsdB:IedB,jsd:jed)); G%porous_DmaxU(:,:) = 0.0
- ALLOC_(G%porous_DavgU(IsdB:IedB,jsd:jed)); G%porous_DavgU(:,:) = 0.0
+ ALLOC_(G%porous_DminU(IsdB:IedB,jsd:jed)) ; G%porous_DminU(:,:) = 0.0
+ ALLOC_(G%porous_DmaxU(IsdB:IedB,jsd:jed)) ; G%porous_DmaxU(:,:) = 0.0
+ ALLOC_(G%porous_DavgU(IsdB:IedB,jsd:jed)) ; G%porous_DavgU(:,:) = 0.0
- ALLOC_(G%porous_DminV(isd:ied,JsdB:JedB)); G%porous_DminV(:,:) = 0.0
- ALLOC_(G%porous_DmaxV(isd:ied,JsdB:JedB)); G%porous_DmaxV(:,:) = 0.0
- ALLOC_(G%porous_DavgV(isd:ied,JsdB:JedB)); G%porous_DavgV(:,:) = 0.0
+ ALLOC_(G%porous_DminV(isd:ied,JsdB:JedB)) ; G%porous_DminV(:,:) = 0.0
+ ALLOC_(G%porous_DmaxV(isd:ied,JsdB:JedB)) ; G%porous_DmaxV(:,:) = 0.0
+ ALLOC_(G%porous_DavgV(isd:ied,JsdB:JedB)) ; G%porous_DavgV(:,:) = 0.0
ALLOC_(G%areaCu(IsdB:IedB,jsd:jed)) ; G%areaCu(:,:) = 0.0
ALLOC_(G%areaCv(isd:ied,JsdB:JedB)) ; G%areaCv(:,:) = 0.0
@@ -584,6 +601,7 @@ subroutine allocate_metrics(G)
ALLOC_(G%IareaCv(isd:ied,JsdB:JedB)) ; G%IareaCv(:,:) = 0.0
ALLOC_(G%bathyT(isd:ied, jsd:jed)) ; G%bathyT(:,:) = -G%Z_ref
+ ALLOC_(G%meanSL(isd:ied, jsd:jed)) ; G%meanSL(:,:) = G%Z_ref
ALLOC_(G%CoriolisBu(IsdB:IedB, JsdB:JedB)) ; G%CoriolisBu(:,:) = 0.0
ALLOC_(G%Coriolis2Bu(IsdB:IedB, JsdB:JedB)) ; G%Coriolis2Bu(:,:) = 0.0
ALLOC_(G%dF_dx(isd:ied, jsd:jed)) ; G%dF_dx(:,:) = 0.0
@@ -596,7 +614,6 @@ subroutine allocate_metrics(G)
allocate(G%gridLonB(G%IsgB:G%IegB), source=0.0)
allocate(G%gridLatT(jsg:jeg), source=0.0)
allocate(G%gridLatB(G%JsgB:G%JegB), source=0.0)
-
end subroutine allocate_metrics
!> Release memory used by the ocean_grid_type and related structures.
@@ -616,6 +633,8 @@ subroutine MOM_grid_end(G)
DEALLOC_(G%dyT) ; DEALLOC_(G%dyCu) ; DEALLOC_(G%dyCv) ; DEALLOC_(G%dyBu)
DEALLOC_(G%IdyT) ; DEALLOC_(G%IdyCu) ; DEALLOC_(G%IdyCv) ; DEALLOC_(G%IdyBu)
+ DEALLOC_(G%IdxCu_OBCmask) ; DEALLOC_(G%IdyCv_OBCmask)
+
DEALLOC_(G%areaT) ; DEALLOC_(G%IareaT)
DEALLOC_(G%areaBu) ; DEALLOC_(G%IareaBu)
DEALLOC_(G%areaCu) ; DEALLOC_(G%IareaCu)
@@ -631,9 +650,10 @@ subroutine MOM_grid_end(G)
DEALLOC_(G%dx_Cv) ; DEALLOC_(G%dy_Cu)
- DEALLOC_(G%bathyT) ; DEALLOC_(G%CoriolisBu) ; DEALLOC_(G%Coriolis2Bu)
- DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy)
- DEALLOC_(G%sin_rot) ; DEALLOC_(G%cos_rot)
+ DEALLOC_(G%bathyT) ; DEALLOC_(G%meanSL)
+ DEALLOC_(G%CoriolisBu) ; DEALLOC_(G%Coriolis2Bu)
+ DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy)
+ DEALLOC_(G%sin_rot) ; DEALLOC_(G%cos_rot)
DEALLOC_(G%porous_DminU) ; DEALLOC_(G%porous_DmaxU) ; DEALLOC_(G%porous_DavgU)
DEALLOC_(G%porous_DminV) ; DEALLOC_(G%porous_DmaxV) ; DEALLOC_(G%porous_DavgV)
diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90
index 5aa822a000..c70c5e8f44 100644
--- a/src/core/MOM_interface_heights.F90
+++ b/src/core/MOM_interface_heights.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Functions for calculating interface heights, including free surface height.
module MOM_interface_heights
-! This file is part of MOM6. See LICENSE.md for the license.
-
-use MOM_density_integrals, only : int_specific_vol_dp, avg_specific_vol
+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
@@ -17,10 +19,10 @@ module MOM_interface_heights
#include
-public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple
+public find_eta, find_dz_for_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple
public calc_derived_thermo
public convert_MLD_to_ML_thickness
-public find_rho_bottom, find_col_avg_SpV
+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
@@ -41,6 +43,80 @@ module MOM_interface_heights
contains
+!> Calculates the change in height across layers, using the appropriate form for
+!! consistency with the calculation of the pressure gradient forces.
+subroutine find_dz_for_eta(h, tv, G, GV, US, dz_lay, halo_size)
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]
+ type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various
+ !! thermodynamic variables.
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: dz_lay !< Height change across layers [Z ~> m]
+ integer, optional, intent(in) :: halo_size !< width of halo points on
+ !! which to calculate eta.
+
+ ! Local variables
+ real :: p(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa]
+ real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2]
+ real :: SpV_lay_conv(SZK_(GV)) ! The prescribed layer specific volume times a conversion factor from
+ ! the units of thickness to layer mass [Z H-1 ~> nondim or m3 kg-1]
+ real :: I_gEarth ! The inverse of the gravitational acceleration times the
+ ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1]
+ integer :: i, j, k, isv, iev, jsv, jev, nz, halo
+
+ halo = 0 ; if (present(halo_size)) halo = max(0,halo_size)
+
+ isv = G%isc-halo ; iev = G%iec+halo ; jsv = G%jsc-halo ; jev = G%jec+halo
+ nz = GV%ke
+
+ if ((isvG%ied) .or. (jsvG%jed)) &
+ call MOM_error(FATAL,"find_dz_for_eta called with an overly large halo_size.")
+
+ if (GV%Boussinesq) then
+ do k=1,nz ; do j=jsv,jev ; do i=isv,iev
+ dz_lay(i,j,K) = h(i,j,k)*GV%H_to_Z
+ enddo ; enddo ; enddo
+ elseif (associated(tv%eqn_of_state)) then
+ I_gEarth = 1.0 / GV%g_Earth
+ !$OMP parallel do default(shared)
+ do j=jsv,jev
+ if (associated(tv%p_surf)) then
+ do i=isv,iev ; p(i,j,1) = tv%p_surf(i,j) ; enddo
+ else
+ do i=isv,iev ; p(i,j,1) = 0.0 ; enddo
+ endif
+ do k=1,nz ; do i=isv,iev
+ p(i,j,K+1) = p(i,j,K) + GV%g_Earth*GV%H_to_RZ*h(i,j,k)
+ enddo ; enddo
+ enddo
+ !$OMP parallel do default(shared) private(dz_geo)
+ do k=1,nz
+ call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), &
+ 0.0, G%HI, tv%eqn_of_state, US, dz_geo, halo_size=halo)
+ do j=jsv,jev ; do i=isv,iev
+ dz_lay(i,j,K) = I_gEarth * dz_geo(i,j)
+ enddo ; enddo
+ enddo
+ else ! non-Boussinesq but with no equation of state
+ do k=1,nz ; do j=jsv,jev ; do i=isv,iev
+ dz_lay(i,j,K) = GV%H_to_RZ*h(i,j,k) / GV%Rlay(k)
+ enddo ; enddo ; enddo
+ ! This would be faster but could change answers.
+ ! do k=1,nz ; SpV_lay_conv(k) = GV%H_to_RZ / GV%Rlay(k) ; enddo
+ ! do k=1,nz ; do j=jsv,jev ; do i=isv,iev
+ ! dz_lay(i,j,K) = h(i,j,k) * SpV_lay_conv(k)
+ ! enddo ; enddo ; enddo
+ endif
+
+ ! To find eta, do the following:
+ ! do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo
+ ! do k=nz,1,-1 ; do j=jsv,jev ; do i=isv,iev
+ ! eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,K)
+ ! enddo ; enddo ; enddo
+
+end subroutine find_dz_for_eta
+
!> Calculates the heights of all interfaces between layers, using the appropriate
!! form for consistency with the calculation of the pressure gradient forces.
!! Additionally, these height may be dilated for consistency with the
@@ -64,16 +140,12 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref)
!! reference height between G%bathyT and eta [Z ~> m]. The default is 0.
! Local variables
- real :: p(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa]
- real :: dz_geo(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in geopotential height
- ! across a layer [L2 T-2 ~> m2 s-2].
+ real :: dz_lay(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in height across a layer [Z ~> m]
real :: dilate(SZI_(G)) ! A non-dimensional dilation factor [nondim]
real :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2]
- real :: I_gEarth ! The inverse of the gravitational acceleration times the
- ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1]
real :: 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)
@@ -83,22 +155,23 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref)
if ((isvG%ied) .or. (jsvG%jed)) &
call MOM_error(FATAL,"find_eta called with an overly large halo_size.")
- I_gEarth = 1.0 / GV%g_Earth
dZ_ref = 0.0 ; if (present(dZref)) dZ_ref = dZref
- !$OMP parallel default(shared) private(dilate,htot)
- !$OMP do
- do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo
-
if (GV%Boussinesq) then
- !$OMP do
- do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev
- eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*GV%H_to_Z
- enddo ; enddo ; enddo
+ do concurrent (j=jsv:jev, i=isv:iev)
+ eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref)
+ enddo
+
+ do concurrent (j=jsv:jev, i=isv:iev)
+ do k=nz,1,-1
+ eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*GV%H_to_Z
+ enddo
+ enddo
+
if (present(eta_bt)) then
! Dilate the water column to agree with the free surface height
! that is used for the dynamics.
- !$OMP do
+ !$omp target update from(eta)
do j=jsv,jev
do i=isv,iev
dilate(i) = (eta_bt(i,j)*GV%H_to_Z + G%bathyT(i,j)) / &
@@ -109,41 +182,22 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref)
(G%bathyT(i,j) + dZ_ref)
enddo ; enddo
enddo
+ !$omp target update to(eta)
endif
else
- if (associated(tv%eqn_of_state)) then
- !$OMP do
- do j=jsv,jev
- if (associated(tv%p_surf)) then
- do i=isv,iev ; p(i,j,1) = tv%p_surf(i,j) ; enddo
- else
- do i=isv,iev ; p(i,j,1) = 0.0 ; enddo
- endif
- do k=1,nz ; do i=isv,iev
- p(i,j,K+1) = p(i,j,K) + GV%g_Earth*GV%H_to_RZ*h(i,j,k)
- enddo ; enddo
- enddo
- !$OMP do
- do k=1,nz
- call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), &
- 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo)
- enddo
- !$OMP do
- do j=jsv,jev
- do k=nz,1,-1 ; do i=isv,iev
- eta(i,j,K) = eta(i,j,K+1) + I_gEarth * dz_geo(i,j,k)
- enddo ; enddo
- enddo
- else
- !$OMP do
- do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev
- eta(i,j,K) = eta(i,j,K+1) + GV%H_to_RZ*h(i,j,k) / GV%Rlay(k)
- enddo ; enddo ; enddo
- endif
+ !$omp target update from(eta)
+ call find_dz_for_eta(h, tv, G, GV, US, dz_lay, halo_size)
+
+ do j=jsv,jev
+ do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo
+ do k=nz,1,-1 ; do i=isv,iev
+ eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,k)
+ enddo ; enddo
+ enddo
+
if (present(eta_bt)) then
! Dilate the water column to agree with the free surface height
! from the time-averaged barotropic solution.
- !$OMP do
do j=jsv,jev
do i=isv,iev ; htot(i) = GV%H_subroundoff ; enddo
do k=1,nz ; do i=isv,iev ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo
@@ -154,9 +208,8 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref)
enddo ; enddo
enddo
endif
+ !$omp target update to(eta)
endif
- !$OMP end parallel
-
end subroutine find_eta_3d
!> Calculates the free surface height, using the appropriate form for consistency
@@ -182,73 +235,48 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref)
!! reference height between G%bathyT and eta [Z ~> m]. The default is 0.
! Local variables
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: &
- p ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa]
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: &
- dz_geo ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2].
+ real :: dz_lay(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in height across a layer [Z ~> m]
real :: htot(SZI_(G)) ! The sum of all layers' thicknesses [H ~> m or kg m-2].
- real :: I_gEarth ! The inverse of the gravitational acceleration times the
- ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1]
real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m].
! dZ_ref is 0 unless the optional argument dZref is present.
- integer i, j, k, is, ie, js, je, nz, halo
+ integer :: i, j, k, is, ie, js, je, nz, halo
halo = 0 ; if (present(halo_size)) halo = max(0,halo_size)
is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo
nz = GV%ke
- I_gEarth = 1.0 / GV%g_Earth
dZ_ref = 0.0 ; if (present(dZref)) dZ_ref = dZref
- !$OMP parallel default(shared) private(htot)
- !$OMP do
- do j=js,je ; do i=is,ie ; eta(i,j) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo
-
if (GV%Boussinesq) then
if (present(eta_bt)) then
- !$OMP do
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
eta(i,j) = GV%H_to_Z*eta_bt(i,j) - dZ_ref
- enddo ; enddo
+ enddo
else
- !$OMP do
- do j=js,je ; do k=1,nz ; do i=is,ie
- eta(i,j) = eta(i,j) + h(i,j,k)*GV%H_to_Z
- enddo ; enddo ; enddo
- endif
- else
- if (associated(tv%eqn_of_state)) then
- !$OMP do
- do j=js,je
- if (associated(tv%p_surf)) then
- do i=is,ie ; p(i,j,1) = tv%p_surf(i,j) ; enddo
- else
- do i=is,ie ; p(i,j,1) = 0.0 ; enddo
- endif
+ do concurrent (j=js:je)
+ do concurrent (i=is:ie)
+ eta(i,j) = -G%bathyT(i,j) + dZ_ref
+ enddo
- do k=1,nz ; do i=is,ie
- p(i,j,k+1) = p(i,j,k) + GV%g_Earth*GV%H_to_RZ*h(i,j,k)
+ do k=1,nz ; do concurrent (i=is:ie)
+ eta(i,j) = eta(i,j) + h(i,j,k)*GV%H_to_Z
enddo ; enddo
enddo
- !$OMP do
- do k = 1, nz
- call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, &
- G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo)
- enddo
- !$OMP do
- do j=js,je ; do k=1,nz ; do i=is,ie
- eta(i,j) = eta(i,j) + I_gEarth * dz_geo(i,j,k)
- enddo ; enddo ; enddo
- else
- !$OMP do
- do j=js,je ; do k=1,nz ; do i=is,ie
- eta(i,j) = eta(i,j) + GV%H_to_RZ*h(i,j,k) / GV%Rlay(k)
- enddo ; enddo ; enddo
endif
+ else
+ !$omp target update from(eta)
+ call find_dz_for_eta(h, tv, G, GV, US, dz_lay, halo_size)
+
+ do j=js,je
+ do i=is,ie ; eta(i,j) = -(G%bathyT(i,j) + dZ_ref) ; enddo
+ do k=1,nz ; do i=is,ie
+ eta(i,j) = eta(i,j) + dz_lay(i,j,k)
+ enddo ; enddo
+ enddo
+
if (present(eta_bt)) then
! Dilate the water column to agree with the time-averaged column
! mass from the barotropic solution.
- !$OMP do
do j=js,je
do i=is,ie ; htot(i) = GV%H_subroundoff ; enddo
do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo
@@ -257,10 +285,9 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref)
(G%bathyT(i,j) + dZ_ref)
enddo
enddo
+ !$omp target update to(eta)
endif
endif
- !$OMP end parallel
-
end subroutine find_eta_2d
@@ -345,7 +372,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 +418,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.
@@ -415,7 +507,7 @@ subroutine find_rho_bottom(G, GV, US, tv, h, dz, pres_int, dz_avg, j, Rho_bot, h
! Local variables
real :: hb(SZI_(G)) ! Running sum of the thickness in the bottom boundary layer [H ~> m or kg m-2]
real :: SpV_h_bot(SZI_(G)) ! Running sum of the specific volume times thickness in the bottom
- ! boundary layer [R-1 H ~> m4 kg-1 or m]
+ ! boundary layer [H R-1 ~> m4 kg-1 or m]
real :: dz_bbl_rem(SZI_(G)) ! Vertical extent of the boundary layer that has yet to be accounted
! for [Z ~> m]
real :: h_bbl_frac(SZI_(G)) ! Thickness of the fractional layer that makes up the top of the
@@ -787,7 +879,7 @@ end subroutine dz_to_thickness_simple
!> Converts layer thicknesses in thickness units to the vertical distance between edges in height
!! units, perhaps by multiplication by the precomputed layer-mean specific volume stored in an
!! array in the thermo_var_ptrs type when in non-Boussinesq mode.
-subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size)
+subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size, do_offload)
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
@@ -801,9 +893,16 @@ subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size)
!! inout to preserve any initialized values in halo points.
integer, optional, intent(in) :: halo_size !< Width of halo within which to
!! calculate thicknesses
+ logical, optional, intent(in) :: do_offload !< If .true., only uses data calculates dz
+ !! on GPU (default .false.)
! Local variables
character(len=128) :: mesg ! A string for error messages
integer :: i, j, k, is, ie, js, je, halo, nz
+ logical :: use_doconcurrent
+
+ ! guard to allow turning off/on do concurrent
+ use_doconcurrent = .false.
+ if (present(do_offload)) use_doconcurrent = do_offload
halo = 0 ; if (present(halo_size)) halo = max(0,halo_size)
is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke
@@ -818,14 +917,25 @@ subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size)
endif
call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg))
endif
-
- do k=1,nz ; do j=js,je ; do i=is,ie
- dz(i,j,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)
- enddo ; enddo ; enddo
+ if (use_doconcurrent) then
+ do concurrent (k=1:nz, j=js:je, i=is:ie)
+ dz(i,j,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)
+ enddo
+ else
+ do k=1,nz ; do j=js,je ; do i=is,ie
+ dz(i,j,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)
+ enddo ; enddo ; enddo
+ endif
else
- do k=1,nz ; do j=js,je ; do i=is,ie
- dz(i,j,k) = GV%H_to_Z * h(i,j,k)
- enddo ; enddo ; enddo
+ if (use_doconcurrent) then
+ do concurrent (k=1:nz, j=js:je, i=is:ie)
+ dz(i,j,k) = GV%H_to_Z * h(i,j,k)
+ enddo
+ else
+ do k=1,nz ; do j=js,je ; do i=is,ie
+ dz(i,j,k) = GV%H_to_Z * h(i,j,k)
+ enddo ; enddo ; enddo
+ endif
endif
end subroutine thickness_to_dz_3d
diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90
index cdba3e0ba9..1dd1d92bf2 100644
--- a/src/core/MOM_isopycnal_slopes.F90
+++ b/src/core/MOM_isopycnal_slopes.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Calculations of isoneutral slopes and stratification.
module MOM_isopycnal_slopes
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum, uvchksum
use MOM_error_handler, only : MOM_error, FATAL
use MOM_grid, only : ocean_grid_type
@@ -28,8 +30,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 +63,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 +132,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 +142,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 +161,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 +249,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 +274,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 +366,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 +400,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 +414,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 +431,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 +451,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 +550,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 +584,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..ee8d59cef3 100644
--- a/src/core/MOM_open_boundary.F90
+++ b/src/core/MOM_open_boundary.F90
@@ -1,35 +1,36 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Controls where open boundary conditions are applied
module MOM_open_boundary
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : rotate_array, rotate_array_pair
-use MOM_array_transform, only : allocate_rotated_array
-use MOM_coms, only : sum_across_PEs, Set_PElist, Get_PElist, PE_here, num_PEs
+use MOM_coms, only : sum_across_PEs, any_across_PEs
+use MOM_coms, only : Set_PElist, Get_PElist, PE_here, num_PEs
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE
-use MOM_debugging, only : hchksum, uvchksum
+use MOM_debugging, only : hchksum, uvchksum, chksum
use MOM_diag_mediator, only : diag_ctrl, time_type
use MOM_domains, only : pass_var, pass_vector
use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type
use MOM_domains, only : To_All, EAST_FACE, NORTH_FACE, SCALAR_PAIR, CGRID_NE, CORNER
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, NOTE, is_root_pe
-use MOM_file_parser, only : get_param, log_version, param_file_type, log_param
+use MOM_file_parser, only : get_param, log_version, param_file_type, read_param
use MOM_grid, only : ocean_grid_type, hor_index_type
use MOM_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(-)
+use MOM_time_manager, only : set_date, time_type, time_minus_signed
use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : thermo_var_ptrs
@@ -42,37 +43,43 @@ 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 read_OBC_segment_data
public update_OBC_segment_data
+public initialize_OBC_segment_reservoirs
public open_boundary_test_extern_uv
public open_boundary_test_extern_h
public open_boundary_zero_normal_flow
public parse_segment_str
-public parse_segment_manifest_str
-public parse_segment_data_str
public register_OBC, OBC_registry_init
public register_file_OBC, file_OBC_end
public segment_tracer_registry_init
public segment_tracer_registry_end
+public segment_thickness_reservoir_init
public register_segment_tracer
public register_temp_salt_segments
public register_obgc_segments
public fill_temp_salt_segments
public fill_obgc_segments
+public fill_thickness_segments
public set_obgc_segments_props
public setup_OBC_tracer_reservoirs
+public setup_OBC_thickness_reservoirs
public open_boundary_register_restarts
+public copy_thickness_reservoirs
public update_segment_tracer_reservoirs
+public update_segment_thickness_reservoirs
+public set_initialized_OBC_tracer_reservoirs
public update_OBC_ramp
public remap_OBC_fields
public rotate_OBC_config
-public rotate_OBC_init
+public rotate_OBC_segment_direction
+public write_OBC_info, chksum_OBC_segments
public initialize_segment_data
public flood_fill
public flood_fill2
@@ -82,15 +89,43 @@ module MOM_open_boundary
integer, parameter, public :: OBC_DIRECTION_S = 200 !< Indicates the boundary is an effective southern boundary
integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary
integer, parameter, public :: OBC_DIRECTION_W = 400 !< Indicates the boundary is an effective western boundary
-integer, parameter :: MAX_OBC_FIELDS = 100 !< Maximum number of data fields needed for OBC segments
+!>@{ Enumeration values for OBC relative vorticity configurations
+integer, parameter, public :: OBC_VORTICITY_NONE = 0
+integer, parameter, public :: OBC_VORTICITY_ZERO = 1
+integer, parameter, public :: OBC_VORTICITY_FREESLIP = 2
+integer, parameter, public :: OBC_VORTICITY_COMPUTED = 3
+integer, parameter, public :: OBC_VORTICITY_SPECIFIED = 4
+!>@}
+!>@{ Enumeration values for OBC strain configurations
+integer, parameter, public :: OBC_STRAIN_NONE = 0
+integer, parameter, public :: OBC_STRAIN_ZERO = 1
+integer, parameter, public :: OBC_STRAIN_FREESLIP = 2
+integer, parameter, public :: OBC_STRAIN_COMPUTED = 3
+integer, parameter, public :: OBC_STRAIN_SPECIFIED = 4
+!>@}
+integer, parameter :: NUM_PHYS_FIELDS = 13 !< Number of physical fields
+!>@{ Indices of physical field positions in segment%field array
+integer, parameter :: &
+ F_U = 1, F_V = 2, F_VX = 3, F_UY = 4, F_Z = 5, F_UAMP = 6, F_UPHASE = 7, &
+ F_VAMP = 8, F_VPHASE = 9, F_ZAMP = 10, F_ZPHASE = 11, F_T = 12, F_S = 13
+!>@}
+character(len=8), parameter :: PHYS_FIELD_NAMES(NUM_PHYS_FIELDS) = &
+ [character(len=8) :: 'U', 'V', 'DVDX', 'DUDY', 'SSH', 'Uamp', &
+ 'Uphase', 'Vamp', 'Vphase', 'SSHamp', 'SSHphase', 'TEMP', 'SALT'] !< Physical field name
+ !! strings used by input parameter
!> Open boundary segment data from files (mostly).
type, public :: OBC_segment_data_type
type(external_field) :: handle !< handle from FMS associated with segment data on disk
type(external_field) :: dz_handle !< handle from FMS associated with segment thicknesses on disk
+ logical :: required = .false. !< True if this field is required
logical :: use_IO = .false. !< True if segment data is based on file input
- character(len=32) :: name !< a name identifier for the segment data
- character(len=8) :: genre !< an 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.
+ integer :: tr_index = -1 !< If this field is a tracer, its index in registry is stored here.
+ logical :: bgc_tracer !< True if this field is a BGC tracer
+ logical :: on_face !< If true, this field is discretized on the OBC segment
+ !! (velocity-point) faces, or if false it as the vorticiy points
real :: scale !< A scaling factor for converting input data to
!! the internal units of this field. For salinity this would
!! be in units of [S ppt-1 ~> 1]
@@ -110,10 +145,10 @@ module MOM_open_boundary
!! for salinity.
real :: resrv_lfac_in = 1. !< The reservoir inverse length scale factor for the inward
!! direction per field [nondim]. The general 1/Lscale_in is
- !! multiplied by this factor for a specific tracer.
+ !! multiplied by this factor for a specific tracer or thickness.
real :: resrv_lfac_out= 1. !< The reservoir inverse length scale factor for the outward
!! direction per field [nondim]. The general 1/Lscale_out is
- !! multiplied by this factor for a specific tracer.
+ !! multiplied by this factor for a specific tracer or thickness.
end type OBC_segment_data_type
!> Tracer on OBC segment data structure, for putting into a segment tracer registry.
@@ -133,6 +168,20 @@ module MOM_open_boundary
integer :: fd_index = -1 !< index of segment tracer in the input fields
end type OBC_segment_tracer_type
+!> Thickness on OBC segment data structure, with a reservoir
+type, public :: OBC_segment_thickness_type
+ real, allocatable :: h(:,:,:) !< layer thickness array in rescaled units, [Z ~> m].
+ real :: OBC_inflow_conc = 0.0 !< layer thickness for generic inflows in rescaled units,
+ !! [Z ~> m].
+ character(len=32) :: name !< thickness name used for error messages
+ real, allocatable :: h_res(:,:,:) !< thickness reservoir array in rescaled units,
+ !! [Z ~> m].
+ real :: scale !< A scaling factor for converting the units of input
+ !! data, [Z m-1 ~> 1].
+ logical :: is_initialized !< reservoir values have been set when True
+ integer :: fd_index = -1 !< index of segment thickness in the input fields
+end type OBC_segment_thickness_type
+
!> Registry type for tracers on segments
type, public :: segment_tracer_registry_type
integer :: ntseg = 0 !< number of registered tracer segments
@@ -166,45 +215,23 @@ module MOM_open_boundary
logical :: open !< Boundary is open for continuity solver, and there are no other
!! parameterized mass fluxes at the open boundary.
logical :: gradient !< Zero gradient at boundary.
- logical :: values_needed !< Whether or not any external OBC fields are needed.
- logical :: u_values_needed !< Whether or not external u OBC fields are needed.
- logical :: uamp_values_needed !< Whether or not external u amplitude OBC fields are needed.
- logical :: uphase_values_needed !< Whether or not external u phase OBC fields are needed.
- logical :: v_values_needed !< Whether or not external v OBC fields are needed.
- logical :: vamp_values_needed !< Whether or not external v amplitude OBC fields are needed.
- logical :: vphase_values_needed !< Whether or not external v phase OBC fields are needed.
- logical :: t_values_needed!< Whether or not external T OBC fields are needed.
- logical :: s_values_needed!< Whether or not external S OBC fields are needed.
- logical :: z_values_needed!< Whether or not external zeta OBC fields are needed.
- logical :: zamp_values_needed !< Whether or not external zeta amplitude OBC fields are needed.
- logical :: zphase_values_needed !< Whether or not external zeta phase OBC fields are needed.
- logical :: g_values_needed!< Whether or not external gradient OBC fields are needed.
integer :: direction !< Boundary faces one of the four directions.
logical :: is_N_or_S !< True if the OB is facing North or South and exists on this PE.
logical :: is_E_or_W !< True if the OB is facing East or West and exists on this PE.
logical :: is_E_or_W_2 !< True if the OB is facing East or West anywhere.
type(OBC_segment_data_type), pointer :: field(:) => NULL() !< OBC data
integer :: num_fields !< number of OBC data fields (e.g. u_normal,u_parallel and eta for Flather)
- integer :: Is_obc !< i-indices of boundary segment.
- integer :: Ie_obc !< i-indices of boundary segment.
- integer :: Js_obc !< j-indices of boundary segment.
- integer :: Je_obc !< j-indices of boundary segment.
- integer :: uamp_index !< Save where uamp is in segment%field.
- integer :: uphase_index !< Save where uphase is in segment%field.
- integer :: vamp_index !< Save where vamp is in segment%field.
- integer :: vphase_index !< Save where vphase is in segment%field.
- integer :: zamp_index !< Save where zamp is in segment%field.
- integer :: zphase_index !< Save where zphase is in segment%field.
+ integer :: Is_obc !< Starting local i-index of boundary segment, this may be outside of the local PE.
+ integer :: Ie_obc !< Ending local i-index of boundary segment, this may be outside of the local PE.
+ integer :: Js_obc !< Starting local j-index of boundary segment, this may be outside of the local PE.
+ integer :: Je_obc !< Ending local j-index of boundary segment, this may be outside of the local PE.
real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow [T ~> s].
real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow [T ~> s].
logical :: on_pe !< true if any portion of the segment is located in this PE's data domain
logical :: temp_segment_data_exists !< true if temperature data arrays are present
logical :: salt_segment_data_exists !< true if salinity data arrays are present
- real, allocatable :: Cg(:,:) !< The external gravity wave speed [L T-1 ~> m s-1]
- !! at OBC-points.
real, allocatable :: Htot(:,:) !< The total column thickness [H ~> m or kg m-2] at OBC-points.
- real, allocatable :: 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 :: 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
@@ -215,8 +242,15 @@ module MOM_open_boundary
!! segment [H L2 T-1 ~> m3 s-1].
real, allocatable :: normal_vel_bt(:,:) !< The barotropic velocity normal to
!! the OB segment [L T-1 ~> m s-1].
+ real, allocatable :: normal_trans_bt(:,:) !< The barotropic transport normal
+ !! the OB segment [H L2 T-1 ~> m3 s-1 or kg s-1].
+ real, allocatable :: tidal_vn(:,:) !< The barotropic tidal velocity normal to
+ !! the OB segment [L T-1 ~> m s-1].
+ real, allocatable :: tidal_vt(:,:) !< The barotropic tidal velocity tangential to
+ !! the OB segment [L T-1 ~> m s-1].
real, allocatable :: SSH(:,:) !< The sea-surface elevation along the
!! segment [Z ~> m].
+ real, allocatable :: tidal_elev(:,:) !< Tidal elevation at the OBC points [Z ~> m]
real, allocatable :: grad_normal(:,:,:) !< The gradient of the normal flow along the
!! segment times the grid spacing [L T-1 ~> m s-1],
!! with the first index being the corner-point index
@@ -252,6 +286,7 @@ module MOM_open_boundary
!! discretized at the corner (PV) points.
real, allocatable :: nudged_tangential_grad(:,:,:) !< The layer dvdx or dudy towards which nudging
!! can occur [T-1 ~> s-1].
+ type(OBC_segment_thickness_type), pointer :: h_Reg=> NULL()!< A pointer to the thickness for the segment.
type(segment_tracer_registry_type), pointer :: tr_Reg=> NULL()!< A pointer to the tracer registry for the segment.
type(hor_index_type) :: HI !< Horizontal index ranges
real :: Tr_InvLscale_out !< An effective inverse length scale for restoring
@@ -261,11 +296,19 @@ module MOM_open_boundary
real :: Tr_InvLscale_in !< An effective inverse length scale for restoring
!! the tracer concentration towards an externally
!! imposed value when flow is entering [L-1 ~> m-1]
+ real :: Th_InvLscale_out !< An effective inverse length scale for restoring
+ !! the layer thickness in a fictitious
+ !! reservoir towards interior values when flow
+ !! is exiting the domain [L-1 ~> m-1]
+ real :: Th_InvLscale_in !< An effective inverse length scale for restoring
+ !! the layer thickness towards an externally
+ !! imposed value when flow is entering [L-1 ~> m-1]
end type OBC_segment_type
!> Open-boundary data
type, public :: ocean_OBC_type
integer :: number_of_segments = 0 !< The number of open-boundary segments.
+ logical :: reverse_segment_order = .false. !< If true, store the segments internally in the reversed order.
integer :: ke = 0 !< The number of model layers
logical :: open_u_BCs_exist_globally = .false. !< True if any zonal velocity points
!! in the global domain use open BCs.
@@ -291,23 +334,9 @@ module MOM_open_boundary
logical :: update_OBC = .false. !< Is OBC data time-dependent
logical :: update_OBC_seg_data = .false. !< Is it the time for OBC segment data update for fields that
!! 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.
- logical :: computed_vorticity = .false. !< If True, uses external data for tangential velocity
- !! in the relative vorticity on open boundaries.
- logical :: specified_vorticity = .false. !< If True, uses external data for tangential velocity
- !! gradients in the relative vorticity on open boundaries.
- logical :: zero_strain = .false. !< If True, sets strain to zero on open boundaries.
- logical :: freeslip_strain = .false. !< If True, sets normal gradient of tangential velocity to zero
- !! in the strain on open boundaries.
- logical :: computed_strain = .false. !< If True, uses external data for tangential velocity to compute
- !! normal gradient in the strain on open boundaries.
- logical :: specified_strain = .false. !< If True, uses external data for tangential velocity gradients
- !! to compute strain on open boundaries.
+ integer :: vorticity_config !< An integer indicating OBC relative vorticity configuration
+ integer :: strain_config !< An integer indicating OBC strain configuration
logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for
!! use in the biharmonic viscosity term.
logical :: brushcutter_mode = .false. !< If True, read data on supergrid.
@@ -315,6 +344,8 @@ module MOM_open_boundary
!! true for those with x reservoirs (needed for restarts).
logical, allocatable :: tracer_y_reservoirs_used(:) !< Dimensioned by the number of tracers, set globally,
!! true for those with y reservoirs (needed for restarts).
+ logical :: thickness_x_reservoirs_used = .false. !< True for thichness reservoirs in x (needed for restarts).
+ logical :: thickness_y_reservoirs_used = .false. !< True for thichness reservoirs in y (needed for restarts).
integer :: ntr = 0 !< number of tracers
integer :: n_tide_constituents = 0 !< Number of tidal constituents to add to the boundary.
logical :: add_tide_constituents = .false. !< If true, add tidal constituents to the boundary elevation
@@ -334,8 +365,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 +383,51 @@ 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]
+ real, allocatable :: h_res_x(:,:,:) !< Array storage of thickness reservoirs for restarts,
+ !! [Z ~> m]
+ real, allocatable :: h_res_y(:,:,:) !< Array storage of thickness reservoirs for restarts,
+ !! [Z ~> m]
+ logical :: use_h_res = .false. !< If true, use thickness reservoirs
+ logical :: debug !< If true, write verbose checksums for debugging purposes.
+ integer :: nk_OBC_debug = 0 !< The number of layers of OBC segment data to write out
+ !! in full when DEBUG_OBCS is true.
real :: silly_h !< A silly value of thickness outside of the domain that can be used to test
!! the independence of the OBCs to this external data [Z ~> m].
real :: silly_u !< A silly value of velocity outside of the domain that can be used to test
@@ -393,7 +449,14 @@ 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.
+ logical :: ts_needed_bug !< If true, recover a bug that temperature and salinity can be ignored
+ !! even if they are registered tracers in the rest of the model.
end type ocean_OBC_type
!> Control structure for open boundaries that read from files.
@@ -431,11 +494,11 @@ module MOM_open_boundary
contains
!> Enables OBC module and reads configuration parameters
-!> This routine is called from MOM_initialize_fixed which
-!> occurs before the initialization of the vertical coordinate
-!> and ALE_init. Therefore segment data are not fully initialized
-!> here. The remainder of the segment data are initialized in a
-!> later call to update_open_boundary_data
+!! This routine is called from MOM_initialize_fixed which
+!! occurs before the initialization of the vertical coordinate
+!! and ALE_init. Therefore segment data are not fully initialized
+!! here. The remainder of the segment data are initialized in a
+!! later call to update_open_boundary_data
subroutine open_boundary_config(G, US, param_file, OBC)
type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
@@ -443,285 +506,409 @@ subroutine open_boundary_config(G, US, param_file, OBC)
type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure
! Local variables
- integer :: l ! For looping over segments
- logical :: debug, debug_OBC, mask_outside, reentrant_x, reentrant_y
+ integer :: num_of_segs ! Number of open boundary segments
+ integer :: n, n_seg ! For looping over segments
+ logical :: debug, mask_outside, reentrant_x, reentrant_y
character(len=15) :: segment_param_str ! The run-time parameter name for each segment
character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str"
- character(len=200) :: config1 ! String for OBC_USER_CONFIG
+ character(len=200) :: config ! A string to temporarily store a few runtime parameters
real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m]
integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags.
- logical :: check_remapping, force_bounds_in_subcell
- logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm
+ logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
+ ! recreate the bugs, or if false bugs are only used if actively selected.
+ logical :: debugging_tests ! If true, do additional calls resetting values to help debug the performance
+ ! of the open boundary condition code.
+ logical :: obsolete_param_set, param_set
+ logical :: zero_vorticity, freeslip_vorticity, computed_vorticity, specified_vorticity
+ logical :: zero_strain, freeslip_strain, computed_strain, specified_strain
! This include declares and sets the variable "version".
# include "version_variable.h"
- allocate(OBC)
+ call log_version(param_file, mdl, version, "Controls where open boundaries are located, "//&
+ "what kind of boundary condition to impose, and what data to apply, if any.", &
+ all_default=.false.)
+ ! Parameter OBC_NUMBER_OF_SEGMENTS is always logged.
+ call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", num_of_segs, &
+ "The number of open boundary segments.", default=0)
+ if (num_of_segs <= 0) & ! Do nothing if there is no OBC segments
+ return
- call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, &
- default=0, do_not_log=.true.)
- call log_version(param_file, mdl, version, &
- "Controls where open boundaries are located, what kind of boundary condition "//&
- "to impose, and what data to apply, if any.", &
- all_default=(OBC%number_of_segments<=0))
- call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, &
- "The number of open boundary segments.", &
- default=0)
- call get_param(param_file, mdl, "OBC_USER_CONFIG", config1, &
+ allocate(OBC)
+ OBC%number_of_segments = num_of_segs
+ call get_param(param_file, mdl, "OBC_USER_CONFIG", config, &
"A string that sets how the open boundary conditions are "//&
" configured: \n", default="none", do_not_log=.true.)
call get_param(param_file, mdl, "NK", OBC%ke, &
"The number of model layers", default=0, do_not_log=.true.)
- if (config1 /= "none" .and. config1 /= "dyed_obcs") OBC%user_BCs_set_globally = .true.
-
- if (OBC%number_of_segments > 0) then
- call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, &
- "If true, sets relative vorticity to zero on open boundaries.", &
- default=.false.)
- call get_param(param_file, mdl, "OBC_FREESLIP_VORTICITY", OBC%freeslip_vorticity, &
- "If true, sets the normal gradient of tangential velocity to "//&
- "zero in the relative vorticity on open boundaries. This cannot "//&
- "be true if another OBC_XXX_VORTICITY option is True.", default=.true.)
- call get_param(param_file, mdl, "OBC_COMPUTED_VORTICITY", OBC%computed_vorticity, &
- "If true, uses the external values of tangential velocity "//&
- "in the relative vorticity on open boundaries. This cannot "//&
- "be true if another OBC_XXX_VORTICITY option is True.", default=.false.)
- call get_param(param_file, mdl, "OBC_SPECIFIED_VORTICITY", OBC%specified_vorticity, &
- "If true, uses the external values of tangential velocity "//&
- "in the relative vorticity on open boundaries. This cannot "//&
- "be true if another OBC_XXX_VORTICITY option is True.", default=.false.)
- if ((OBC%zero_vorticity .and. OBC%freeslip_vorticity) .or. &
- (OBC%zero_vorticity .and. OBC%computed_vorticity) .or. &
- (OBC%zero_vorticity .and. OBC%specified_vorticity) .or. &
- (OBC%freeslip_vorticity .and. OBC%computed_vorticity) .or. &
- (OBC%freeslip_vorticity .and. OBC%specified_vorticity) .or. &
- (OBC%computed_vorticity .and. OBC%specified_vorticity)) &
- call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//&
- "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//&
- "and OBC_IMPORTED_VORTICITY can be True at once.")
- call get_param(param_file, mdl, "OBC_ZERO_STRAIN", OBC%zero_strain, &
- "If true, sets the strain used in the stress tensor to zero on open boundaries.", &
- default=.false.)
- call get_param(param_file, mdl, "OBC_FREESLIP_STRAIN", OBC%freeslip_strain, &
- "If true, sets the normal gradient of tangential velocity to "//&
- "zero in the strain use in the stress tensor on open boundaries. This cannot "//&
- "be true if another OBC_XXX_STRAIN option is True.", default=.true.)
- call get_param(param_file, mdl, "OBC_COMPUTED_STRAIN", OBC%computed_strain, &
- "If true, sets the normal gradient of tangential velocity to "//&
- "zero in the strain use in the stress tensor on open boundaries. This cannot "//&
- "be true if another OBC_XXX_STRAIN option is True.", default=.false.)
- call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN", OBC%specified_strain, &
- "If true, sets the normal gradient of tangential velocity to "//&
- "zero in the strain use in the stress tensor on open boundaries. This cannot "//&
- "be true if another OBC_XXX_STRAIN option is True.", default=.false.)
- if ((OBC%zero_strain .and. OBC%freeslip_strain) .or. &
- (OBC%zero_strain .and. OBC%computed_strain) .or. &
- (OBC%zero_strain .and. OBC%specified_strain) .or. &
- (OBC%freeslip_strain .and. OBC%computed_strain) .or. &
- (OBC%freeslip_strain .and. OBC%specified_strain) .or. &
- (OBC%computed_strain .and. OBC%specified_strain)) &
- call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//&
- "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//&
- "and OBC_IMPORTED_STRAIN can be True at once.")
- call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, &
- "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//&
- "viscosity term.", default=.false.)
- call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, &
- "If true, set the areas outside open boundaries to be land.", &
- default=.false.)
- call get_param(param_file, mdl, "RAMP_OBCS", OBC%ramp, &
- "If true, ramps from zero to the external values over time, with"//&
- "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far", &
- default=.false.)
- call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", OBC%ramp_timescale, &
- "If RAMP_OBCS is true, this sets the ramping timescale.", &
- units="days", default=1.0, scale=86400.0*US%s_to_T)
- call get_param(param_file, mdl, "OBC_TIDE_N_CONSTITUENTS", OBC%n_tide_constituents, &
- "Number of tidal constituents being added to the open boundary.", &
- default=0)
-
- if (OBC%n_tide_constituents > 0) then
- OBC%add_tide_constituents = .true.
+ if (config /= "none" .and. config /= "dyed_obcs") OBC%user_BCs_set_globally = .true.
+
+ ! Configuration for OBC relative vorticity.
+ ! Old setup method
+ obsolete_param_set = .false.
+ zero_vorticity = .false.
+ call read_param(param_file, "OBC_ZERO_VORTICITY", zero_vorticity, set=param_set)
+ obsolete_param_set = obsolete_param_set .or. param_set
+ freeslip_vorticity = .true.
+ call read_param(param_file, "OBC_FREESLIP_VORTICITY", freeslip_vorticity, set=param_set)
+ obsolete_param_set = obsolete_param_set .or. param_set
+ computed_vorticity = .false.
+ call read_param(param_file, "OBC_COMPUTED_VORTICITY", computed_vorticity, set=param_set)
+ obsolete_param_set = obsolete_param_set .or. param_set
+ specified_vorticity = .false.
+ call read_param(param_file, "OBC_SPECIFIED_VORTICITY", specified_vorticity, set=param_set)
+ obsolete_param_set = obsolete_param_set .or. param_set
+ if (obsolete_param_set) then
+ call MOM_error(WARNING, 'OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY'//&
+ ' and OBC_SPECIFIED_VORTICITY are obsolete, use OBC_VORTICITY_CONFIG instead.')
+ if ((zero_vorticity .and. freeslip_vorticity) .or. &
+ (zero_vorticity .and. computed_vorticity) .or. &
+ (zero_vorticity .and. specified_vorticity) .or. &
+ (freeslip_vorticity .and. computed_vorticity) .or. &
+ (freeslip_vorticity .and. specified_vorticity) .or. &
+ (computed_vorticity .and. specified_vorticity)) &
+ call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//&
+ "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//&
+ "and OBC_IMPORTED_VORTICITY can be True at once.")
+ ! "config" is set from OBC_XXX_VORTICITY if they are used.
+ if (zero_vorticity) then
+ config = 'zero'
+ elseif (freeslip_vorticity) then
+ config = 'freeslip'
+ elseif (computed_vorticity) then
+ config = 'computed'
+ elseif (specified_vorticity) then
+ config = 'specified'
+ else
+ config = 'none'
+ endif
+ else
+ config = 'freeslip' ! Default
+ endif
+ ! New setup method (overrides old method if specified)
+ call read_param(param_file, "OBC_VORTICITY_CONFIG", config)
+ call get_param(param_file, mdl, "OBC_VORTICITY_CONFIG", config, &
+ "Configuration for relative vorticity in momentum advection at open "//&
+ "boundaries. Options are: \n"// &
+ " \t none - No adjustment.\n"//&
+ " \t zero - Sets relative vorticity to zero.\n"//&
+ " \t freeslip - Sets the normal gradient of tangential velocity to zero.\n"//&
+ " \t computed - Computes the normal gradient of tangential velocity using\n"//&
+ " \t external values of tangential velocity.\n"//&
+ " \t specified - Uses the external values of the normal gradient of\n"//&
+ " \t tangential velocity.", default="freeslip", do_not_read=.true.)
+ select case (trim(config))
+ case ("none") ; OBC%vorticity_config = OBC_VORTICITY_NONE
+ case ("zero") ; OBC%vorticity_config = OBC_VORTICITY_ZERO
+ case ("freeslip") ; OBC%vorticity_config = OBC_VORTICITY_FREESLIP
+ case ("computed") ; OBC%vorticity_config = OBC_VORTICITY_COMPUTED
+ case ("specified") ; OBC%vorticity_config = OBC_VORTICITY_SPECIFIED
+ case default
+ call MOM_error(FATAL, "MOM_open_boundary: Unrecognized OBC_VORTICITY_CONFIG: "//trim(config))
+ end select
+
+ ! Configuration for OBC strain.
+ ! Old setup method
+ obsolete_param_set = .false.
+ zero_strain = .false.
+ call read_param(param_file, "OBC_ZERO_STRAIN", zero_strain, set=param_set)
+ obsolete_param_set = obsolete_param_set .or. param_set
+ freeslip_strain = .true.
+ call read_param(param_file, "OBC_FREESLIP_STRAIN", freeslip_strain, set=param_set)
+ obsolete_param_set = obsolete_param_set .or. param_set
+ computed_strain = .false.
+ call read_param(param_file, "OBC_COMPUTED_STRAIN", computed_strain, set=param_set)
+ obsolete_param_set = obsolete_param_set .or. param_set
+ specified_strain = .false.
+ call read_param(param_file, "OBC_SPECIFIED_STRAIN", specified_strain, set=param_set)
+ obsolete_param_set = obsolete_param_set .or. param_set
+ if (obsolete_param_set) then
+ call MOM_error(WARNING, 'OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN'//&
+ ' and OBC_SPECIFIED_STRAIN are obsolete, use OBC_STRAIN_CONFIG instead.')
+ if ((zero_strain .and. freeslip_strain) .or. &
+ (zero_strain .and. computed_strain) .or. &
+ (zero_strain .and. specified_strain) .or. &
+ (freeslip_strain .and. computed_strain) .or. &
+ (freeslip_strain .and. specified_strain) .or. &
+ (computed_strain .and. specified_strain)) &
+ call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//&
+ "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//&
+ "and OBC_IMPORTED_STRAIN can be True at once.")
+ ! "config" is set from OBC_XXX_STRAIN if they are used.
+ if (zero_strain) then
+ config = 'zero'
+ elseif (freeslip_strain) then
+ config = 'freeslip'
+ elseif (computed_strain) then
+ config = 'computed'
+ elseif (specified_strain) then
+ config = 'specified'
else
- OBC%add_tide_constituents = .false.
+ config = 'none'
endif
+ else
+ config = 'freeslip' ! Default
+ endif
+ ! New setup method (overrides old method if specified)
+ call read_param(param_file, "OBC_STRAIN_CONFIG", config)
+ call get_param(param_file, mdl, "OBC_STRAIN_CONFIG", config, &
+ "Configuration for strain in horizontal viscosity at open boundaries. "//&
+ "Options are: \n"// &
+ " \t none - No adjustment.\n"//&
+ " \t zero - Sets strain to zero.\n"//&
+ " \t freeslip - Sets the normal gradient of tangential velocity to zero.\n"//&
+ " \t computed - Computes the normal gradient of tangential velocity using\n"//&
+ " \t external values of tangential velocity.\n"//&
+ " \t specified - Uses the external values of the normal gradient of\n"//&
+ " \t tangential velocity.", default="freeslip", do_not_read=.true.)
+ select case (trim(config))
+ case ("none") ; OBC%strain_config = OBC_STRAIN_NONE
+ case ("zero") ; OBC%strain_config = OBC_STRAIN_ZERO
+ case ("freeslip") ; OBC%strain_config = OBC_STRAIN_FREESLIP
+ case ("computed") ; OBC%strain_config = OBC_STRAIN_COMPUTED
+ case ("specified") ; OBC%strain_config = OBC_STRAIN_SPECIFIED
+ case default
+ call MOM_error(FATAL, "MOM_open_boundary: Unrecognized OBC_STRAIN_CONFIG: "//trim(config))
+ end select
- call get_param(param_file, mdl, "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, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, &
+ "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//&
+ "viscosity term.", default=.false.)
+ call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, &
+ "If true, set the areas outside open boundaries to be land.", &
+ default=.false.)
+ call get_param(param_file, mdl, "RAMP_OBCS", OBC%ramp, &
+ "If true, ramps from zero to the external values over time, with "//&
+ "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far.", &
+ default=.false.)
+ call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", OBC%ramp_timescale, &
+ "If RAMP_OBCS is true, this sets the ramping timescale.", &
+ units="days", default=1.0, scale=86400.0*US%s_to_T)
+ call get_param(param_file, mdl, "OBC_TIDE_N_CONSTITUENTS", OBC%n_tide_constituents, &
+ "Number of tidal constituents being added to the open boundary.", &
+ default=0)
+ OBC%add_tide_constituents = (OBC%n_tide_constituents > 0)
+
+ call get_param(param_file, mdl, "DEBUG", debug, default=.false.)
+ call get_param(param_file, mdl, "DEBUG_OBCS", OBC%debug, &
"If true, do additional calls to help debug the performance "//&
"of the open boundary condition code.", &
- default=debug, do_not_log=.not.(debug_OBC.or.debug), debuggingParam=.true.)
-
- call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, &
+ default=.false., debuggingParam=.true.)
+ if (OBC%debug .and. (num_PEs() > 1)) &
+ call MOM_error(FATAL, "DEBUG_OBCS = True is currently only supported for single PE runs.")
+ call get_param(param_file, mdl, "OBC_DEBUGGING_TESTS", debugging_tests, &
+ "If true, do additional calls resetting certain values to help verify the correctness "//&
+ "of the open boundary condition code.", &
+ default=.false., old_name="DEBUG_OBC", debuggingParam=.true.)
+ call get_param(param_file, mdl, "NK_OBC_DEBUG", OBC%nk_OBC_debug, &
+ "The number of layers of OBC segment data to write out in full "//&
+ "when DEBUG_OBCS is true.", &
+ default=0, debuggingParam=.true., do_not_log=.not.OBC%debug)
+ call get_param(param_file, mdl, "OBC_REVERSE_SEGMENT_ORDER", OBC%reverse_segment_order, &
+ "If true, store the OBC segments internally and handle them in the reverse "//&
+ "order from that with which they are specified via external parameters to test "//&
+ "for dependencies on the order with which the OBC segments are applied.", &
+ default=.false., debuggingParam=.true., do_not_log=(OBC%number_of_segments<2))
+
+ call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, &
"A silly value of thicknesses used outside of open boundary "//&
"conditions for debugging.", units="m", default=0.0, scale=US%m_to_Z, &
- do_not_log=.not.OBC%debug, debuggingParam=.true.)
- call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, &
+ do_not_log=.not.debugging_tests, debuggingParam=.true.)
+ call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, &
"A silly value of velocities used outside of open boundary "//&
"conditions for debugging.", units="m/s", default=0.0, scale=US%m_s_to_L_T, &
- do_not_log=.not.OBC%debug, debuggingParam=.true.)
- call get_param(param_file, mdl, "EXTERIOR_OBC_BUG", OBC%exterior_OBC_bug, &
+ 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.)
- reentrant_x = .false.
- call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.)
- reentrant_y = .false.
- call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.)
-
- ! Allocate everything
- allocate(OBC%segment(1:OBC%number_of_segments))
- do l=1,OBC%number_of_segments
- OBC%segment(l)%Flather = .false.
- OBC%segment(l)%radiation = .false.
- OBC%segment(l)%radiation_tan = .false.
- OBC%segment(l)%radiation_grad = .false.
- OBC%segment(l)%oblique = .false.
- OBC%segment(l)%oblique_tan = .false.
- OBC%segment(l)%oblique_grad = .false.
- OBC%segment(l)%nudged = .false.
- OBC%segment(l)%nudged_tan = .false.
- OBC%segment(l)%nudged_grad = .false.
- OBC%segment(l)%specified = .false.
- OBC%segment(l)%specified_tan = .false.
- OBC%segment(l)%specified_grad = .false.
- OBC%segment(l)%open = .false.
- OBC%segment(l)%gradient = .false.
- OBC%segment(l)%values_needed = .false.
- OBC%segment(l)%u_values_needed = .false.
- OBC%segment(l)%uamp_values_needed = OBC%add_tide_constituents
- OBC%segment(l)%uphase_values_needed = OBC%add_tide_constituents
- OBC%segment(l)%v_values_needed = .false.
- OBC%segment(l)%vamp_values_needed = OBC%add_tide_constituents
- OBC%segment(l)%vphase_values_needed = OBC%add_tide_constituents
- OBC%segment(l)%t_values_needed = .false.
- OBC%segment(l)%s_values_needed = .false.
- OBC%segment(l)%z_values_needed = .false.
- OBC%segment(l)%zamp_values_needed = OBC%add_tide_constituents
- OBC%segment(l)%zphase_values_needed = OBC%add_tide_constituents
- OBC%segment(l)%g_values_needed = .false.
- OBC%segment(l)%direction = OBC_NONE
- OBC%segment(l)%is_N_or_S = .false.
- OBC%segment(l)%is_E_or_W = .false.
- OBC%segment(l)%is_E_or_W_2 = .false.
- OBC%segment(l)%Velocity_nudging_timescale_in = 0.0
- OBC%segment(l)%Velocity_nudging_timescale_out = 0.0
- OBC%segment(l)%num_fields = 0
- enddo
- allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=OBC_NONE)
- allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=OBC_NONE)
-
- do l = 1, OBC%number_of_segments
- write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") l
- call get_param(param_file, mdl, segment_param_str, segment_str, &
- "Documentation needs to be dynamic?????", &
- fail_if_missing=.true.)
- segment_str = remove_spaces(segment_str)
- if (segment_str(1:2) == 'I=') then
- call setup_u_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_y)
- elseif (segment_str(1:2) == 'J=') then
- call setup_v_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_x)
- else
- call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//&
- "Unable to interpret "//segment_param_str//" = "//trim(segment_str))
- endif
- enddo
+ default=enable_bugs)
+ call get_param(param_file, mdl, "OBC_HOR_INDEXING_BUG", OBC%hor_index_bug, &
+ "If true, recover set of a horizontal indexing bugs in the OBC code.", &
+ default=enable_bugs)
+ call get_param(param_file, mdl, "OBC_RESERVOIR_INIT_BUG", OBC%reservoir_init_bug, &
+ "If true, set the OBC tracer reservoirs at the startup of a new run from the "//&
+ "interior tracer concentrations regardless of properties that may be explicitly "//&
+ "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.)
+ call get_param(param_file, mdl, "OBC_TEMP_SALT_NEEDED_BUG", OBC%ts_needed_bug, &
+ "If true, recover a bug that OBC temperature and salinity can be ignored "//&
+ "even if they are registered tracers in the rest of the model.", default=.true.)
+ call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.)
+ call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.)
+
+ ! Allocate everything
+ allocate(OBC%segment(1:OBC%number_of_segments))
+ do n=1,OBC%number_of_segments
+ OBC%segment(n)%Flather = .false.
+ OBC%segment(n)%radiation = .false.
+ OBC%segment(n)%radiation_tan = .false.
+ OBC%segment(n)%radiation_grad = .false.
+ OBC%segment(n)%oblique = .false.
+ OBC%segment(n)%oblique_tan = .false.
+ OBC%segment(n)%oblique_grad = .false.
+ OBC%segment(n)%nudged = .false.
+ OBC%segment(n)%nudged_tan = .false.
+ OBC%segment(n)%nudged_grad = .false.
+ OBC%segment(n)%specified = .false.
+ OBC%segment(n)%specified_tan = .false.
+ OBC%segment(n)%specified_grad = .false.
+ OBC%segment(n)%open = .false.
+ OBC%segment(n)%gradient = .false.
+ OBC%segment(n)%direction = OBC_NONE
+ OBC%segment(n)%is_N_or_S = .false.
+ OBC%segment(n)%is_E_or_W = .false.
+ OBC%segment(n)%is_E_or_W_2 = .false.
+ OBC%segment(n)%Velocity_nudging_timescale_in = 0.0
+ OBC%segment(n)%Velocity_nudging_timescale_out = 0.0
+ OBC%segment(n)%num_fields = 0
+ enddo
+ allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0)
+ allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=0)
+ OBC%u_OBCs_on_PE = .false.
+ OBC%v_OBCs_on_PE = .false.
- ! Moved this earlier because time_interp_external_init needs to be called
- ! before anything that uses time_interp_external (such as initialize_segment_data)
- if (OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. &
- OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then
- ! Need this for ocean_only mode boundary interpolation.
- call time_interp_external_init()
+ do n=1,OBC%number_of_segments
+ n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n
+ write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") n
+ call get_param(param_file, mdl, segment_param_str, segment_str, &
+ "Documentation needs to be dynamic?????", &
+ fail_if_missing=.true.)
+ segment_str = remove_spaces(segment_str)
+ if (segment_str(1:2) == 'I=') then
+ call setup_u_point_obc(OBC, G, US, segment_str, n_seg, n, param_file, reentrant_y)
+ elseif (segment_str(1:2) == 'J=') then
+ call setup_v_point_obc(OBC, G, US, segment_str, n_seg, n, param_file, reentrant_x)
+ else
+ call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//&
+ "Unable to interpret "//segment_param_str//" = "//trim(segment_str))
endif
- ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) &
- ! call initialize_segment_data(G, OBC, param_file)
+ enddo
+ ! Set arrays indicating the segment number and segment direction, and also store the
+ ! range of indices within which various orientations of OBCs can be found on this PE.
+ call set_segnum_signs(OBC, G)
+
+ ! Moved this earlier because time_interp_external_init needs to be called
+ ! before anything that uses time_interp_external (such as initialize_segment_data)
+ if (OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. &
+ OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then
+ ! Need this for ocean_only mode boundary interpolation.
+ call time_interp_external_init()
+ endif
+ ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) &
+ ! call initialize_segment_data(G, OBC, param_file)
- if (open_boundary_query(OBC, apply_open_OBC=.true.)) then
- call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, &
+ if (open_boundary_query(OBC, apply_open_OBC=.true.)) then
+ call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, &
"The maximum magnitude of the baroclinic radiation velocity (or speed of "//&
"characteristics), in gridpoints per timestep. This is only "//&
"used if one of the open boundary segments is using Orlanski.", &
units="nondim", default=1.0)
- call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, &
+ call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, &
"The relative weighting for the baroclinic radiation "//&
"velocities (or speed of characteristics) at the new "//&
"time level (1) or the running mean (0) for velocities. "//&
"Valid values range from 0 to 1. This is only used if "//&
"one of the open boundary segments is using Orlanski.", &
units="nondim", default=0.3)
- endif
+ endif
- Lscale_in = 0.
- Lscale_out = 0.
- if (open_boundary_query(OBC, apply_open_OBC=.true.)) then
- call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, &
- "An effective length scale for restoring the tracer concentration "//&
- "at the boundaries to externally imposed values when the flow "//&
- "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L)
-
- call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, &
- "An effective length scale for restoring the tracer concentration "//&
- "at the boundaries to values from the interior when the flow "//&
- "is entering the domain.", units="m", default=0.0, scale=US%m_to_L)
- endif
+ Lscale_in = 0.
+ Lscale_out = 0.
+ if (open_boundary_query(OBC, apply_open_OBC=.true.)) then
+ call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, &
+ "An effective length scale for restoring the tracer concentration "//&
+ "at the boundaries to externally imposed values when the flow "//&
+ "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L)
+
+ call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, &
+ "An effective length scale for restoring the tracer concentration "//&
+ "at the boundaries to values from the interior when the flow "//&
+ "is entering the domain.", units="m", default=0.0, scale=US%m_to_L)
+ endif
- if (mask_outside) call mask_outside_OBCs(G, US, param_file, OBC)
+ if (mask_outside) call mask_outside_OBCs(G, US, param_file, OBC)
- ! All tracers are using the same restoring length scale for now, but we may want to make this
- ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained
- ! by data while others are well constrained - MJH.
- do l = 1, OBC%number_of_segments
- OBC%segment(l)%Tr_InvLscale_in = 0.0
- if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale_in = 1.0/Lscale_in
- OBC%segment(l)%Tr_InvLscale_out = 0.0
- if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out
- enddo
+ ! All tracers are using the same restoring length scale for now, but we may want to make this
+ ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained
+ ! by data while others are well constrained - MJH.
+ do n=1,OBC%number_of_segments
+ OBC%segment(n)%Tr_InvLscale_in = 0.0
+ if (Lscale_in>0.) OBC%segment(n)%Tr_InvLscale_in = 1.0/Lscale_in
+ OBC%segment(n)%Tr_InvLscale_out = 0.0
+ if (Lscale_out>0.) OBC%segment(n)%Tr_InvLscale_out = 1.0/Lscale_out
+ enddo
+
+ Lscale_in = 0.
+ Lscale_out = 0.
+ if (open_boundary_query(OBC, apply_open_OBC=.true.)) then
+ call get_param(param_file, mdl, "OBC_THICKNESS_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, &
+ "An effective length scale for restoring the layer thickness "//&
+ "at the boundaries to externally imposed values when the flow "//&
+ "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L)
+
+ call get_param(param_file, mdl, "OBC_THICKNESS_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, &
+ "An effective length scale for restoring the layer thickness "//&
+ "at the boundaries to values from the interior when the flow "//&
+ "is entering the domain.", units="m", default=0.0, scale=US%m_to_L)
+ endif
+
+ do n=1,OBC%number_of_segments
+ OBC%segment(n)%Th_InvLscale_in = 0.0
+ if (Lscale_in>0.) OBC%segment(n)%Th_InvLscale_in = 1.0/Lscale_in
+ OBC%segment(n)%Th_InvLscale_out = 0.0
+ if (Lscale_out>0.) OBC%segment(n)%Th_InvLscale_out = 1.0/Lscale_out
+ if (Lscale_in>0. .or. Lscale_out>0.) then
+ if (OBC%segment(n)%is_E_or_W_2) then
+ OBC%thickness_x_reservoirs_used = .true.
+ OBC%use_h_res = .true.
+ else
+ OBC%thickness_y_reservoirs_used = .true.
+ OBC%use_h_res = .true.
+ endif
+ endif
+ enddo
- call get_param(param_file, mdl, "REMAPPING_SCHEME", OBC%remappingScheme, &
- default=remappingDefaultScheme, do_not_log=.true.)
- call get_param(param_file, mdl, "OBC_REMAPPING_SCHEME", OBC%remappingScheme, &
- "This sets the reconstruction scheme used "//&
- "for OBC vertical remapping for all variables. "//&
- "It can be one of the following schemes: \n"//&
- trim(remappingSchemesDoc), default=OBC%remappingScheme)
- call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", OBC%check_reconstruction, &
- "If true, cell-by-cell reconstructions are checked for "//&
- "consistency and if non-monotonicity or an inconsistency is "//&
- "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.)
- call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", OBC%check_remapping, &
- "If true, the results of remapping are checked for "//&
- "conservation and new extrema and if an inconsistency is "//&
- "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.)
- call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, &
- "If true, read external OBC data on the supergrid.", &
- default=.false.)
- call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", OBC%force_bounds_in_subcell, &
- "If true, the values on the intermediate grid used for remapping "//&
- "are forced to be bounded, which might not be the case due to "//&
- "round off.", default=.false.,do_not_log=.true.)
- call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
+ call get_param(param_file, mdl, "REMAPPING_SCHEME", OBC%remappingScheme, &
+ default=remappingDefaultScheme, do_not_log=.true.)
+ call get_param(param_file, mdl, "OBC_REMAPPING_SCHEME", OBC%remappingScheme, &
+ "This sets the reconstruction scheme used "//&
+ "for OBC vertical remapping for all variables. "//&
+ "It can be one of the following schemes: \n"//&
+ trim(remappingSchemesDoc), default=OBC%remappingScheme)
+ call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", OBC%check_reconstruction, &
+ "If true, cell-by-cell reconstructions are checked for "//&
+ "consistency and if non-monotonicity or an inconsistency is "//&
+ "detected then a FATAL error is issued.", default=.false., do_not_log=.true.)
+ call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", OBC%check_remapping, &
+ "If true, the results of remapping are checked for "//&
+ "conservation and new extrema and if an inconsistency is "//&
+ "detected then a FATAL error is issued.", default=.false., do_not_log=.true.)
+ call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, &
+ "If true, read external OBC data on the supergrid.", &
+ default=.false.)
+ call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", OBC%force_bounds_in_subcell, &
+ "If true, the values on the intermediate grid used for remapping "//&
+ "are forced to be bounded, which might not be the case due to "//&
+ "round off.", default=.false., do_not_log=.true.)
+ call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
"This sets the default value for the various _ANSWER_DATE parameters.", &
default=99991231)
- call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", OBC%remap_answer_date, &
+ call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", OBC%remap_answer_date, &
"The vintage of the expressions and order of arithmetic to use for remapping. "//&
"Values below 20190101 result in the use of older, less accurate expressions "//&
"that were in use at the end of 2018. Higher values result in the use of more "//&
"robust and accurate forms of mathematically equivalent expressions.", &
default=default_answer_date)
- call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", OBC%om4_remap_via_sub_cells, &
- do_not_log=.true., default=.true.)
+ call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", OBC%om4_remap_via_sub_cells, &
+ do_not_log=.true., default=.true.)
- call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", OBC%om4_remap_via_sub_cells, &
+ call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", OBC%om4_remap_via_sub_cells, &
"If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//&
"See REMAPPING_USE_OM4_SUBCELLS for more details. "//&
"We recommend setting this option to false.", default=OBC%om4_remap_via_sub_cells)
- endif ! OBC%number_of_segments > 0
-
- ! Safety check
+ ! Safety check
if ((OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) .and. &
.not.G%symmetric ) call MOM_error(FATAL, &
"MOM_open_boundary, open_boundary_config: "//&
@@ -752,6 +939,8 @@ subroutine open_boundary_setup_vert(GV, US, OBC)
if (associated(OBC)) then
if (OBC%number_of_segments > 0) then
+ ! Set up vertical remapping for open boundaries. Remapping happens independently on each PE,
+ ! so this block could be skipped for PEs without open boundary conditions that use remapping.
if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then
dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10
elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then
@@ -776,52 +965,277 @@ subroutine open_boundary_setup_vert(GV, US, OBC)
end subroutine open_boundary_setup_vert
-!> Allocate space for reading OBC data from files. It sets up the required vertical
-!! remapping. In the process, it does funky stuff with the MPI processes.
-subroutine initialize_segment_data(G, GV, US, OBC, PF)
- type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+!> Determine which physical fields are required for this segment based on boundary-condition type
+!! and segment orientation. Also enable groups of physical fields required by tides or thermodynamics.
+!! Note the tidal group could be further narrowed based on modes.
+subroutine segment_determine_required_fields(segment, tides, temp_salt)
+ type(OBC_segment_type), intent(inout) :: segment !< OBC segment
+ logical, optional, intent(in) :: tides !< Switch for tidal variables
+ logical, optional, intent(in) :: temp_salt !< Switch for thermodynamic variables
+
+ ! Local variables
+ logical :: use_tide ! Local switch for tidal variables
+ logical :: use_temp ! Local switch for thermodynamic variables
+ integer :: m
+ integer :: F_Vn, F_Vt, F_G
+ integer, parameter :: &
+ tide_idx(6) = (/ F_UAMP, F_UPHASE, F_VAMP, F_VPHASE, F_ZAMP, F_ZPHASE /), & ! Indices for tides
+ temp_idx(2) = (/ F_T, F_S /) ! Indices for thermodynamics
+
+ if (.not. associated(segment%field)) &
+ call MOM_error(FATAL, 'segment_determine_required_fields: segment%field is not allocated.')
+
+ use_tide = .false. ; if (present(tides)) use_tide = tides
+ use_temp = .false. ; if (present(temp_salt)) use_temp = temp_salt
+
+ ! Normal, tangential and gradient depend on segment orientation.
+ if (segment%is_E_or_W_2) then
+ F_Vn = F_U ; F_Vt = F_V ; F_G = F_VX
+ else
+ F_Vn = F_V ; F_Vt = F_U ; F_G = F_UY
+ endif
+ if (segment%Flather) &
+ segment%field(F_Z)%required = .true.
+
+ if (segment%Flather .or. segment%nudged .or. segment%specified) &
+ segment%field(F_Vn)%required = .true.
+
+ if (segment%nudged_tan .or. segment%specified_tan) &
+ segment%field(F_Vt)%required = .true.
+
+ if (segment%nudged_grad .or. segment%specified_grad) &
+ segment%field(F_G)%required = .true.
+
+ if (use_tide) then ; do m = 1, size(tide_idx)
+ segment%field(tide_idx(m))%required = .true.
+ enddo ; endif
+
+ if (use_temp) then ; do m = 1, size(temp_idx)
+ segment%field(temp_idx(m))%required = .true.
+ enddo ; endif
+
+end subroutine segment_determine_required_fields
+
+!> Find physical field index from name
+integer function find_phys_field_index(name)
+ character(len=*), intent(in) :: name !< Field name
+
+ ! Local variables
+ integer :: i
+
+ find_phys_field_index = 0
+ do i = 1, NUM_PHYS_FIELDS ; if (trim(name) == PHYS_FIELD_NAMES(i)) then
+ find_phys_field_index = i
+ return
+ endif ; enddo
+end function find_phys_field_index
+
+!> Set global flag OBC%any_needs_IO_for_data.
+subroutine OBC_any_IO(OBC)
+ type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure
+
+ ! Local variables
+ integer :: m, n
+ logical :: use_IO
+
+ use_IO = .false.
+ do n=1,OBC%number_of_segments
+ do m=1,OBC%segment(n)%num_fields
+ if (OBC%segment(n)%field(m)%use_IO) then
+ use_IO = .true.
+ exit
+ endif
+ enddo
+ if (use_IO) exit
+ enddo
+
+ OBC%any_needs_IO_for_data = any_across_PEs(use_IO)
+end subroutine OBC_any_IO
+
+!> Allocate data (buffer_src, buffer_dst and dz_src) for a field at an OBC segment.
+subroutine allocate_segment_field_data(field, OBC, segment, US, inputdir, filename, varname, &
+ suffix, value, turns, nz)
+ type(OBC_segment_data_type), &
+ intent(inout) :: field !< A field of the segment
+ type(ocean_OBC_type), intent(in) :: OBC !< Open boundary control structure
+ type(OBC_segment_type), intent(inout) :: segment !< Segment to work on
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ character(len=*), intent(in) :: inputdir !< The directory of input files
+ character(len=*), intent(in) :: filename !< Input file name
+ character(len=*), intent(in) :: varname !< Variable name in the input file
+ character(len=*), intent(in) :: suffix !< Variable name suffix, "_segment_xxx"
+ real, intent(in) :: value !< Unscaled specified value of the field [a]
+ integer, intent(in) :: turns !< Number of quarter turns of the grid
+ integer, intent(in) :: nz !< Default k-axis size in buffer_dst
+
+ ! Local variables
+ character(len=256) :: full_filename, full_varname ! Full filename and varname
+ character(len=512) :: mesg ! Error message
+ real :: init_value_dst ! Initial value for allocated buffer_dst array [a]
+ integer :: qturns ! The number of quarter turns in the range of 0 to 3
+ integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB ! Aliases of segment geometry indices
+ integer, dimension(4) :: siz, siz_check ! Four-dimensional shape of a variable in input file
+ integer :: dim ! Loop index for siz/siz_check
+ integer :: nk_dst ! k-axis size of buffer_dst
+
+ if (.not. segment%on_pe) return
+
+ isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
+ jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB
+ nk_dst = nz
+
+ qturns = modulo(turns, 4)
+
+ field%on_face = field_is_on_face(field%name, segment%is_E_or_W)
+ ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input
+ ! value is rescaled there.
+ field%scale = scale_factor_from_name(field%name, US, segment%tr_Reg)
+ field%use_IO = (trim(filename) /= 'none')
+
+ if (field%use_IO) then
+ full_filename = trim(inputdir) // trim(filename)
+ full_varname = trim(varname) // trim(suffix)
+
+ if (.not.file_exists(full_filename)) &
+ call MOM_error(FATAL," Unable to open OBC file " // trim(full_filename))
+
+ call field_size(full_filename, full_varname, siz, no_domain=.true.)
+ field%nk_src = siz(3)
+
+ if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then
+ write(mesg, '("Brushcutter mode sizes ",I0," ",I0)') siz(1), siz(2)
+ call MOM_error(WARNING, mesg // " " // trim(full_filename) // " " // trim(full_varname))
+ call MOM_error(FATAL,'segment data are not on the supergrid')
+ endif
+
+ ! Allocate src array
+ if (.not.field%on_face) then
+ allocate(field%buffer_src(IsdB:IedB, JsdB:JedB, field%nk_src), source=0.0)
+ elseif (segment%is_E_or_W) then
+ allocate(field%buffer_src(IsdB:IedB, jsd:jed, field%nk_src), source=0.0)
+ else
+ allocate(field%buffer_src(isd:ied, JsdB:JedB, field%nk_src), source=0.0)
+ endif
+
+ field%handle = init_external_field(trim(full_filename), trim(full_varname), &
+ ignore_axis_atts=.true., threading=SINGLE_FILE)
+
+ if ((field%nk_src > 1) .and. (.not. field_is_tidal(field%name))) then ! nk_src is depth
+ full_varname = 'dz_' // trim(full_varname)
+ call field_size(full_filename, full_varname, siz_check, no_domain=.true.)
+ do dim = 1, 4 ; if (siz(dim) /= siz_check(dim)) &
+ call MOM_error(FATAL, "'dz' field size is inconsistent with "//&
+ "its corresponding variable.")
+ enddo
+
+ if (.not.field%on_face) then
+ allocate(field%dz_src(IsdB:IedB, JsdB:JedB, field%nk_src), source=0.0)
+ elseif (segment%is_E_or_W) then
+ allocate(field%dz_src(IsdB:IedB, jsd:jed, field%nk_src), source=0.0)
+ else
+ allocate(field%dz_src(isd:ied, JsdB:JedB, field%nk_src), source=0.0)
+ endif
+ field%dz_handle = init_external_field(trim(full_filename), trim(full_varname), &
+ ignore_axis_atts=.true., threading=SINGLE_FILE)
+
+ elseif (field_is_tidal(field%name)) then ! nk_src is constituent for tidal variables
+ ! expect third dimension to be number of constituents in MOM_input
+ if (OBC%add_tide_constituents .and. (field%nk_src /= OBC%n_tide_constituents)) &
+ call MOM_error(FATAL, 'Number of constituents in input data is not '//&
+ 'the same as the number specified')
+ nk_dst = field%nk_src
+
+ else ! nk_src = 1
+ nk_dst = 1
+
+ endif
+
+ init_value_dst = 0.0
+ else ! This data is not being read from a file.
+ field%value = field%scale * value
+ ! Change the sign of the specified velocities, depending on the number of quarter turns of the grid.
+ if ( ( ((field%name == 'U') .or. (field%name == 'Uamp')) .and. &
+ ((qturns == 1) .or. (qturns == 2)) ) .or. &
+ ( ((field%name == 'V') .or. (field%name == 'Vamp')) .and. &
+ ((qturns == 3) .or. (qturns == 2)) ) ) &
+ field%value = -field%value
+
+ ! Check if this is a tidal field. If so, the number of expected constituents must be 1.
+ if (field_is_tidal(field%name)) then
+ if (OBC%add_tide_constituents .and. (OBC%n_tide_constituents > 1)) &
+ call MOM_error(FATAL, 'Only one constituent is supported when specifying '//&
+ 'tidal boundary conditions by value rather than file.')
+ nk_dst = 1
+ endif
+
+ if (field%name == 'SSH') &
+ nk_dst = 1
+
+ init_value_dst = field%value
+ endif
+
+ ! Allocate buffer_dst array
+ if (.not.field%on_face) then
+ allocate(field%buffer_dst(IsdB:IedB, JsdB:JedB, nk_dst), source=init_value_dst)
+ elseif (segment%is_E_or_W) then
+ allocate(field%buffer_dst(IsdB:IedB, jsd:jed, nk_dst), source=init_value_dst)
+ else
+ allocate(field%buffer_dst(isd:ied, JsdB:JedB, nk_dst), source=init_value_dst)
+ endif
+
+ ! This can be removed.
+ if (field%name == 'TEMP') segment%temp_segment_data_exists = .true.
+ if (field%name == 'SALT') segment%salt_segment_data_exists = .true.
+
+end subroutine allocate_segment_field_data
+
+!> Get and store properties about the fields on the OBC segments and allocate space for reading
+!! OBC data from files. In the process, it does funky stuff with the MPI processes.
+subroutine initialize_segment_data(GV, US, OBC, PF, turns, use_temperature)
type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure
type(param_file_type), intent(in) :: PF !< Parameter file handle
+ integer, intent(in) :: turns !< Number of quarter turns of the grid
+ logical, intent(in) :: use_temperature !< If true, temperature and
+ !! salinity used as state variables.
- integer :: n, m, num_fields, mm
+ ! Local variables
+ integer :: n, n_seg, m, num_manifest_fields, mm
character(len=1024) :: segstr
character(len=256) :: filename
- character(len=20) :: segnam, suffix
- character(len=32) :: fieldname
+ character(len=20) :: segname, suffix
+ character(len=32) :: varname
real :: value ! A value that is parsed from the segment data string [various units]
- character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names
+ character(len=32), dimension(NUM_PHYS_FIELDS) :: phys_inputs ! input physical field names
+ integer, dimension(NUM_PHYS_FIELDS) :: phys_idx ! input physical field indices to PHYS_FIELD_NAMES
+ character(len=32) :: bgc_input ! segment field names
character(len=128) :: inputdir
type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list
character(len=256) :: mesg ! Message for error messages.
- integer, dimension(4) :: siz,siz2
- integer :: is, ie, js, je
- integer :: isd, ied, jsd, jed
- integer :: IsdB, IedB, JsdB, JedB
integer, dimension(:), allocatable :: saved_pelist
integer :: current_pe
integer, dimension(1) :: single_pelist
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.
+ logical :: check_ts_needed ! Check if temperature and salinity are explicitly specified.
+ integer :: idx
+ character(len=256) :: routine_name ! Name of this subroutine
- is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
+ if (OBC%user_BCs_set_globally) return
+
+ routine_name = trim(mdl) // ', initialize_segment_data'
- ! There is a problem with the order of the OBC initialization
- ! with respect to ALE_init. Currently handling this by copying the
- ! param file so that I can use it later in step_MOM in order to finish
- ! initializing segments on the first step.
+ OBC%update_OBC = .true. ! Data is time-dependent if not using user BC.
+
+ check_ts_needed = use_temperature .and. (.not. OBC%ts_needed_bug)
call get_param(PF, mdl, "INPUTDIR", inputdir, default=".")
inputdir = slasher(inputdir)
- if (OBC%user_BCs_set_globally) return
-
! Try this here just for the documentation. It is repeated below.
- do n=1, OBC%number_of_segments
- write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n
- call get_param(PF, mdl, segnam, segstr, 'OBC segment docs')
+ do n=1,OBC%number_of_segments
+ write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n
+ call get_param(PF, mdl, segname, segstr, 'OBC segment docs')
enddo
!< temporarily disable communication in order to read segment data independently
@@ -832,310 +1246,215 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF)
single_pelist(1) = current_pe
call Set_PElist(single_pelist)
- do n=1, OBC%number_of_segments
- segment => OBC%segment(n)
- if (.not. segment%values_needed) cycle
+ do n=1,OBC%number_of_segments
+ n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n
+ segment => OBC%segment(n_seg)
+
+ if (.not. segment%on_pe) cycle
- write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n
- write(suffix,"('_segment_',i3.3)") n
+ write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n
+ write(suffix, "('_segment_',i3.3)") n
! needs documentation !! Yet, unsafe for now, causes grief for
! MOM_parameter_docs in circle_obcs on two processes.
-! call get_param(PF, mdl, segnam, segstr, 'xyz')
+ ! call get_param(PF, mdl, segname, segstr, 'xyz')
! Clear out any old values
segstr = ''
- call get_param(PF, mdl, segnam, segstr)
+ call get_param(PF, mdl, segname, segstr)
if (segstr == '') then
- write(mesg,'("No OBC_SEGMENT_XXX_DATA string for OBC segment ",I3)') n
+ write(mesg,'("No OBC_SEGMENT_XXX_DATA string for OBC segment ",I0)') n
call MOM_error(FATAL, mesg)
endif
- call parse_segment_manifest_str(trim(segstr), num_fields, fields)
- if (num_fields == 0) then
- call MOM_mesg('initialize_segment_data: num_fields = 0')
- cycle ! cycle to next segment
- endif
-
- !There are OBC%num_obgc_tracers obgc tracers are there that are not listed in param file
- segment%num_fields = num_fields + OBC%num_obgc_tracers
+ segment%num_fields = NUM_PHYS_FIELDS + OBC%num_obgc_tracers
allocate(segment%field(segment%num_fields))
- segment%temp_segment_data_exists = .false.
- segment%salt_segment_data_exists = .false.
-!!
-! CODE HERE FOR OTHER OPTIONS (CLAMPED, NUDGED,..)
-!!
+ ! Initialize physical fields
+ do m = 1, NUM_PHYS_FIELDS
+ segment%field(m)%name = PHYS_FIELD_NAMES(m) ! The order of physical fields is fixed.
+ segment%field(m)%bgc_tracer = .false.
+ segment%field(m)%required = .false.
+ segment%field(m)%use_IO = .false.
+ segment%field(m)%tr_index = -1
+ enddo
+ segment%field(F_T)%tr_index = 1 ! Temperature tracer index is hard-coded.
+ segment%field(F_S)%tr_index = 2 ! Salinity tracer index is hard-coded.
- 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
+ call segment_determine_required_fields(segment, tides=OBC%add_tide_constituents, &
+ temp_salt=check_ts_needed)
- 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
- call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname)
- 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.
- 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.
- do mm=1,num_fields
- if (trim(fields(m)) == trim(fields(mm))) then
- if (is_root_pe()) &
- call MOM_error(FATAL,"MOM_open_boundary:initialize_segment_data(): obgc tracer " //trim(fields(m))// &
- " appears in OBC_SEGMENT_XXX_DATA string in MOM6 param file. This is not supported!")
- endif
- enddo
+ ! Parse and find available physical fields
+ call parse_segment_manifest_str(trim(segstr), num_manifest_fields, phys_inputs)
+
+ phys_idx(:) = -1
+ do m = 1, num_manifest_fields
+ idx = find_phys_field_index(rotated_field_name(trim(phys_inputs(m)), turns))
+ if (idx == 0) then
+ write(mesg,'("OBC segment ",I0," has an unknown input field: ",a)') n, trim(phys_inputs(m))
+ call MOM_error(FATAL, trim(routine_name) // ", " // trim(mesg))
endif
- if (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.)
-! 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 ((.not. segment%field(idx)%required) .and. &
+ ((.not. (idx == F_T .or. idx == F_S)) .or. check_ts_needed)) then
+ write(mesg,'("OBC segment ",I0," has an unnecessary field: ",a)') &
+ n, trim(phys_inputs(m))
+ call MOM_error(WARNING, trim(mesg))
+ ! Unnecessary field is allowed and allocated for now.
+ ! Otherwise, the next line can be uncommented.
+ ! cycle
+ endif
+ phys_idx(idx) = m
+ enddo
- if (siz(1)>1) then
- if (OBC%brushcutter_mode) then
- siz2(1) = (siz(1)-1)/2
- else
- siz2(1) = siz(1)
- endif
- endif
- siz2(2) = 1
- if (siz(2)>1) then
- if (OBC%brushcutter_mode) then
- siz2(2) = (siz(2)-1)/2
- else
- siz2(2) = siz(2)
- endif
- endif
- siz2(3) = siz(3)
+ ! These can be removed.
+ segment%temp_segment_data_exists = .false.
+ segment%salt_segment_data_exists = .false.
- if (segment%is_E_or_W) then
- if (segment%field(m)%name == 'V') then
- allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3)))
- segment%v_values_needed = .false.
- elseif (segment%field(m)%name == 'Vamp') then
- allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3)))
- segment%vamp_values_needed = .false.
- segment%vamp_index = m
- elseif (segment%field(m)%name == 'Vphase') then
- allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3)))
- segment%vphase_values_needed = .false.
- segment%vphase_index = m
- elseif (segment%field(m)%name == 'DVDX') then
- allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3)))
- segment%g_values_needed = .false.
- else
- allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz2(3)))
- if (segment%field(m)%name == 'U') then
- segment%u_values_needed = .false.
- elseif (segment%field(m)%name == 'Uamp') then
- segment%uamp_values_needed = .false.
- segment%uamp_index = m
- elseif (segment%field(m)%name == 'Uphase') then
- segment%uphase_values_needed = .false.
- segment%uphase_index = m
- elseif (segment%field(m)%name == 'SSH') then
- segment%z_values_needed = .false.
- elseif (segment%field(m)%name == 'SSHamp') then
- segment%zamp_values_needed = .false.
- segment%zamp_index = m
- elseif (segment%field(m)%name == 'SSHphase') then
- segment%zphase_values_needed = .false.
- segment%zphase_index = m
- elseif (segment%field(m)%name == 'TEMP') then
- segment%t_values_needed = .false.
- elseif (segment%field(m)%name == 'SALT') then
- segment%s_values_needed = .false.
- endif
- endif
- else
- if (segment%field(m)%name == 'U') then
- allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3)))
- segment%u_values_needed = .false.
- elseif (segment%field(m)%name == 'DUDY') then
- allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3)))
- segment%g_values_needed = .false.
- elseif (segment%field(m)%name == 'Uamp') then
- allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3)))
- segment%uamp_values_needed = .false.
- segment%uamp_index = m
- elseif (segment%field(m)%name == 'Uphase') then
- allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3)))
- segment%uphase_values_needed = .false.
- segment%uphase_index = m
- else
- allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz2(3)))
- if (segment%field(m)%name == 'V') then
- segment%v_values_needed = .false.
- elseif (segment%field(m)%name == 'Vamp') then
- segment%vamp_values_needed = .false.
- segment%vamp_index = m
- elseif (segment%field(m)%name == 'Vphase') then
- segment%vphase_values_needed = .false.
- segment%vphase_index = m
- elseif (segment%field(m)%name == 'SSH') then
- segment%z_values_needed = .false.
- elseif (segment%field(m)%name == 'SSHamp') then
- segment%zamp_values_needed = .false.
- segment%zamp_index = m
- elseif (segment%field(m)%name == 'SSHphase') then
- segment%zphase_values_needed = .false.
- segment%zphase_index = m
- elseif (segment%field(m)%name == 'TEMP') then
- segment%t_values_needed = .false.
- elseif (segment%field(m)%name == 'SALT') then
- segment%s_values_needed = .false.
- endif
- endif
- endif
- segment%field(m)%buffer_src(:,:,:) = 0.0
- segment%field(m)%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
- 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)
- segment%field(m)%value = segment%field(m)%scale * value
- segment%field(m)%use_IO = .false.
-
- ! Check if this is a tidal field. If so, the number
- ! of expected constituents must be 1.
- if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then
- if (OBC%n_tide_constituents > 1 .and. OBC%add_tide_constituents) then
- call MOM_error(FATAL, 'Only one constituent is supported when specifying '//&
- 'tidal boundary conditions by value rather than file.')
- endif
- endif
- if (segment%field(m)%name == 'U') then
- segment%u_values_needed = .false.
- elseif (segment%field(m)%name == 'Uamp') then
- segment%uamp_values_needed = .false.
- segment%uamp_index = m
- elseif (segment%field(m)%name == 'Uphase') then
- segment%uphase_values_needed = .false.
- segment%uphase_index = m
- elseif (segment%field(m)%name == 'V') then
- segment%v_values_needed = .false.
- elseif (segment%field(m)%name == 'Vamp') then
- segment%vamp_values_needed = .false.
- segment%vamp_index = m
- elseif (segment%field(m)%name == 'Vphase') then
- segment%vphase_values_needed = .false.
- segment%vphase_index = m
- elseif (segment%field(m)%name == 'SSH') then
- segment%z_values_needed = .false.
- elseif (segment%field(m)%name == 'SSHamp') then
- segment%zamp_values_needed = .false.
- segment%zamp_index = m
- elseif (segment%field(m)%name == 'SSHphase') then
- segment%zphase_values_needed = .false.
- segment%zphase_index = m
- elseif (segment%field(m)%name == 'TEMP') then
- segment%t_values_needed = .false.
- elseif (segment%field(m)%name == 'SALT') then
- segment%s_values_needed = .false.
- elseif (segment%field(m)%name == 'DVDX' .or. segment%field(m)%name == 'DUDY') then
- segment%g_values_needed = .false.
- endif
+ ! Allocate physical fields
+ do m = 1, NUM_PHYS_FIELDS
+ if (segment%field(m)%required .and. (phys_idx(m) < 0)) then
+ write(mesg,'("OBC segment ",I0," requires field: ",a)') n, trim(segment%field(m)%name)
+ call MOM_error(FATAL, trim(routine_name) // ", " // trim(mesg))
+ endif
+ if ((phys_idx(m) > 0)) then ! Field is found in input, even if not required
+ call parse_segment_data_str(trim(segstr), phys_idx(m), trim(phys_inputs(phys_idx(m))), &
+ value, filename, varname)
+ call allocate_segment_field_data(segment%field(m), OBC, segment, US, &
+ inputdir, filename, varname, suffix, value, turns, GV%ke)
endif
enddo
- if (segment%u_values_needed .or. segment%uamp_values_needed .or. segment%uphase_values_needed .or. &
- segment%v_values_needed .or. segment%vamp_values_needed .or. segment%vphase_values_needed .or. &
- segment%t_values_needed .or. segment%s_values_needed .or. segment%g_values_needed .or. &
- segment%z_values_needed .or. segment%zamp_values_needed .or. segment%zphase_values_needed ) then
- write(mesg,'("Values needed for OBC segment ",I3)') n
- call MOM_error(FATAL, mesg)
- endif
- enddo
+
+ ! Allocate BGC tracer fields
+ obgc_segments_props_list => OBC%obgc_segments_props ! pointer to the head node
+ do m = NUM_PHYS_FIELDS+1, segment%num_fields
+ segment%field(m)%bgc_tracer = .true.
+ ! Query the obgc segment properties by traversing the linked list
+ call get_obgc_segments_props(obgc_segments_props_list, bgc_input, filename, varname, &
+ segment%field(m)%resrv_lfac_in, segment%field(m)%resrv_lfac_out)
+ ! Make sure the obgc tracer is not specified in the MOM6 param file too.
+ do mm=1,num_manifest_fields ; if (trim(bgc_input) == trim(phys_inputs(mm))) then
+ write(mesg,'("Input parameter for OBC segment ",I0," contains a BGC tracer: ", A)') &
+ n, trim(bgc_input)
+ call MOM_error(FATAL, trim(routine_name) // ", " // trim(mesg))
+ endif ; enddo
+ segment%field(m)%name = rotated_field_name(bgc_input, turns)
+ segment%field(m)%tr_index = get_tracer_index(segment, trim(segment%field(m)%name))
+ call allocate_segment_field_data(segment%field(m), OBC, segment, US, &
+ inputdir, filename, varname, suffix, 0.0, turns, GV%ke)
+ enddo
+
+ ! write(stderr, '(A)') trim(suffix)//" segment checksum"
+ if (OBC%debug) call chksum_OBC_segment_data(OBC%segment(n_seg), GV, US, OBC%nk_OBC_debug, n)
+
+ enddo ! n-loop for segments
call Set_PElist(saved_pelist)
! Determine global IO data requirement patterns.
- 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)
- 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)
-
+ call OBC_any_IO(OBC)
end subroutine initialize_segment_data
+!> Determine whether a particular field is descretized at the normal-velocity faces of an open
+!! boundary condition segment.
+logical function field_is_on_face(name, is_E_or_W)
+ character(len=*), intent(in) :: name !< The OBC segment data name to interpret
+ logical, intent(in) :: is_E_or_W !< This is true for an eastern or western open boundary condition
+
+ field_is_on_face = .true.
+ if (is_E_or_W) then
+ if ((name == 'V') .or. (name == 'Vamp') .or. (name == 'Vphase') .or. (name == 'DVDX')) &
+ field_is_on_face = .false.
+ else
+ if ((name == 'U') .or. (name == 'Uamp') .or. (name == 'Uphase') .or. (name == 'DUDY')) &
+ field_is_on_face = .false.
+ endif
+end function field_is_on_face
+
+!> Determine based on its name whether a particular field a barotropic tidal field, for which the
+!! third dimension is the tidal constituent rather than a vertical axis
+logical function field_is_tidal(name)
+ character(len=*), intent(in) :: name !< The OBC segment data name to interpret
+
+ field_is_tidal = ((index(name, 'phase') > 0) .or. (index(name, 'amp') > 0))
+end function field_is_tidal
+
+!> This subroutine sets the sign of the OBC%segnum_u and OBC%segnum_v arrays to indicate the
+!! direction of the faces - positive for logically eastern or northern OBCs and neagative
+!! for logically western or southern OBCs, or zero on non-OBC points. Also store information
+!! about which orientations of OBCs ar on this PE and the range of indices within which the
+!! various orientations of OBCs can be found on this PE.
+subroutine set_segnum_signs(OBC, G)
+ type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure, perhaps on a rotated grid.
+ type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure used by OBC
+
+ integer :: i, j
+
+ OBC%u_OBCs_on_PE = .false. ; OBC%v_OBCs_on_PE = .false.
+ do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB
+ OBC%segnum_u(I,j) = abs(OBC%segnum_u(I,j))
+ if (abs(OBC%segnum_u(I,j)) > 0) then
+ OBC%u_OBCs_on_PE = .true.
+ if (OBC%segment(abs(OBC%segnum_u(I,j)))%direction == OBC_DIRECTION_W) &
+ OBC%segnum_u(I,j) = -abs(OBC%segnum_u(I,j))
+ endif
+ enddo ; enddo
+ do J=G%JsdB,G%JedB ; do i=G%isd,G%ied
+ OBC%segnum_v(i,J) = abs(OBC%segnum_v(i,J))
+ if (abs(OBC%segnum_v(i,J)) > 0) then
+ OBC%v_OBCs_on_PE = .true.
+ if (OBC%segment(abs(OBC%segnum_v(i,J)))%direction == OBC_DIRECTION_S) &
+ OBC%segnum_v(i,J) = -abs(OBC%segnum_v(i,J))
+ endif
+ enddo ; enddo
+
+ ! Determine the maximum and minimum index range for various directions of OBC points on this PE
+ ! by first setting these one point outside of the wrong side of the domain.
+ OBC%Is_u_W_obc = G%IedB + 1 ; OBC%Ie_u_W_obc = G%IsdB - 1
+ OBC%js_u_W_obc = G%jed + 1 ; OBC%je_u_W_obc = G%jsd - 1
+ OBC%Is_u_E_obc = G%IedB + 1 ; OBC%Ie_u_E_obc = G%IsdB - 1
+ OBC%js_u_E_obc = G%jed + 1 ; OBC%je_u_E_obc = G%jsd - 1
+ OBC%is_v_S_obc = G%ied + 1 ; OBC%ie_v_S_obc = G%isd - 1
+ OBC%Js_v_S_obc = G%JedB + 1 ; OBC%Je_v_S_obc = G%JsdB - 1
+ OBC%is_v_N_obc = G%ied + 1 ; OBC%ie_v_N_obc = G%isd - 1
+ OBC%Js_v_N_obc = G%JedB + 1 ; OBC%Je_v_N_obc = G%JsdB - 1
+ OBC%v_N_OBCs_on_PE = .false. ; OBC%v_S_OBCs_on_PE = .false.
+ OBC%u_E_OBCs_on_PE = .false. ; OBC%u_W_OBCs_on_PE = .false.
+ ! Note that the loop ranges are reduced because outward facing OBCs can not be applied at edge points.
+ do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB-1
+ if (OBC%segnum_u(I,j) < 0) then ! This point has OBC_DIRECTION_W.
+ OBC%Is_u_W_obc = min(I, OBC%Is_u_W_obc) ; OBC%Ie_u_W_obc = max(I, OBC%Ie_u_W_obc)
+ OBC%js_u_W_obc = min(j, OBC%js_u_W_obc) ; OBC%je_u_W_obc = max(j, OBC%je_u_W_obc)
+ OBC%u_W_OBCs_on_PE = .true.
+ endif
+ enddo ; enddo
+ do j=G%jsd,G%jed ; do I=G%IsdB+1,G%IedB
+ if (OBC%segnum_u(I,j) > 0) then ! This point has OBC_DIRECTION_E.
+ OBC%Is_u_E_obc = min(I, OBC%Is_u_E_obc) ; OBC%Ie_u_E_obc = max(I, OBC%Ie_u_E_obc)
+ OBC%js_u_E_obc = min(j, OBC%js_u_E_obc) ; OBC%je_u_E_obc = max(j, OBC%je_u_E_obc)
+ OBC%u_E_OBCs_on_PE = .true.
+ endif
+ enddo ; enddo
+ do J=G%JsdB,G%JedB-1 ; do i=G%isd,G%ied
+ if (OBC%segnum_v(i,J) < 0) then ! This point has OBC_DIRECTION_S.
+ OBC%is_v_S_obc = min(i, OBC%is_v_S_obc) ; OBC%ie_v_S_obc = max(i, OBC%ie_v_S_obc)
+ OBC%Js_v_S_obc = min(J, OBC%Js_v_S_obc) ; OBC%Je_v_S_obc = max(J, OBC%Je_v_S_obc)
+ OBC%v_S_OBCs_on_PE = .true.
+ endif
+ enddo ; enddo
+ do J=G%JsdB+1,G%JedB ; do i=G%isd,G%ied
+ if (OBC%segnum_v(i,J) > 0) then ! This point has OBC_DIRECTION_N.
+ OBC%is_v_N_obc = min(i, OBC%is_v_N_obc) ; OBC%ie_v_N_obc = max(i, OBC%ie_v_N_obc)
+ OBC%Js_v_N_obc = min(J, OBC%Js_v_N_obc) ; OBC%Je_v_N_obc = max(J, OBC%Je_v_N_obc)
+ OBC%v_N_OBCs_on_PE = .true.
+ endif
+ enddo ; enddo
+
+end subroutine set_segnum_signs
+
!> Return an appropriate dimensional scaling factor for input data based on an OBC segment data
!! name [various ~> 1], or 1 for tracers or other fields that do not match one of the specified names.
!! Note that calls to register_segment_tracer can come before or after calls to scale_factor_from_name.
-real function scale_factor_from_name(name, GV, US, Tr_Reg)
+real function scale_factor_from_name(name, US, Tr_Reg)
character(len=*), intent(in) :: name !< The OBC segment data name to interpret
- type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(segment_tracer_registry_type), pointer :: Tr_Reg !< pointer to tracer registry for this segment
@@ -1201,17 +1520,20 @@ subroutine initialize_obc_tides(OBC, US, param_file)
"Fixed reference date to use for nodal modulation of boundary tides.", &
old_name="OBC_TIDE_NODAL_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides)
- if (.not. OBC%add_eq_phase) then
- ! If equilibrium phase argument is not added, the input phases
- ! should already be relative to the reference time.
- call MOM_mesg('OBC tidal phases will *not* be corrected with equilibrium arguments.')
- endif
-
allocate(OBC%tide_names(OBC%n_tide_constituents))
read(tide_constituent_str, *) OBC%tide_names
! Set reference time (t = 0) for boundary tidal forcing.
- OBC%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0)
+ if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0.
+ OBC%time_ref = set_date(1, 1, 1, 0, 0, 0)
+ else
+ if (.not. OBC%add_eq_phase) then
+ ! If equilibrium phase argument is not added, the input phases
+ ! should already be relative to the reference time.
+ call MOM_mesg('OBC tidal phases will *not* be corrected with equilibrium arguments.')
+ endif
+ OBC%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0)
+ endif
! Find relevant lunar and solar longitudes at the reference time
if (OBC%add_eq_phase) call astro_longitudes_init(OBC%time_ref, OBC%tidal_longitudes)
@@ -1266,7 +1588,7 @@ subroutine initialize_obc_tides(OBC, US, param_file)
end subroutine initialize_obc_tides
!> Define indices for segment and store in hor_index_type
-!> using global segment bounds corresponding to q-points
+!! using global segment bounds corresponding to q-points
subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc)
type(dyn_horgrid_type), intent(in) :: G !< grid type
type(OBC_segment_type), intent(inout) :: seg !< Open boundary segment
@@ -1275,7 +1597,7 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc)
integer, intent(in) :: Js_obc !< Q-point global j-index of start of segment
integer, intent(in) :: Je_obc !< Q-point global j-index of end of segment
! Local variables
- integer :: IsgB, IegB, JsgB, JegB
+ integer :: IsgB, IegB, JsgB, JegB ! Global corner point indices at the ends of the OBC segments
integer :: isg, ieg, jsg, jeg
! Isg, Ieg will be I*_obc in global space
@@ -1389,12 +1711,13 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc)
end subroutine setup_segment_indices
!> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly
-subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y)
+subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reentrant_y)
type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure
type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string"
- integer, intent(in) :: l_seg !< which segment is this?
+ integer, intent(in) :: l_seg !< The internal segment number
+ integer, intent(in) :: l_seg_io !< The segment number used for reading parameters
type(param_file_type), intent(in) :: PF !< Parameter file handle
logical, intent(in) :: reentrant_y !< is the domain reentrant in y?
! Local variables
@@ -1416,7 +1739,7 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y)
OBC%segment(l_seg)%direction = OBC_DIRECTION_E
elseif (Je_obcJs_obc .and. j<=Je_obc) then
OBC%segnum_u(I_obc,j) = l_seg
+ if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) OBC%segnum_u(I_obc,j) = -l_seg
+ OBC%u_OBCs_on_PE = .true.
endif
enddo
OBC%segment(l_seg)%Is_obc = I_obc
@@ -1521,20 +1838,16 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y)
if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) &
call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: \n"//&
"Orlanski and Oblique OBC options cannot be used together on one segment.")
-
- if (OBC%segment(l_seg)%u_values_needed .or. OBC%segment(l_seg)%v_values_needed .or. &
- OBC%segment(l_seg)%t_values_needed .or. OBC%segment(l_seg)%s_values_needed .or. &
- OBC%segment(l_seg)%z_values_needed .or. OBC%segment(l_seg)%g_values_needed) &
- OBC%segment(l_seg)%values_needed = .true.
end subroutine setup_u_point_obc
!> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly
-subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x)
+subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reentrant_x)
type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure
type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string"
- integer, intent(in) :: l_seg !< which segment is this?
+ integer, intent(in) :: l_seg !< The internal segment number
+ integer, intent(in) :: l_seg_io !< The segment number used for reading parameters
type(param_file_type), intent(in) :: PF !< Parameter file handle
logical, intent(in) :: reentrant_x !< is the domain reentrant in x?
! Local variables
@@ -1570,8 +1883,6 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x)
OBC%segment(l_seg)%open = .true.
OBC%Flather_v_BCs_exist_globally = .true.
OBC%open_v_BCs_exist_globally = .true.
- OBC%segment(l_seg)%z_values_needed = .true.
- OBC%segment(l_seg)%v_values_needed = .true.
elseif (trim(action_str(a_loop)) == 'ORLANSKI') then
OBC%segment(l_seg)%radiation = .true.
OBC%segment(l_seg)%open = .true.
@@ -1599,14 +1910,11 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x)
elseif (trim(action_str(a_loop)) == 'NUDGED') then
OBC%segment(l_seg)%nudged = .true.
OBC%nudged_v_BCs_exist_globally = .true.
- OBC%segment(l_seg)%v_values_needed = .true.
elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then
OBC%segment(l_seg)%nudged_tan = .true.
OBC%nudged_v_BCs_exist_globally = .true.
- OBC%segment(l_seg)%u_values_needed = .true.
elseif (trim(action_str(a_loop)) == 'NUDGED_GRAD') then
OBC%segment(l_seg)%nudged_grad = .true.
- OBC%segment(l_seg)%g_values_needed = .true.
elseif (trim(action_str(a_loop)) == 'GRADIENT') then
OBC%segment(l_seg)%gradient = .true.
OBC%segment(l_seg)%open = .true.
@@ -1614,19 +1922,16 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x)
elseif (trim(action_str(a_loop)) == 'SIMPLE') then
OBC%segment(l_seg)%specified = .true.
OBC%specified_v_BCs_exist_globally = .true. ! This avoids deallocation
- OBC%segment(l_seg)%v_values_needed = .true.
elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then
OBC%segment(l_seg)%specified_tan = .true.
- OBC%segment(l_seg)%u_values_needed = .true.
elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then
OBC%segment(l_seg)%specified_grad = .true.
- OBC%segment(l_seg)%g_values_needed = .true.
else
call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: "//&
"String '"//trim(action_str(a_loop))//"' not understood.")
endif
if (OBC%segment(l_seg)%nudged .or. OBC%segment(l_seg)%nudged_tan) then
- write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg
+ write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg_io
allocate(tnudge(2))
call get_param(PF, mdl, segment_param_str(1:43), tnudge, &
"Timescales in days for nudging along a segment, "//&
@@ -1649,6 +1954,8 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x)
do i=G%HI%isd, G%HI%ied
if (i>Is_obc .and. i<=Ie_obc) then
OBC%segnum_v(i,J_obc) = l_seg
+ if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) OBC%segnum_v(i,J_obc) = -l_seg
+ OBC%v_OBCs_on_PE = .true.
endif
enddo
OBC%segment(l_seg)%Is_obc = Is_obc
@@ -1661,10 +1968,6 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x)
call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: \n"//&
"Orlanski and Oblique OBC options cannot be used together on one segment.")
- if (OBC%segment(l_seg)%u_values_needed .or. OBC%segment(l_seg)%v_values_needed .or. &
- OBC%segment(l_seg)%t_values_needed .or. OBC%segment(l_seg)%s_values_needed .or. &
- OBC%segment(l_seg)%z_values_needed .or. OBC%segment(l_seg)%g_values_needed) &
- OBC%segment(l_seg)%values_needed = .true.
end subroutine setup_v_point_obc
!> Parse an OBC_SEGMENT_%%% string
@@ -1680,6 +1983,7 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_
! Local variables
character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of
!! "I=%,J=%:%,string"
+ character(len=3) :: max_words !< maximum number of OBC types per segment
integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J="
integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J="
integer :: j
@@ -1699,7 +2003,7 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_
if (.not. (word2(1:2)=='I=')) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//&
"Second word of string '"//trim(segment_str)//"' must start with 'I='.")
else
- call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//&
+ call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//&
"String '"//segment_str//"' must start with 'I=' or 'J='.")
endif
@@ -1745,6 +2049,14 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_
"Range in string '"//trim(segment_str)//"' must span one cell.")
endif
+ ! checking if the number of provided OBC types is less than or equal to 8
+ if (extract_word(segment_str,',',3+size(action_str))/="") then
+ write(max_words, '(I0)') size(action_str)
+ call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "// &
+ "Number of OBC descriptor words in '" // trim(segment_str) // "' is too large. " // &
+ "There can be at most " // trim(max_words) // " descriptor words.")
+ endif
+
! Type of open boundary condition
do j = 1, size(action_str)
action_str(j) = extract_word(segment_str,',',2+j)
@@ -1760,7 +2072,7 @@ integer function interpret_int_expr(string, imax)
integer slen
slen = len_trim(string)
- if (slen==0) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//&
+ if (slen==0) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//&
"Parsed string was empty!")
if (len_trim(string)==1 .and. string(1:1)=='N') then
interpret_int_expr = imax
@@ -1776,7 +2088,7 @@ integer function interpret_int_expr(string, imax)
read(string(1:slen),*,err=911) interpret_int_expr
endif
return
- 911 call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//&
+ 911 call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//&
"Problem reading value from string '"//trim(string)//"'.")
end function interpret_int_expr
end subroutine parse_segment_str
@@ -1787,19 +2099,35 @@ subroutine parse_segment_manifest_str(segment_str, num_fields, fields)
character(len=*), intent(in) :: segment_str !< A string in form of
!< "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..."
integer, intent(out) :: num_fields !< The number of fields in the segment data
- character(len=*), dimension(MAX_OBC_FIELDS), intent(out) :: fields
+ character(len=*), dimension(NUM_PHYS_FIELDS), intent(out) :: fields
!< List of fieldnames for each segment
! Local variables
- character(len=128) :: word1, word2
+ character(len=128) :: field_spec, field
+ integer :: i
num_fields = 0
+ fields(:) = ''
+
do
- word1 = extract_word(segment_str, ',', num_fields+1)
- if (trim(word1) == '') exit
+ field_spec = extract_word(segment_str, ',', num_fields + 1)
+ if (trim(field_spec) == '') exit
+
+ if (num_fields >= NUM_PHYS_FIELDS) &
+ call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_manifest_str: " // &
+ "too many fields in OBC segment manifest '" //trim(segment_str) // "'.")
+
+ field = trim(extract_word(field_spec, '=', 1))
+
+ ! Check for duplicate fields
+ do i=1, num_fields
+ if (fields(i) == trim(field)) &
+ call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_manifest_str: "//&
+ "duplicate field '" // trim(field) // "' in '" // trim(segment_str) // "'.")
+ enddo
+
num_fields = num_fields + 1
- word2 = extract_word(word1, '=', 1)
- fields(num_fields) = trim(word2)
+ fields(num_fields) = trim(field)
enddo
end subroutine parse_segment_manifest_str
@@ -1850,7 +2178,6 @@ subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldn
987 call MOM_error(FATAL,'Error while parsing segment data specification! '//trim(segment_str))
end subroutine parse_segment_data_str
-
!> Parse all the OBC_SEGMENT_%%%_DATA strings again
!! to see which need tracer reservoirs (all pes need to know).
subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature)
@@ -1859,22 +2186,26 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature)
logical, intent(in) :: use_temperature !< If true, T and S are used
! Local variables
- integer :: n,m,num_fields,na
+ integer :: n ! The segment number used to read in input data
+ integer :: n_seg ! The internal segment number
+ integer :: m, num_fields ! Used to loop over the fields on a segment
+ integer :: na
character(len=1024) :: segstr
character(len=256) :: filename
- character(len=20) :: segnam, suffix
+ character(len=20) :: segname, suffix
character(len=32) :: fieldname
real :: value ! A value that is parsed from the segment data string [various units]
- character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names
+ character(len=32), dimension(NUM_PHYS_FIELDS) :: fields ! segment field names
type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list
- do n=1, OBC%number_of_segments
- segment => OBC%segment(n)
- write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n
- write(suffix,"('_segment_',i3.3)") n
+ do n=1,OBC%number_of_segments
+ n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n
+ segment => OBC%segment(n_seg)
+ write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n
+ write(suffix, "('_segment_',i3.3)") n
! Clear out any old values
segstr = ''
- call get_param(PF, mdl, segnam, segstr)
+ call get_param(PF, mdl, segname, segstr)
if (segstr == '') cycle
call parse_segment_manifest_str(trim(segstr), num_fields, fields)
@@ -1916,16 +2247,16 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature)
!So we need to start from reservoir index for non-native tracers from 3, hence na=2 below.
!num_fields is the number of vars in segstr (6 of them now, U,V,SSH,TEMP,SALT,dye)
!but OBC%tracer_x_reservoirs_used is allocated to size Reg%ntr, which is the total number of tracers
- na=2 !number of native MOM6 tracers (T&S) with reservoirs
+ na = 2 ! Number of native MOM6 tracers (T&S) with reservoirs
do m=1,OBC%num_obgc_tracers
!This logic assumes all external tarcers need a reservoir
!The segments for tracers are not initialized yet (that happens later in initialize_segment_data())
!so we cannot query to determine if this tracer needs a reservoir.
- if (segment%is_E_or_W_2) then
+ 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 +2264,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
@@ -1976,8 +2299,15 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS)
call pass_var(OBC%tres_y(:,:,:,m), G%Domain, position=NORTH_FACE)
enddo
endif
+ if (allocated(OBC%h_res_x) .and. allocated(OBC%h_res_y)) then
+ call pass_vector(OBC%h_res_x(:,:,:), OBC%h_res_y(:,:,:), G%Domain, To_All+Scalar_Pair)
+ elseif (allocated(OBC%h_res_x)) then
+ call pass_var(OBC%h_res_x(:,:,:), G%Domain, position=EAST_FACE)
+ elseif (allocated(OBC%h_res_y)) then
+ call pass_var(OBC%h_res_y(:,:,:), G%Domain, position=NORTH_FACE)
+ endif
-end subroutine open_boundary_init
+end subroutine open_boundary_halo_update
logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, &
apply_nudged_OBC, needs_ext_seg_data)
@@ -2009,7 +2339,7 @@ subroutine open_boundary_dealloc(OBC)
if (.not. associated(OBC)) return
- do n=1, OBC%number_of_segments
+ do n=1,OBC%number_of_segments
segment => OBC%segment(n)
call deallocate_OBC_segment_data(segment)
enddo
@@ -2026,6 +2356,8 @@ subroutine open_boundary_dealloc(OBC)
if (allocated(OBC%cff_normal_v)) deallocate(OBC%cff_normal_v)
if (allocated(OBC%tres_x)) deallocate(OBC%tres_x)
if (allocated(OBC%tres_y)) deallocate(OBC%tres_y)
+ if (allocated(OBC%h_res_x)) deallocate(OBC%h_res_x)
+ if (allocated(OBC%h_res_y)) deallocate(OBC%h_res_y)
if (associated(OBC%remap_z_CS)) deallocate(OBC%remap_z_CS)
if (associated(OBC%remap_h_CS)) deallocate(OBC%remap_h_CS)
deallocate(OBC)
@@ -2053,7 +2385,7 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth)
return
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
+ segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
if (segment%direction == OBC_DIRECTION_E) then
I=segment%HI%IsdB
@@ -2097,14 +2429,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
@@ -2113,16 +2445,16 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US)
enddo
do J=segment%HI%JsdB+1,segment%HI%JedB-1
if (segment%direction == OBC_DIRECTION_W) then
- G%mask2dCv(i,J) = 0 ; G%OBCmaskCv(i,J) = 0.0
+ G%mask2dCv(i,J) = 0 ; G%OBCmaskCv(i,J) = 0.0 ; G%IdyCv_OBCmask(i,J) = 0.0
else
- G%mask2dCv(i+1,J) = 0.0 ; G%OBCmaskCv(i+1,J) = 0.0
+ G%mask2dCv(i+1,J) = 0.0 ; G%OBCmaskCv(i+1,J) = 0.0 ; G%IdyCv_OBCmask(i+1,J) = 0.0
endif
enddo
else
! Sweep along v-segments and delete the OBC for blocked points.
J=segment%HI%JsdB
do i=segment%HI%isd,segment%HI%ied
- if (G%mask2dCv(i,J) == 0) OBC%segnum_v(i,J) = OBC_NONE
+ if (G%mask2dCv(i,J) == 0) OBC%segnum_v(i,J) = 0
if (segment%direction == OBC_DIRECTION_S) then
G%mask2dT(i,j) = 0.0
else
@@ -2131,33 +2463,34 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US)
enddo
do I=segment%HI%IsdB+1,segment%HI%IedB-1
if (segment%direction == OBC_DIRECTION_S) then
- G%mask2dCu(I,j) = 0.0 ; G%OBCmaskCu(I,j) = 0.0
+ G%mask2dCu(I,j) = 0.0 ; G%OBCmaskCu(I,j) = 0.0 ; G%IdxCu_OBCmask(I,j) = 0.0
else
- G%mask2dCu(I,j+1) = 0.0 ; G%OBCmaskCu(I,j+1) = 0.0
+ G%mask2dCu(I,j+1) = 0.0 ; G%OBCmaskCu(I,j+1) = 0.0 ; G%IdxCu_OBCmask(I,j+1) = 0.0
endif
enddo
endif
enddo
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
+ segment => OBC%segment(n)
if (.not. (segment%on_pe .and. segment%open)) cycle
! Set the OBCmask values to help eliminate certain terms at u- or v- OBC points.
+ ! Testing suggests this could be applied at all u- or v- OBC points without changing answers.
if (segment%is_E_or_W) then
I=segment%HI%IsdB
do j=segment%HI%jsd,segment%HI%jed
- G%OBCmaskCu(I,j) = 0.0
+ G%OBCmaskCu(I,j) = 0.0 ; G%IdxCu_OBCmask(I,j) = 0.0
enddo
else
J=segment%HI%JsdB
do i=segment%HI%isd,segment%HI%ied
- G%OBCmaskCv(i,J) = 0.0
+ G%OBCmaskCv(i,J) = 0.0 ; G%IdyCv_OBCmask(i,J) = 0.0
enddo
endif
enddo
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
+ segment => OBC%segment(n)
if (.not. segment%on_pe .or. .not. segment%specified) cycle
if (segment%is_E_or_W) then
! Sweep along u-segments and for %specified BC points reset the u-point area which was masked out
@@ -2189,69 +2522,234 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US)
any_U = .false.
any_V = .false.
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
+ segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
if (segment%is_E_or_W) then
I=segment%HI%IsdB
do j=segment%HI%jsd,segment%HI%jed
- if (OBC%segnum_u(I,j) /= OBC_NONE) any_U = .true.
+ if (OBC%segnum_u(I,j) /= 0) any_U = .true.
enddo
else
J=segment%HI%JsdB
do i=segment%HI%isd,segment%HI%ied
- if (OBC%segnum_v(i,J) /= OBC_NONE) any_V = .true.
+ if (OBC%segnum_v(i,J) /= 0) any_V = .true.
enddo
endif
enddo
- OBC%OBC_pe = .true.
- if (.not.(any_U .or. any_V)) OBC%OBC_pe = .false.
+ OBC%u_OBCs_on_PE = any_U
+ OBC%v_OBCs_on_PE = any_V
+ OBC%OBC_pe = (any_U .or. any_V)
end subroutine open_boundary_impose_land_mask
-!> Make sure the OBC tracer reservoirs are initialized.
-subroutine setup_OBC_tracer_reservoirs(G, GV, OBC)
- type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
- type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
- type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure
+!> Initialize the tracer reservoirs values, perhaps only if they have not been set via a restart file.
+subroutine setup_OBC_tracer_reservoirs(G, GV, OBC, restart_CS)
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
+ type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure
+ type(MOM_restart_CS), optional, intent(in) :: restart_CS !< MOM restart control structure
+ ! Local variables
type(OBC_segment_type), pointer :: segment => NULL()
real :: I_scale ! The inverse of the scaling factor for the tracers.
! For salinity the units would be [ppt S-1 ~> 1]
+ logical :: set_tres_x, set_tres_y
+ character(len=12) :: x_var_name, y_var_name
integer :: i, j, k, m, n
+ do m=1,OBC%ntr
+
+ set_tres_x = allocated(OBC%tres_x) .and. OBC%tracer_x_reservoirs_used(m)
+ set_tres_y = allocated(OBC%tres_y) .and. OBC%tracer_y_reservoirs_used(m)
+
+ if (present(restart_CS)) then
+ ! Set the names of the reservoirs for this tracer in the restart file, and inquire whether
+ ! they have been initialized
+ if (modulo(G%HI%turns, 2) == 0) then
+ write(x_var_name,'("tres_x_",I3.3)') m
+ write(y_var_name,'("tres_y_",I3.3)') m
+ else
+ write(x_var_name,'("tres_y_",I3.3)') m
+ write(y_var_name,'("tres_x_",I3.3)') m
+ endif
+ if (set_tres_x) set_tres_x = .not.query_initialized(OBC%tres_x, x_var_name, restart_CS)
+ if (set_tres_y) set_tres_y = .not.query_initialized(OBC%tres_y, y_var_name, restart_CS)
+ endif
+
+ do n=1,OBC%number_of_segments
+ segment => OBC%segment(n)
+ if (associated(segment%tr_Reg)) then ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then
+ I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale
+
+ if (segment%is_E_or_W .and. set_tres_x) then
+ I = segment%HI%IsdB
+ if (segment%tr_Reg%Tr(m)%is_initialized) then
+ do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed
+ OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,j,k)
+ enddo ; enddo
+ else
+ do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed
+ OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,j,k)
+ enddo ; enddo
+ endif
+ elseif (segment%is_N_or_S .and. set_tres_y) then
+ J = segment%HI%JsdB
+ if (segment%tr_Reg%Tr(m)%is_initialized) then
+ do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied
+ OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k)
+ enddo ; enddo
+ else
+ do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied
+ OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,J,k)
+ enddo ; enddo
+ endif
+ endif
+ endif ; endif
+ enddo
+ enddo
+
+end subroutine setup_OBC_tracer_reservoirs
+
+!> Initialize the thickness reservoirs values, perhaps only if they have not been set via a restart file.
+subroutine setup_OBC_thickness_reservoirs(G, GV, OBC, restart_CS)
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
+ type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure
+ type(MOM_restart_CS), optional, intent(in) :: restart_CS !< MOM restart control structure
+
+ ! Local variables
+ type(OBC_segment_type), pointer :: segment => NULL()
+ real :: I_scale ! The inverse of the scaling factor for the thicknesses.
+ ! [m Z-1 ~> 1]
+ logical :: set_h_res_x, set_h_res_y
+ character(len=12) :: x_var_name, y_var_name
+ integer :: i, j, k, n
+
+ set_h_res_x = allocated(OBC%h_res_x) .and. OBC%thickness_x_reservoirs_used
+ set_h_res_y = allocated(OBC%h_res_y) .and. OBC%thickness_y_reservoirs_used
+
+ if (present(restart_CS)) then
+ ! Set the names of the reservoirs for the layer thickness in the restart file, and inquire
+ ! whether they have been initialized
+ if (modulo(G%HI%turns, 2) == 0) then
+ write(x_var_name,'("h_res_x")')
+ write(y_var_name,'("h_res_y")')
+ else
+ write(x_var_name,'("h_res_y")')
+ write(y_var_name,'("h_res_x")')
+ endif
+ if (set_h_res_x) set_h_res_x = .not.query_initialized(OBC%h_res_x, x_var_name, restart_CS)
+ if (set_h_res_y) set_h_res_y = .not.query_initialized(OBC%h_res_y, y_var_name, restart_CS)
+ endif
+
+ do n=1,OBC%number_of_segments
+ segment => OBC%segment(n)
+ if (associated(segment%h_Reg)) then ; if (allocated(segment%h_Reg%h_res)) then
+ I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale
+
+ if (segment%is_E_or_W .and. set_h_res_x) then
+ I = segment%HI%IsdB
+ if (segment%h_Reg%is_initialized) then
+ do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed
+ OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(i,j,k)
+ enddo ; enddo
+ else
+ do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed
+ OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h(i,j,k)
+ enddo ; enddo
+ endif
+ elseif (segment%is_N_or_S .and. set_h_res_y) then
+ J = segment%HI%JsdB
+ if (segment%h_Reg%is_initialized) then
+ do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied
+ OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k)
+ enddo ; enddo
+ else
+ do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied
+ OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h(i,J,k)
+ enddo ; enddo
+ endif
+ endif
+ endif ; endif
+ enddo
+
+end subroutine setup_OBC_thickness_reservoirs
+
+!> Record that the tracer reservoirs have been initialized so that their values are not reset later.
+subroutine set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS)
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+ type(ocean_OBC_type), intent(in) :: OBC !< Open boundary control structure
+ type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure
+ character(len=12) :: x_var_name, y_var_name
+ integer :: m
+
+ do m=1,OBC%ntr
+ ! Set the names of the reservoirs for this tracer in the restart file
+ if (modulo(G%HI%turns, 2) == 0) then
+ write(x_var_name,'("tres_x_",I3.3)') m
+ write(y_var_name,'("tres_y_",I3.3)') m
+ else
+ write(x_var_name,'("tres_y_",I3.3)') m
+ write(y_var_name,'("tres_x_",I3.3)') m
+ endif
+
+ if (OBC%tracer_x_reservoirs_used(m)) call set_initialized(OBC%tres_x, x_var_name, restart_CS)
+ if (OBC%tracer_y_reservoirs_used(m)) call set_initialized(OBC%tres_y, y_var_name, restart_CS)
+ enddo
+
+end subroutine set_initialized_OBC_tracer_reservoirs
+
+!> Fill segment%h_Reg from restart fields.
+subroutine copy_thickness_reservoirs(OBC, G, GV)
+ type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
+ type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure
+ ! Local variables
+ type(OBC_segment_type), pointer :: segment => NULL()
+ integer :: i, j, k, n
+ logical :: sym
+
+ if (.not.associated(OBC)) return
+
+ if (.not.(OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used)) &
+ return
+
+ ! Now thickness reservoirs
do n=1,OBC%number_of_segments
segment=>OBC%segment(n)
- if (associated(segment%tr_Reg)) then
+ if (associated(segment%h_Reg)) then
if (segment%is_E_or_W) then
I = segment%HI%IsdB
- do m=1,OBC%ntr
- 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
+ if (allocated(segment%h_Reg%h_res)) then
+ do k=1,GV%ke
+ do j=segment%HI%jsd,segment%HI%jed
+ segment%h_Reg%h_res(I,j,k) = segment%h_Reg%scale * OBC%h_res_x(I,j,k)
enddo
- endif
- enddo
+ enddo
+ endif
else
J = segment%HI%JsdB
- do m=1,OBC%ntr
- 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
+ if (allocated(segment%h_Reg%h_res)) then
+ do k=1,GV%ke
+ do i=segment%HI%isd,segment%HI%ied
+ segment%h_Reg%h_res(i,J,k) = segment%h_Reg%scale * OBC%h_res_y(i,J,k)
enddo
- endif
- enddo
+ enddo
+ endif
endif
endif
enddo
-end subroutine setup_OBC_tracer_reservoirs
+ if (OBC%debug) then
+ sym = G%Domain%symmetric
+ if (allocated(OBC%h_res_x) .and. allocated(OBC%h_res_y)) then
+ call uvchksum("radiation_OBCs: OBC%h_res_[xy]", OBC%h_res_x(:,:,:), OBC%h_res_y(:,:,:), G%HI, &
+ haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0)
+ endif
+ endif
+
+end subroutine copy_thickness_reservoirs
!> Apply radiation conditions to 3D u,v at open boundaries
subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dt)
@@ -2259,7 +2757,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure
real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u_new !< On exit, new u values on open boundaries
- !! On entry, the old time-level v but including
+ !! On entry, the old time-level u but including
!! barotropic accelerations [L T-1 ~> m s-1].
real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_old !< Original unadjusted u [L T-1 ~> m s-1]
real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v_new !< On exit, new v values on open boundaries.
@@ -2303,6 +2801,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
if (.not.(OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) &
return
+ if (OBC%debug) call chksum_OBC_segments(OBC, G, GV, US, OBC%nk_OBC_debug)
+
eps = 1.0e-20*US%m_s_to_L_T**2
!! Copy previously calculated phase velocity from global arrays into segments
@@ -2310,7 +2810,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
!! and needs to be revisited in the future.
if (OBC%gamma_uv < 1.0) then
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
+ segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
if (segment%is_E_or_W .and. segment%radiation) then
do k=1,GV%ke
@@ -2351,7 +2851,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
! Now tracers (if any)
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
+ segment => OBC%segment(n)
if (associated(segment%tr_Reg)) then
if (segment%is_E_or_W) then
I = segment%HI%IsdB
@@ -2382,7 +2882,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US,
gamma_u = OBC%gamma_uv
rx_max = OBC%rx_max ; ry_max = OBC%rx_max
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
+ segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
if (segment%oblique) call gradient_at_q_points(G, GV, segment, u_new(:,:,:), v_new(:,:,:))
if (segment%direction == OBC_DIRECTION_E) then
@@ -3373,23 +3873,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 +4088,8 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel)
end subroutine gradient_at_q_points
-!> Sets the initial values of the tracer open boundary conditions.
-!! Redoing this elsewhere.
-subroutine set_tracer_data(OBC, tv, h, G, GV, PF)
- type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure
- type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
- type(ocean_OBC_type), target, intent(in) :: OBC !< Open boundary structure
- type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< 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 +4111,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
@@ -3695,27 +4142,35 @@ subroutine allocate_OBC_segment_data(OBC, segment)
if (segment%is_E_or_W) then
! If these are just Flather, change update_OBC_segment_data accordingly
- allocate(segment%Cg(IsdB:IedB,jsd:jed), source=0.0)
allocate(segment%Htot(IsdB:IedB,jsd:jed), source=0.0)
- allocate(segment%dZtot(IsdB:IedB,jsd:jed), source=0.0)
- allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0)
+ ! Allocate dZtot with extra values at the end to avoid segmentation faults in cases where
+ ! it is interpolated to OBC vorticity points.
+ allocate(segment%dZtot(IsdB:IedB,jsd-1:jed+1), source=0.0)
allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0)
+ allocate(segment%tidal_elev(IsdB:IedB,jsd:jed), source=0.0)
if (segment%radiation) &
allocate(segment%rx_norm_rad(IsdB:IedB,jsd:jed,OBC%ke), source=0.0)
allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke), source=0.0)
allocate(segment%normal_vel_bt(IsdB:IedB,jsd:jed), source=0.0)
allocate(segment%normal_trans(IsdB:IedB,jsd:jed,OBC%ke), source=0.0)
+ allocate(segment%normal_trans_bt(IsdB:IedB,jsd:jed), source=0.0)
+ allocate(segment%tidal_vn(IsdB:IedB,jsd:jed), source=0.0)
if (segment%nudged) &
allocate(segment%nudged_normal_vel(IsdB:IedB,jsd:jed,OBC%ke), source=0.0)
- if (segment%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. &
- segment%oblique_tan .or. OBC%computed_vorticity .or. OBC%computed_strain) &
+ if (segment%radiation_tan .or. segment%nudged_tan .or. &
+ segment%specified_tan .or. segment%oblique_tan .or. &
+ (OBC%vorticity_config == OBC_VORTICITY_COMPUTED) .or. &
+ (OBC%strain_config == OBC_STRAIN_COMPUTED)) then
allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0)
+ allocate(segment%tidal_vt(IsdB:IedB,JsdB:JedB), source=0.0)
+ endif
if (segment%nudged_tan) &
allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0)
if (segment%nudged_grad) &
allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0)
- if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. &
- segment%oblique_grad .or. segment%specified_grad) &
+ if (segment%radiation_grad .or. segment%oblique_grad .or. segment%specified_grad .or. &
+ (OBC%vorticity_config == OBC_VORTICITY_SPECIFIED) .or. &
+ (OBC%strain_config == OBC_STRAIN_SPECIFIED)) &
allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0)
if (segment%oblique) then
allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke), source=0.0)
@@ -3731,27 +4186,35 @@ subroutine allocate_OBC_segment_data(OBC, segment)
if (segment%is_N_or_S) then
! If these are just Flather, change update_OBC_segment_data accordingly
- allocate(segment%Cg(isd:ied,JsdB:JedB), source=0.0)
allocate(segment%Htot(isd:ied,JsdB:JedB), source=0.0)
- allocate(segment%dZtot(isd:ied,JsdB:JedB), source=0.0)
- allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0)
+ ! Allocate dZtot with extra values at the end to avoid segmentation faults in cases where
+ ! it is interpolated to OBC vorticity points.
+ allocate(segment%dZtot(isd-1:ied+1,JsdB:JedB), source=0.0)
allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0)
+ allocate(segment%tidal_elev(isd:ied,JsdB:JedB), source=0.0)
if (segment%radiation) &
allocate(segment%ry_norm_rad(isd:ied,JsdB:JedB,OBC%ke), source=0.0)
allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke), source=0.0)
allocate(segment%normal_vel_bt(isd:ied,JsdB:JedB), source=0.0)
allocate(segment%normal_trans(isd:ied,JsdB:JedB,OBC%ke), source=0.0)
+ allocate(segment%normal_trans_bt(isd:ied,JsdB:JedB), source=0.0)
+ allocate(segment%tidal_vn(isd:ied,JsdB:JedB), source=0.0)
if (segment%nudged) &
allocate(segment%nudged_normal_vel(isd:ied,JsdB:JedB,OBC%ke), source=0.0)
- if (segment%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. &
- segment%oblique_tan .or. OBC%computed_vorticity .or. OBC%computed_strain) &
+ if (segment%radiation_tan .or. segment%nudged_tan .or. &
+ segment%specified_tan .or. segment%oblique_tan .or. &
+ (OBC%vorticity_config == OBC_VORTICITY_COMPUTED) .or. &
+ (OBC%strain_config == OBC_STRAIN_COMPUTED)) then
allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0)
+ allocate(segment%tidal_vt(IsdB:IedB,JsdB:JedB), source=0.0)
+ endif
if (segment%nudged_tan) &
allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0)
if (segment%nudged_grad) &
allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0)
- if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. &
- segment%oblique_grad .or. segment%specified_grad) &
+ if (segment%radiation_grad .or. segment%oblique_grad .or. segment%specified_grad .or. &
+ (OBC%vorticity_config == OBC_VORTICITY_SPECIFIED) .or. &
+ (OBC%strain_config == OBC_STRAIN_SPECIFIED)) &
allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0)
if (segment%oblique) then
allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke), source=0.0)
@@ -3773,11 +4236,10 @@ subroutine deallocate_OBC_segment_data(segment)
if (.not. segment%on_pe) return
- if (allocated(segment%Cg)) deallocate(segment%Cg)
if (allocated(segment%Htot)) deallocate(segment%Htot)
if (allocated(segment%dZtot)) deallocate(segment%dZtot)
- if (allocated(segment%h)) deallocate(segment%h)
if (allocated(segment%SSH)) deallocate(segment%SSH)
+ if (allocated(segment%tidal_elev)) deallocate(segment%tidal_elev)
if (allocated(segment%rx_norm_rad)) deallocate(segment%rx_norm_rad)
if (allocated(segment%ry_norm_rad)) deallocate(segment%ry_norm_rad)
if (allocated(segment%rx_norm_obl)) deallocate(segment%rx_norm_obl)
@@ -3789,6 +4251,9 @@ subroutine deallocate_OBC_segment_data(segment)
if (allocated(segment%normal_vel)) deallocate(segment%normal_vel)
if (allocated(segment%normal_vel_bt)) deallocate(segment%normal_vel_bt)
if (allocated(segment%normal_trans)) deallocate(segment%normal_trans)
+ if (allocated(segment%normal_trans_bt)) deallocate(segment%normal_trans_Bt)
+ if (allocated(segment%tidal_vn)) deallocate(segment%tidal_vn)
+ if (allocated(segment%tidal_vt)) deallocate(segment%tidal_vt)
if (allocated(segment%nudged_normal_vel)) deallocate(segment%nudged_normal_vel)
if (allocated(segment%tangential_vel)) deallocate(segment%tangential_vel)
if (allocated(segment%nudged_tangential_vel)) deallocate(segment%nudged_tangential_vel)
@@ -3796,7 +4261,7 @@ subroutine deallocate_OBC_segment_data(segment)
if (allocated(segment%tangential_grad)) deallocate(segment%tangential_grad)
if (associated(segment%tr_Reg)) call segment_tracer_registry_end(segment%tr_Reg)
-
+ if (associated(segment%h_Reg)) call segment_thickness_registry_end(segment%h_Reg)
end subroutine deallocate_OBC_segment_data
@@ -3814,7 +4279,7 @@ subroutine open_boundary_test_extern_uv(G, GV, OBC, u, v)
if (.not. associated(OBC)) return
- do n = 1, OBC%number_of_segments
+ do n=1,OBC%number_of_segments
do k = 1, GV%ke
if (OBC%segment(n)%is_N_or_S) then
J = OBC%segment(n)%HI%JsdB
@@ -3860,7 +4325,7 @@ subroutine open_boundary_test_extern_h(G, GV, OBC, h)
silly_h = GV%Z_to_H * OBC%silly_h ! This rescaling is here because GV was initialized after OBC.
- do n = 1, OBC%number_of_segments
+ do n=1,OBC%number_of_segments
do k = 1, GV%ke
if (OBC%segment(n)%is_N_or_S) then
J = OBC%segment(n)%HI%JsdB
@@ -3890,690 +4355,575 @@ subroutine open_boundary_test_extern_h(G, GV, OBC, h)
end subroutine open_boundary_test_extern_h
-!> Update the OBC values on the segments.
-subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time)
- type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
- type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
- type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- type(ocean_OBC_type), pointer :: OBC !< Open boundary structure
- type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure
- real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Thickness [H ~> m or kg m-2]
- type(time_type), intent(in) :: Time !< Model time
+!> Read OBC values on the segments from files
+subroutine read_OBC_segment_data(G, GV, US, OBC, tv, h, Time)
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(ocean_OBC_type), pointer :: OBC !< Open boundary structure
+ type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2]
+ type(time_type), intent(in) :: Time !< Model time
+
! Local variables
- integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed
- integer :: IsdB, IedB, JsdB, JedB, n, m, nz, nt
+ integer :: i, j, k, n, m
+ integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
type(OBC_segment_type), pointer :: segment => NULL()
- integer, dimension(4) :: siz
real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input [various units]
integer :: ni_seg, nj_seg ! number of src gridpoints along the segments
integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer
- integer :: 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
+ real :: dz_stack(SZK_(GV)) ! Distance between the interfaces at corner points [Z ~> m]
+ integer :: i_seg_offset, j_seg_offset, bug_offset
real :: net_dz_src ! Total vertical extent of the incoming flow in the source field [Z ~> m]
real :: net_dz_int ! Total vertical extent of the incoming flow in the model [Z ~> m]
real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim]
- real :: tidal_vel ! Interpolated tidal velocity at the OBC points [L T-1 ~> m s-1]
- real :: tidal_elev ! Interpolated tidal elevation at the OBC points [Z ~> m]
- real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1]
integer :: turns ! Number of index quarter turns
- real :: time_delta ! Time since tidal reference date [T ~> s]
+ 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
+ if (.not. associated(OBC)) return
+ if (OBC%user_BCs_set_globally) return
- turns = G%HI%turns
+ turns = modulo(G%HI%turns, 4)
+ dz(:,:,:) = 0.0
+ call thickness_to_dz(h, tv, dz, G, GV, US)
+ call pass_var(dz, G%Domain)
- if (.not. associated(OBC)) return
+ do n=1,OBC%number_of_segments
+ segment => OBC%segment(n)
- if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref)
+ if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain
- if (OBC%number_of_segments >= 1) then
- call thickness_to_dz(h, tv, dz, G, GV, US)
- call pass_var(dz, G%Domain)
- endif
+ 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
- do n = 1, OBC%number_of_segments
- segment => OBC%segment(n)
+ ni_seg = segment%ie_obc - segment%is_obc + 1 ! Global number of q points
+ nj_seg = segment%je_obc - segment%js_obc + 1 ! Global number of q points
+ i_seg_offset = G%idg_offset - segment%HI%IsgB
+ j_seg_offset = G%jdg_offset - segment%HI%JsgB
- if (.not. segment%on_pe) cycle ! continue to next segment if not in computational domain
-
- ! NOTE: These are in segment%HI, but defined slightly differently
- ni_seg = segment%ie_obc-segment%is_obc+1
- nj_seg = segment%je_obc-segment%js_obc+1
- is_obc = max(segment%is_obc,isd-1)
- ie_obc = min(segment%ie_obc,ied)
- js_obc = max(segment%js_obc,jsd-1)
- je_obc = min(segment%je_obc,jed)
- i_seg_offset = G%idg_offset - segment%HI%Isgb
- j_seg_offset = G%jdg_offset - segment%HI%Jsgb
-
-! Calculate auxiliary fields at staggered locations.
-! Segment indices are on q points:
-!
-! |-----------|------------|-----------|-----------| J_obc
-! Is_obc Ie_obc
-!
-! i2 has to start at Is_obc+1 and end at Ie_obc.
-! j2 is J_obc and jshift has to be +1 at both the north and south.
-
- ! calculate auxiliary fields at staggered locations
- ishift=0;jshift=0
+ ! Calculate auxiliary fields at staggered locations
+ segment%dZtot(:,:) = 0.0
if (segment%is_E_or_W) then
- allocate(normal_trans_bt(segment%HI%IsdB:segment%HI%IedB,segment%HI%jsd:segment%HI%jed), source=0.0)
- if (segment%direction == OBC_DIRECTION_W) ishift=1
- I=segment%HI%IsdB
- do j=segment%HI%jsd,segment%HI%jed
- segment%Htot(I,j) = 0.0
- 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)
- allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB), source=0.0)
- if (segment%direction == OBC_DIRECTION_S) jshift=1
- J=segment%HI%JsdB
- do i=segment%HI%isd,segment%HI%ied
- segment%Htot(i,J) = 0.0
- 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
+ I = IsdB
+ ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points
+ do k = 1, GV%ke ; do j = max(jsd-1, G%jsd), min(jed+1, G%jed)
+ segment%dZtot(I,j) = segment%dZtot(I,j) + dz(isd,j,k)
+ enddo ; enddo
+ else ! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S)
+ J = JsdB
+ ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points
+ do k = 1, GV%ke ; do i = max(isd-1, G%isd), min(ied+1, G%ied)
+ segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,jsd,k)
+ enddo ; enddo
endif
- allocate(dz_stack(GV%ke), source=0.0)
- do m = 1,segment%num_fields
- !This field may not require a high frequency OBC segment update and might be allowed
- !a less frequent update as set by the parameter update_OBC_period_max in MOM.F90.
- !Cycle if it is not the time to update OBC segment data for this field.
- if (trim(segment%field(m)%genre) == 'obgc' .and. (.not. OBC%update_OBC_seg_data)) cycle
- if (segment%field(m)%use_IO) then
- siz(1) = size(segment%field(m)%buffer_src,1)
- siz(2) = size(segment%field(m)%buffer_src,2)
- siz(3) = size(segment%field(m)%buffer_src,3)
- if (.not.allocated(segment%field(m)%buffer_dst)) then
- if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency')
- if (segment%field(m)%nk_src > 1) then
- if (segment%is_E_or_W) then
- if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke))
- elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent
- elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase' .or. &
- segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,siz(3))) ! 3rd dim is constituent
- else
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke))
- endif
- else
- if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke))
- elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent
- elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase' .or. &
- segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then
- allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent
- else
- allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke))
- endif
- endif
- else
- if (segment%is_E_or_W) then
- if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. &
- segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1))
- else
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1))
- endif
- else
- if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. &
- segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1))
- else
- allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1))
- endif
- endif
- endif
- segment%field(m)%buffer_dst(:,:,:) = 0.0
+ ! Read data from files to buffer_src
+ do m=1,segment%num_fields
+ if (segment%field(m)%required .and. (.not. allocated(segment%field(m)%buffer_dst))) &
+ call MOM_error(FATAL, 'buffer_dst not allocated')
+
+ if ( (.not. segment%field(m)%use_IO) .or. & ! .and. (.not. segment%field(m)%required)
+ (segment%field(m)%bgc_tracer .and. (.not. OBC%update_OBC_seg_data)) ) &
+ !This field may not require a high frequency OBC segment update and might be allowed
+ !a less frequent update as set by the parameter update_OBC_period_max in MOM.F90.
+ !Cycle if it is not the time to update OBC segment data for this field.
+ cycle
+
+ ! read source data interpolated to the current model time
+ ! NOTE: buffer is sized for vertex points, but may be used for faces
+ if (segment%is_E_or_W) then
+ if (OBC%brushcutter_mode) then
+ allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currently on supergrid
+ else
+ allocate(tmp_buffer(1,nj_seg,segment%field(m)%nk_src)) ! segment data is currently on native grid
+ endif
+ else
+ if (OBC%brushcutter_mode) then
+ allocate(tmp_buffer(ni_seg*2-1,1,segment%field(m)%nk_src)) ! segment data is currently on supergrid
+ else
+ allocate(tmp_buffer(ni_seg,1,segment%field(m)%nk_src)) ! segment data is currently on native grid
+ endif
+ endif
+
+ ! TODO: Since we conditionally rotate a subset of tmp_buffer_in after
+ ! reading the value, it is currently not possible to use the rotated
+ ! implementation of time_interp_extern.
+ ! For now, we must explicitly allocate and rotate this array.
+ if (turns /= 0) then
+ if (modulo(turns, 2) /= 0) then
+ allocate(tmp_buffer_in(size(tmp_buffer, 2), size(tmp_buffer, 1), size(tmp_buffer, 3)))
+ else
+ allocate(tmp_buffer_in(size(tmp_buffer, 1), size(tmp_buffer, 2), size(tmp_buffer, 3)))
+ endif
+ else
+ tmp_buffer_in => tmp_buffer
+ endif
+
+ ! This is where the data values are actually read in.
+ call time_interp_external(segment%field(m)%handle, Time, tmp_buffer_in, scale=segment%field(m)%scale)
+
+ ! NOTE: Rotation of face-points require that we skip the final value when not in brushcutter mode.
+ if (turns /= 0) then
+ flip_buffer = ((turns==1) .or. (turns==3))
+ if (OBC%brushcutter_mode .or. (.not.flip_buffer)) then
+ call rotate_array(tmp_buffer_in, turns, tmp_buffer)
+ elseif (flip_buffer .and. segment%is_E_or_W .and. segment%field(m)%on_face) then
+ nj_buf = size(tmp_buffer, 2) - 1
+ call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:))
+ elseif (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then
+ ni_buf = size(tmp_buffer, 1) - 1
+ call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:))
+ else
+ call rotate_array(tmp_buffer_in, turns, tmp_buffer)
endif
- ! read source data interpolated to the current model time
- ! NOTE: buffer is sized for vertex points, but may be used for faces
- if (siz(1)==1) then
- if (OBC%brushcutter_mode) then
- allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currently on supergrid
+
+ if (((segment%field(m)%name == 'U') .and. ((turns==1).or.(turns==2))) .or. &
+ ((segment%field(m)%name == 'V') .and. ((turns==2).or.(turns==3))) .or. &
+ ((segment%field(m)%name == 'Vamp') .and. ((turns==2).or.(turns==3))) .or. &
+ ((segment%field(m)%name == 'Uamp') .and. ((turns==1).or.(turns==2))) .or. &
+ ((segment%field(m)%name == 'DVDX') .and. ((turns==1).or.(turns==3))) .or. &
+ ((segment%field(m)%name == 'DUDY') .and. ((turns==1).or.(turns==3))) ) then
+ tmp_buffer(:,:,:) = -tmp_buffer(:,:,:)
+ endif
+ endif
+
+ if (OBC%brushcutter_mode) then
+ ! In brushcutter mode, the input data includes vales at both the vorticity point nodes and
+ ! the velocity point faces of the OBC segments. The vorticity node values are at the odd
+ ! positions in tmp_buffer, while the faces are at the even points. The bug that is being
+ ! corrected here is the use of the odd indexed points for both the corners and the faces.
+ bug_offset = 0 ; if (OBC%hor_index_bug) bug_offset = -1
+ if (segment%is_E_or_W) then
+ if (.not.segment%field(m)%on_face) then
+ segment%field(m)%buffer_src(IsdB,:,:) = &
+ tmp_buffer(1, 2*(JsdB+j_seg_offset+1)-1:2*(JedB+j_seg_offset)+1:2, :)
else
- allocate(tmp_buffer(1,nj_seg,segment%field(m)%nk_src)) ! segment data is currently on native grid
+ segment%field(m)%buffer_src(IsdB,:,:) = &
+ tmp_buffer(1, 2*(JsdB+j_seg_offset+1)+bug_offset:2*(JedB+j_seg_offset):2, :)
endif
else
- if (OBC%brushcutter_mode) then
- allocate(tmp_buffer(ni_seg*2-1,1,segment%field(m)%nk_src)) ! segment data is currently on supergrid
+ if (.not.segment%field(m)%on_face) then
+ segment%field(m)%buffer_src(:,JsdB,:) = &
+ tmp_buffer(2*(IsdB+i_seg_offset+1)-1:2*(IedB+i_seg_offset)+1:2, 1, :)
else
- allocate(tmp_buffer(ni_seg,1,segment%field(m)%nk_src)) ! segment data is currently on native grid
+ segment%field(m)%buffer_src(:,JsdB,:) = &
+ tmp_buffer(2*(IsdB+i_seg_offset+1)+bug_offset:2*(IedB+i_seg_offset):2, 1, :)
endif
endif
-
- ! TODO: Since we conditionally rotate a subset of tmp_buffer_in after
- ! reading the value, it is currently not possible to use the rotated
- ! implementation of time_interp_extern.
- ! For now, we must explicitly allocate and rotate this array.
- if (turns /= 0) then
- if (modulo(turns, 2) /= 0) then
- allocate(tmp_buffer_in(size(tmp_buffer, 2), size(tmp_buffer, 1), size(tmp_buffer, 3)))
+ else ! Not brushcutter_mode.
+ if (segment%is_E_or_W) then
+ if (.not.segment%field(m)%on_face) then
+ segment%field(m)%buffer_src(IsdB,:,:) = &
+ tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset+1,:)
else
- allocate(tmp_buffer_in(size(tmp_buffer, 1), size(tmp_buffer, 2), size(tmp_buffer, 3)))
+ segment%field(m)%buffer_src(IsdB,:,:) = &
+ tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset,:)
endif
else
- tmp_buffer_in => tmp_buffer
+ if (.not.segment%field(m)%on_face) then
+ segment%field(m)%buffer_src(:,JsdB,:) = &
+ tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset+1,1,:)
+ else
+ segment%field(m)%buffer_src(:,JsdB,:) = &
+ tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset,1,:)
+ endif
endif
+ endif
- ! 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)
+ ! no dz for tidal variables
+ if (segment%field(m)%nk_src <= 1) then ! This is 2-d data with no remapping.
+ segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1)
+ elseif (field_is_tidal(segment%field(m)%name)) then
+ ! The 3rd axis for tidal variables is the tidal constituent, so there is no remapping.
+ segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:)
+ else
+ ! Read in 3-d data that may need to be remapped onto the new grid
+ ! This is also where the 2-d tidal data values (apart from phase and amp) are actually read in.
+ call time_interp_external(segment%field(m)%dz_handle, Time, tmp_buffer_in, scale=US%m_to_Z)
- ! NOTE: Rotation of face-points require that we skip the final value
if (turns /= 0) then
- ! TODO: This is hardcoded for 90 degrees, and needs to be generalized.
- if (segment%is_E_or_W &
- .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'Vamp' &
- .or. segment%field(m)%name == 'Vphase' .or. segment%field(m)%name == 'DVDX')) then
+ flip_buffer = ((turns==1) .or. (turns==3))
+ if (flip_buffer .and. segment%is_E_or_W .and. segment%field(m)%on_face) then
nj_buf = size(tmp_buffer, 2) - 1
call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:))
- elseif (segment%is_N_or_S &
- .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'Uamp' &
- .or. segment%field(m)%name == 'Uphase' .or. segment%field(m)%name == 'DUDY')) then
+ elseif (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then
ni_buf = size(tmp_buffer, 1) - 1
call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:))
else
call rotate_array(tmp_buffer_in, turns, tmp_buffer)
endif
-
- ! TODO: This is hardcoded for 90 degrees, and needs to be generalized.
- if (segment%field(m)%name == 'U' &
- .or. segment%field(m)%name == 'DVDX' &
- .or. segment%field(m)%name == 'DUDY' &
- .or. segment%field(m)%name == 'Uamp') then
- tmp_buffer(:,:,:) = -tmp_buffer(:,:,:)
- endif
- endif
+ endif ! End of rotation
if (OBC%brushcutter_mode) then
+ bug_offset = 0 ; if (OBC%hor_index_bug) bug_offset = -1
if (segment%is_E_or_W) then
- if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. &
- segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then
- segment%field(m)%buffer_src(is_obc,:,:) = &
- tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset)+1:2,:)
+ if (.not.segment%field(m)%on_face) then
+ segment%field(m)%dz_src(IsdB,:,:) = &
+ tmp_buffer(1, 2*(JsdB+j_seg_offset+1)-1:2*(JedB+j_seg_offset)+1:2, :)
else
- segment%field(m)%buffer_src(is_obc,:,:) = &
- tmp_buffer(1,2*(js_obc+j_seg_offset)+1:2*(je_obc+j_seg_offset):2,:)
+ segment%field(m)%dz_src(IsdB,:,:) = &
+ tmp_buffer(1, 2*(JsdB+j_seg_offset+1)+bug_offset:2*(JedB+j_seg_offset):2, :)
endif
else
- if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. &
- segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then
- segment%field(m)%buffer_src(:,js_obc,:) = &
- tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset)+1:2,1,:)
+ if (.not.segment%field(m)%on_face) then
+ segment%field(m)%dz_src(:,JsdB,:) = &
+ tmp_buffer(2*(IsdB+i_seg_offset+1)-1:2*(IedB+i_seg_offset)+1:2, 1, :)
else
- segment%field(m)%buffer_src(:,js_obc,:) = &
- tmp_buffer(2*(is_obc+i_seg_offset)+1:2*(ie_obc+i_seg_offset):2,1,:)
+ segment%field(m)%dz_src(:,JsdB,:) = &
+ tmp_buffer(2*(IsdB+i_seg_offset+1)+bug_offset:2*(IedB+i_seg_offset):2, 1, :)
endif
endif
- else
+ else ! Not brushcutter_mode.
if (segment%is_E_or_W) then
- if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. &
- segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then
- segment%field(m)%buffer_src(is_obc,:,:) = &
- tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset+1,:)
+ if (.not.segment%field(m)%on_face) then
+ segment%field(m)%dz_src(IsdB,:,:) = &
+ tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset+1,:)
else
- segment%field(m)%buffer_src(is_obc,:,:) = &
- tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset,:)
+ segment%field(m)%dz_src(IsdB,:,:) = &
+ tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset,:)
endif
else
- if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. &
- segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then
- segment%field(m)%buffer_src(:,js_obc,:) = &
- tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset+1,1,:)
+ if (.not.segment%field(m)%on_face) then
+ segment%field(m)%dz_src(:,JsdB,:) = &
+ tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset+1,1,:)
else
- segment%field(m)%buffer_src(:,js_obc,:) = &
- tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset,1,:)
+ segment%field(m)%dz_src(:,JsdB,:) = &
+ tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset,1,:)
endif
endif
endif
- ! no dz for tidal variables
- if (segment%field(m)%nk_src > 1 .and.&
- (index(segment%field(m)%name, 'phase') <= 0 .and. index(segment%field(m)%name, 'amp') <= 0)) then
- ! This is where the 2-d tidal data values 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
- nj_buf = size(tmp_buffer, 2) - 1
- call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:))
- elseif (segment%is_N_or_S &
- .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY')) then
- ni_buf = size(tmp_buffer, 1) - 1
- call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:))
- else
- call rotate_array(tmp_buffer_in, turns, tmp_buffer)
- endif
- endif
- if (OBC%brushcutter_mode) then
- if (segment%is_E_or_W) then
- if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then
- segment%field(m)%dz_src(is_obc,:,:) = &
- tmp_buffer(1,2*(js_obc+j_seg_offset)+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,:)
- endif
- else
- if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then
- segment%field(m)%dz_src(:,js_obc,:) = &
- tmp_buffer(2*(is_obc+i_seg_offset)+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,:)
+
+ 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
+ I = IsdB
+ if (.not.segment%field(m)%on_face) then
+ ! Do q points for the whole segment
+ do J = max(JsdB, G%jsd), min(JedB, G%jed-1)
+ ! Using the h remapping approach
+ ! Pretty sure we need to check for source/target grid consistency here
+ !### For a concave corner between OBC segments, there are 3 thicknesses we might
+ ! consider using.
+ segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer
+ if ((G%mask2dCu(I,j) > 0.0) .or. (G%mask2dCu(I,j+1) > 0.0)) then
+ dz_stack(:) = (1.0 / (G%mask2dCu(I,j) + G%mask2dCu(I,j+1))) * &
+ (G%mask2dCu(I,j) * dz(isd,j,:) + G%mask2dCu(I,j+1) * dz(isd,j+1,:))
+ call remapping_core_h(OBC%remap_z_CS, &
+ segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), &
+ segment%field(m)%buffer_src(I,J,:), &
+ GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:))
endif
- endif
+ enddo
else
- if (segment%is_E_or_W) then
- if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then
- segment%field(m)%dz_src(is_obc,:,:) = &
- tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+j_seg_offset+1,:)
- else
- segment%field(m)%dz_src(is_obc,:,:) = &
- 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
- segment%field(m)%dz_src(:,js_obc,:) = &
- tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset+1,1,:)
- else
- segment%field(m)%dz_src(:,js_obc,:) = &
- tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset,1,:)
+ do j = JsdB+1, JedB
+ ! Using the h remapping approach
+ ! Pretty sure we need to check for source/target grid consistency here
+ segment%field(m)%buffer_dst(I,j,:) = 0.0 ! initialize remap destination buffer
+ if (G%mask2dCu(I,j)>0.) then
+ net_dz_src = sum( segment%field(m)%dz_src(I,j,:) )
+ net_dz_int = sum( dz(isd,j,:) )
+ scl_fac = net_dz_int / net_dz_src
+ call remapping_core_h(OBC%remap_z_CS, &
+ segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), &
+ segment%field(m)%buffer_src(I,j,:), &
+ GV%ke, dz(isd,j,:), segment%field(m)%buffer_dst(I,j,:))
endif
- endif
+ enddo
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 (segment%is_E_or_W) then
- ishift=1
- if (segment%direction == OBC_DIRECTION_E) ishift=0
- I=is_obc
- if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then
- ! Do q points for the whole segment
- do J=max(js_obc,jsd),min(je_obc,jed-1)
- ! Using the h remapping approach
- ! Pretty sure we need to check for source/target grid consistency here
- segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer
- if (G%mask2dCu(I,j)>0. .and. G%mask2dCu(I,j+1)>0.) then
- dz_stack(:) = 0.5*(dz(i+ishift,j,:) + dz(i+ishift,j+1,:))
- call remapping_core_h(OBC%remap_z_CS, &
- segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), &
- segment%field(m)%buffer_src(I,J,:), &
- GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:))
- elseif (G%mask2dCu(I,j)>0.) then
- dz_stack(:) = dz(i+ishift,j,:)
- call remapping_core_h(OBC%remap_z_CS, &
- segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), &
- segment%field(m)%buffer_src(I,J,:), &
- GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:))
- elseif (G%mask2dCu(I,j+1)>0.) then
- dz_stack(:) = dz(i+ishift,j+1,:)
- call remapping_core_h(OBC%remap_z_CS, &
- segment%field(m)%nk_src, segment%field(m)%dz_src(I,j,:), &
- segment%field(m)%buffer_src(I,J,:), &
- GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:))
- endif
- enddo
- else
- do j=js_obc+1,je_obc
+ else
+ J = JsdB
+ if (.not.segment%field(m)%on_face) then
+ ! Do q points for the whole segment
+ do I = max(IsdB, G%isd), min(IedB, G%ied-1)
+ segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer
+ if ((G%mask2dCv(i,J) > 0.0) .or. (G%mask2dCv(i+1,J) > 0.0)) then
! Using the h remapping approach
! Pretty sure we need to check for source/target grid consistency here
- segment%field(m)%buffer_dst(I,j,:) = 0.0 ! initialize remap destination buffer
- if (G%mask2dCu(I,j)>0.) then
- net_dz_src = sum( segment%field(m)%dz_src(I,j,:) )
- net_dz_int = sum( dz(i+ishift,j,:) )
- scl_fac = net_dz_int / net_dz_src
- call remapping_core_h(OBC%remap_z_CS, &
- segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), &
- segment%field(m)%buffer_src(I,j,:), &
- GV%ke, dz(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:))
- endif
- enddo
- endif
+ dz_stack(:) = (1.0 / (G%mask2dCv(i,J) + G%mask2dCv(i+1,J))) * &
+ (G%mask2dCv(i,J) * dz(i,jsd,:) + G%mask2dCv(i+1,J) * dz(i+1,jsd,:))
+ call remapping_core_h(OBC%remap_z_CS, &
+ segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), &
+ segment%field(m)%buffer_src(I,J,:), &
+ GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:))
+ endif
+ enddo
else
- jshift=1
- if (segment%direction == OBC_DIRECTION_N) jshift=0
- J=js_obc
- if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then
- ! Do q points for the whole segment
- do I=max(is_obc,isd),min(ie_obc,ied-1)
- segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer
- if (G%mask2dCv(i,J)>0. .and. G%mask2dCv(i+1,J)>0.) then
- ! Using the h remapping approach
- ! Pretty sure we need to check for source/target grid consistency here
- dz_stack(:) = 0.5*(dz(i,j+jshift,:) + dz(i+1,j+jshift,:))
- call remapping_core_h(OBC%remap_z_CS, &
- segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), &
- segment%field(m)%buffer_src(I,J,:), &
- GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:))
- elseif (G%mask2dCv(i,J)>0.) then
- dz_stack(:) = dz(i,j+jshift,:)
- call remapping_core_h(OBC%remap_z_CS, &
- segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), &
- segment%field(m)%buffer_src(I,J,:), &
- GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:))
- elseif (G%mask2dCv(i+1,J)>0.) then
- dz_stack(:) = dz(i+1,j+jshift,:)
- call remapping_core_h(OBC%remap_z_CS, &
- segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), &
- segment%field(m)%buffer_src(I,J,:), &
- GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:))
- endif
- enddo
- else
- do i=is_obc+1,ie_obc
- ! Using the h remapping approach
- ! Pretty sure we need to check for source/target grid consistency here
- segment%field(m)%buffer_dst(i,J,:) = 0.0 ! initialize remap destination buffer
- if (G%mask2dCv(i,J)>0.) then
- net_dz_src = sum( segment%field(m)%dz_src(i,J,:) )
- net_dz_int = sum( dz(i,j+jshift,:) )
- scl_fac = net_dz_int / net_dz_src
- call remapping_core_h(OBC%remap_z_CS, &
- segment%field(m)%nk_src, scl_fac* segment%field(m)%dz_src(i,J,:), &
- segment%field(m)%buffer_src(i,J,:), &
- GV%ke, dz(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:))
- endif
- enddo
- endif
+ do i = IsdB+1, IedB
+ ! Using the h remapping approach
+ ! Pretty sure we need to check for source/target grid consistency here
+ segment%field(m)%buffer_dst(i,J,:) = 0.0 ! initialize remap destination buffer
+ if (G%mask2dCv(i,J)>0.) then
+ net_dz_src = sum( segment%field(m)%dz_src(i,J,:) )
+ net_dz_int = sum( dz(i,jsd,:) )
+ scl_fac = net_dz_int / net_dz_src
+ call remapping_core_h(OBC%remap_z_CS, &
+ segment%field(m)%nk_src, scl_fac* segment%field(m)%dz_src(i,J,:), &
+ segment%field(m)%buffer_src(i,J,:), &
+ GV%ke, dz(i,jsd,:), segment%field(m)%buffer_dst(i,J,:))
+ endif
+ enddo
endif
- elseif (segment%field(m)%nk_src > 1 .and. &
- (index(segment%field(m)%name, 'phase') > 0 .or. index(segment%field(m)%name, 'amp') > 0)) then
- ! no dz for tidal variables
- segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:)
- else ! 2d data
- segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer
- endif
- deallocate(tmp_buffer)
- if (turns /= 0) &
- deallocate(tmp_buffer_in)
- else ! 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
- else
- if (segment%field(m)%name == 'U') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke))
- elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1))
- elseif (segment%field(m)%name == 'V') then
- allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke))
- elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then
- allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1))
- elseif (segment%field(m)%name == 'DUDY') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke))
- elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' &
- .or. segment%field(m)%name == 'SSHphase') then
- allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1))
- else
- allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke))
- endif
- endif
- segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value
endif
endif
- enddo
- ! Start second loop to update all fields now that data for all fields are available.
- ! (split because tides depend on multiple variables).
- do m = 1,segment%num_fields
- !cycle if it is not the time to update OBGC tracers from source
- if (trim(segment%field(m)%genre) == 'obgc' .and. (.not. OBC%update_OBC_seg_data)) cycle
- ! if (segment%field(m)%use_IO) then
- ! calculate external BT velocity and transport if needed
- if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then
- if (trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) then
- I=is_obc
- do j=js_obc+1,je_obc
- normal_trans_bt(I,j) = 0.0
- tidal_vel = 0.0
- if (OBC%add_tide_constituents) then
- do c=1,OBC%n_tide_constituents
- tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%uamp_index)%buffer_dst(I,j,c)) * &
- cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c)) &
- + (OBC%tide_eq_phases(c) + OBC%tide_un(c)))
- enddo
- endif
- do k=1,GV%ke
- segment%normal_vel(I,j,k) = segment%field(m)%buffer_dst(I,j,k) + tidal_vel
- segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k)*segment%h(I,j,k) * G%dyCu(I,j)
- normal_trans_bt(I,j) = normal_trans_bt(I,j) + segment%normal_trans(I,j,k)
- enddo
- segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) &
- / (max(segment%Htot(I,j), 1.e-12 * GV%m_to_H) * G%dyCu(I,j))
- if (allocated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:)
- enddo
- elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then
- J=js_obc
- do i=is_obc+1,ie_obc
- normal_trans_bt(i,J) = 0.0
- tidal_vel = 0.0
- if (OBC%add_tide_constituents) then
- do c=1,OBC%n_tide_constituents
- tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%vamp_index)%buffer_dst(I,j,c)) * &
- cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c)) &
- + (OBC%tide_eq_phases(c) + OBC%tide_un(c)))
- enddo
- endif
- do k=1,GV%ke
- segment%normal_vel(i,J,k) = segment%field(m)%buffer_dst(i,J,k) + tidal_vel
- segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k)*segment%h(i,J,k) * &
- G%dxCv(i,J)
- normal_trans_bt(i,J) = normal_trans_bt(i,J) + segment%normal_trans(i,J,k)
- enddo
- segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) &
- / (max(segment%Htot(i,J), 1.e-12 * GV%m_to_H) * G%dxCv(i,J))
- if (allocated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:)
- enddo
- elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. &
- allocated(segment%tangential_vel)) then
- I=is_obc
- do J=js_obc,je_obc
- tidal_vel = 0.0
- if (OBC%add_tide_constituents) then
- do c=1,OBC%n_tide_constituents
- tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%vamp_index)%buffer_dst(I,j,c)) * &
- cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c)) &
- + (OBC%tide_eq_phases(c) + OBC%tide_un(c)))
- enddo
- endif
- do k=1,GV%ke
- segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + tidal_vel
- enddo
- if (allocated(segment%nudged_tangential_vel)) &
- segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:)
- enddo
- elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. &
- allocated(segment%tangential_vel)) then
- J=js_obc
- do I=is_obc,ie_obc
- tidal_vel = 0.0
- if (OBC%add_tide_constituents) then
- do c=1,OBC%n_tide_constituents
- tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%uamp_index)%buffer_dst(I,j,c)) * &
- cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c)) &
- + (OBC%tide_eq_phases(c) + OBC%tide_un(c)))
- enddo
- endif
- do k=1,GV%ke
- segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + tidal_vel
- enddo
- if (allocated(segment%nudged_tangential_vel)) &
- segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:)
- enddo
- endif
- elseif (trim(segment%field(m)%name) == 'DVDX' .and. segment%is_E_or_W .and. &
- allocated(segment%tangential_grad)) then
- I=is_obc
- do J=js_obc,je_obc
- do k=1,GV%ke
- segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k)
- if (allocated(segment%nudged_tangential_grad)) &
- segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:)
- enddo
- enddo
- elseif (trim(segment%field(m)%name) == 'DUDY' .and. segment%is_N_or_S .and. &
- allocated(segment%tangential_grad)) then
- J=js_obc
- do I=is_obc,ie_obc
- do k=1,GV%ke
- segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k)
- if (allocated(segment%nudged_tangential_grad)) &
- segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:)
- enddo
- enddo
- endif
+ deallocate(tmp_buffer)
+ if (turns /= 0) deallocate(tmp_buffer_in)
+ enddo ! end field loop
+ enddo ! endd segment loop
+end subroutine read_OBC_segment_data
+
+!> Update OBC segment velocities, gradient, SSH and the external fields %t of thickness/tracer reservoirs.
+subroutine update_OBC_segment_data(G, GV, US, OBC, h, Time)
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ type(ocean_OBC_type), pointer :: OBC !< Open boundary structure
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2]
+ type(time_type), intent(in) :: Time !< Model time
- ! endif
+ ! Local variables
+ type(OBC_segment_type), pointer :: segment => NULL()
+ integer :: c, i, j, k, n, m, nz, nt
+ integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
+ integer :: is_seg, ie_seg, js_seg, je_seg ! Orientation-agnostic loop ranges
+ integer :: i_offset_in, j_offset_in ! Indexing offset for interior cells
+ integer :: F_G, F_VN, F_VNAMP, F_VNPHASE, F_VT, F_VTAMP, F_VTPHASE ! Field indices
+ real :: ramp_value ! If OBC%ramp is True, where we are on the ramp from 0 to 1, or 1 otherwise [nondim].
+ real :: time_delta ! Time since tidal reference date [T ~> s]
+ real :: tidal_amp, tidal_phase ! Tidal amplitude [Z ~> m] and phase [rad]
+
+ if (.not. associated(OBC)) return
+ if (OBC%user_BCs_set_globally) return
+
+ nz = GV%ke
+
+ if (OBC%add_tide_constituents) &
+ time_delta = time_minus_signed(Time, OBC%time_ref, scale=US%s_to_T)
- ! from this point on, data are entirely on segments - will
- ! write all segment loops as 2d loops.
+ do n=1,OBC%number_of_segments
+ segment => OBC%segment(n)
+
+ if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain
+
+ ! Segment indices are on q points:
+ ! | x | x | x | x | jsd/jed (if southern boundary)
+ ! |-----------|-----------|-----------|-----------| JsdB/JedB
+ ! IsdB isd ied IedB
+ ! | x | x | x | x | jsd/jed (if northern boundary)
+
+ isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
+ jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB
+ i_offset_in = ied - IedB ! = 0 if East, South, North; = 1 if West
+ j_offset_in = jed - JedB ! = 0 if North, West, East ; = 1 if South
+
+ if (segment%is_E_or_W) then
+ is_seg = IsdB ; ie_seg = is_seg
+ js_seg = jsd ; je_seg = jed
+ F_VN = F_U ; F_VNAMP = F_UAMP ; F_VNPHASE = F_UPHASE
+ F_VT = F_V ; F_VTAMP = F_VAMP ; F_VTPHASE = F_VPHASE ; F_G = F_VX
+ else
+ is_seg = isd ; ie_seg = ied
+ js_seg = JsdB ; je_seg = js_seg
+ F_VN = F_V ; F_VNAMP = F_VAMP ; F_VNPHASE = F_VPHASE
+ F_VT = F_U ; F_VTAMP = F_UAMP ; F_VTPHASE = F_UPHASE ; F_G = F_UY
+ endif
+
+ ! Update normal velocity, transport. Split by orientation for now because of G%dyCu and G%dxCv.
+ if (allocated(segment%field(F_VN)%buffer_dst)) then
+ ! Update tidal normal velocity
+ segment%tidal_vn(:,:) = 0.0
+ if (OBC%add_tide_constituents) then
+ do c=1,OBC%n_tide_constituents ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ tidal_amp = OBC%tide_fn(c) * segment%field(F_VNAMP)%buffer_dst(i,j,c)
+ tidal_phase = (time_delta * OBC%tide_frequencies(c) - segment%field(F_VNPHASE)%buffer_dst(i,j,c)) &
+ + (OBC%tide_eq_phases(c) + OBC%tide_un(c))
+ segment%tidal_vn(i,j) = segment%tidal_vn(i,j) + tidal_amp * cos(tidal_phase)
+ enddo ; enddo ; enddo
+ endif
+
+ segment%Htot(:,:) = 0.0
+ segment%normal_trans_bt(:,:) = 0.0
if (segment%is_E_or_W) then
- js_obc2 = js_obc+1
- is_obc2 = is_obc
+ do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%Htot(i,j) = segment%Htot(i,j) + h(i+i_offset_in,j+j_offset_in,k)
+ segment%normal_vel(i,j,k) = segment%field(F_VN)%buffer_dst(i,j,k) + segment%tidal_vn(i,j)
+ segment%normal_trans(i,j,k) = &
+ segment%normal_vel(i,j,k) * h(i+i_offset_in,j+j_offset_in,k) * G%dyCu(i,j)
+ segment%normal_trans_bt(i,j) = segment%normal_trans_bt(i,j) + segment%normal_trans(i,j,k)
+ enddo ; enddo ; enddo
+ do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%normal_vel_bt(i,j) = segment%normal_trans_bt(i,j) &
+ / (max(segment%Htot(i,j), 1.e-12 * GV%m_to_H) * G%dyCu(i,j))
+ enddo ; enddo
else
- js_obc2 = js_obc
- is_obc2 = is_obc+1
+ do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%Htot(i,j) = segment%Htot(i,j) + h(i+i_offset_in,j+j_offset_in,k)
+ segment%normal_vel(i,j,k) = segment%field(F_VN)%buffer_dst(i,j,k) + segment%tidal_vn(i,j)
+ segment%normal_trans(i,j,k) = &
+ segment%normal_vel(i,j,k) * h(i+i_offset_in,j+j_offset_in,k) * G%dxCv(i,j)
+ segment%normal_trans_bt(i,j) = segment%normal_trans_bt(i,j) + segment%normal_trans(i,j,k)
+ enddo ; enddo ; enddo
+ do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%normal_vel_bt(i,j) = segment%normal_trans_bt(i,j) &
+ / (max(segment%Htot(i,j), 1.e-12 * GV%m_to_H) * G%dxCv(i,j))
+ enddo ; enddo
endif
- if (segment%is_N_or_S) then
- is_obc2 = is_obc+1
- js_obc2 = js_obc
- else
- is_obc2 = is_obc
- js_obc2 = js_obc+1
+
+ if (allocated(segment%nudged_normal_vel)) then
+ do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%nudged_normal_vel(i,j,k) = segment%normal_vel(i,j,k)
+ enddo ; enddo ; enddo
endif
+ endif
- if (trim(segment%field(m)%name) == 'SSH') then
- if (OBC%ramp) then
- do j=js_obc2,je_obc
- do i=is_obc2,ie_obc
- tidal_elev = 0.0
- if (OBC%add_tide_constituents) then
- do c=1,OBC%n_tide_constituents
- tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * &
- cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) &
- + (OBC%tide_eq_phases(c) + OBC%tide_un(c)))
- enddo
- endif
- segment%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)
- enddo
- enddo
- endif
+ ! Update tangential velocity
+ if (allocated(segment%tangential_vel) .and. allocated(segment%field(F_VT)%buffer_dst)) then
+ ! Update tidal tangential velocity
+ segment%tidal_vt(:,:) = 0.0
+ if (OBC%add_tide_constituents) then
+ do c=1,OBC%n_tide_constituents ; do J=JsdB,JedB ; do I=IsdB,IedB
+ tidal_amp = OBC%tide_fn(c) * segment%field(F_VTAMP)%buffer_dst(I,J,c)
+ tidal_phase = (time_delta * OBC%tide_frequencies(c) - segment%field(F_VTPHASE)%buffer_dst(I,J,c)) &
+ + (OBC%tide_eq_phases(c) + OBC%tide_un(c))
+ segment%tidal_vt(I,J) = segment%tidal_vt(I,J) + tidal_amp * cos(tidal_phase)
+ enddo ; enddo ; enddo
endif
- if (trim(segment%field(m)%name) == 'TEMP') then
- if (allocated(segment%field(m)%buffer_dst)) then
- do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc
- segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k)
- enddo ; enddo ; enddo
- if (.not. segment%tr_Reg%Tr(1)%is_initialized) then
- ! if the tracer reservoir has not yet been initialized, then set to external value.
- do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc
- segment%tr_Reg%Tr(1)%tres(i,j,k) = segment%tr_Reg%Tr(1)%t(i,j,k)
- enddo ; enddo ; enddo
- segment%tr_Reg%Tr(1)%is_initialized=.true.
- endif
- else
- segment%tr_Reg%Tr(1)%OBC_inflow_conc = segment%field(m)%value
- endif
- elseif (trim(segment%field(m)%name) == 'SALT') then
- if (allocated(segment%field(m)%buffer_dst)) then
- do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc
- segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k)
- enddo ; enddo ; enddo
- if (.not. segment%tr_Reg%Tr(2)%is_initialized) then
- !if the tracer reservoir has not yet been initialized, then set to external value.
- do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc
- segment%tr_Reg%Tr(2)%tres(i,j,k) = segment%tr_Reg%Tr(2)%t(i,j,k)
- enddo ; enddo ; enddo
- segment%tr_Reg%Tr(2)%is_initialized=.true.
- endif
- else
- segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value
- endif
- 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))
- 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.
- 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
- segment%tr_Reg%Tr(nt)%is_initialized=.true.
- endif
- else
- segment%tr_Reg%Tr(nt)%OBC_inflow_conc = segment%field(m)%value
- endif
+ do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB
+ segment%tangential_vel(I,J,k) = segment%field(F_VT)%buffer_dst(I,J,k) + segment%tidal_vt(I,J)
+ enddo ; enddo ; enddo
+
+ if (allocated(segment%nudged_tangential_vel)) then
+ do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB
+ segment%nudged_tangential_vel(I,J,k) = segment%tangential_vel(I,J,k)
+ enddo ; enddo ; enddo
endif
+ endif
- enddo ! end field loop
- deallocate(dz_stack)
- deallocate(normal_trans_bt)
+ ! Update tangential gradient dvdx and dudy
+ if (allocated(segment%tangential_grad) .and. allocated(segment%field(F_G)%buffer_dst)) then
+ do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB
+ segment%tangential_grad(I,J,k) = segment%field(F_G)%buffer_dst(I,J,k)
+ enddo ; enddo ; enddo
- enddo ! end segment loop
+ if (allocated(segment%nudged_tangential_grad)) then
+ do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB
+ segment%nudged_tangential_grad(I,J,k) = segment%tangential_grad(I,J,k)
+ enddo ; enddo ; enddo
+ endif
+ endif
+
+ ! Update SSH
+ if (allocated(segment%field(F_Z)%buffer_dst)) then
+ ! Update tidal SSH
+ segment%tidal_elev(:,:) = 0.0
+ if (OBC%add_tide_constituents) then
+ do c=1,OBC%n_tide_constituents ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ tidal_amp = OBC%tide_fn(c) * segment%field(F_ZAMP)%buffer_dst(i,j,c)
+ tidal_phase = (time_delta * OBC%tide_frequencies(c) - segment%field(F_ZPHASE)%buffer_dst(i,j,c)) &
+ + (OBC%tide_eq_phases(c) + OBC%tide_un(c))
+ segment%tidal_elev(i,j) = segment%tidal_elev(i,j) + tidal_amp * cos(tidal_phase)
+ enddo ; enddo ; enddo
+ endif
+ ramp_value = 1.0 ; if (OBC%ramp) ramp_value = OBC%ramp_value
+ do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%SSH(i,j) = ramp_value * (segment%field(F_Z)%buffer_dst(i,j,1) + segment%tidal_elev(i,j))
+ enddo ; enddo
+ endif
+
+ ! Update thickness registry
+ if (OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used) then
+ do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%h_Reg%h(i,j,k) = h(i+i_offset_in,j+j_offset_in,k)
+ enddo ; enddo ; enddo
+ endif
+
+ ! Update tracer registry
+ do m = NUM_PHYS_FIELDS-1, segment%num_fields ! F_T = NUM_PHYS_FIELDS-1 and F_S = NUM_PHYS_FIELDS
+ if (.not. allocated(segment%field(m)%buffer_dst) .or. &
+ (segment%field(m)%bgc_tracer .and. (.not. OBC%update_OBC_seg_data))) then
+ cycle
+ endif
+ nt = segment%field(m)%tr_index
+ ! Note the following unnecessary IF-branch is kept from the old code (as recent as Jan 2026).
+ ! In the old code segment%field(m)%buffer_dst is always allocated at this point, and therefore
+ ! the "else" section is unreachable. This will be fixed when OBC_inflow_conc is reworked.
+ if (allocated(segment%field(m)%buffer_dst)) then
+ do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k)
+ enddo ; enddo ; enddo
+ else
+ segment%tr_Reg%Tr(nt)%OBC_inflow_conc = segment%field(m)%value
+ endif
+ enddo ! end tracer field loop
+ enddo ! end segment loop
end subroutine update_OBC_segment_data
+!> Initialize thickness and tracer reservoirs to external value.
+subroutine initialize_OBC_segment_reservoirs(GV, OBC)
+ type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
+ type(ocean_OBC_type), pointer :: OBC !< Open boundary structure
+
+ ! Local variables
+ type(OBC_segment_type), pointer :: segment => NULL()
+ integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
+ integer :: is_seg, ie_seg, js_seg, je_seg, nz
+ integer :: n, m, nt, i, j, k
+ character(len=256) :: msg ! Error message
+
+ if (.not. associated(OBC)) return
+
+ nz = GV%ke
+
+ do n=1,OBC%number_of_segments
+ segment => OBC%segment(n)
+
+ if (.not. segment%on_pe) cycle
+
+ isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
+ jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB
+
+ if (segment%is_E_or_W) then
+ is_seg = IsdB ; ie_seg = IedB ! = is_seg
+ js_seg = jsd ; je_seg = jed
+ else
+ is_seg = isd ; ie_seg = ied
+ js_seg = JsdB ; je_seg = JedB ! = js_seg
+ endif
+
+ ! Thickness
+ ! If the thickness reservoir has not yet been initialized, then set to external value.
+ if (OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used) then
+ if (.not. segment%h_Reg%is_initialized) then ! h_Reg may be initialized by fill_thickness_segments
+ do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%h_Reg%h_res(i,j,k) = segment%h_Reg%h(i,j,k)
+ enddo ; enddo ; enddo
+ segment%h_Reg%is_initialized = .true.
+ endif
+ endif
+
+ ! Tracers
+ ! If the tracer reservoir has not yet been initialized, then set to external value.
+ do m=NUM_PHYS_FIELDS-1, segment%num_fields ! F_T = NUM_PHYS_FIELDS-1 and F_S = NUM_PHYS_FIELDS
+ if (.not. allocated(segment%field(m)%buffer_dst)) cycle
+ nt = segment%field(m)%tr_index
+ if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then ! T/S may be initialized by fill_temp_salt_segments
+ do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
+ segment%tr_Reg%Tr(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k)
+ enddo ; enddo ; enddo
+ segment%tr_Reg%Tr(nt)%is_initialized = .true.
+ endif
+ enddo ! end tracer field loop
+ enddo ! end segment loop
+end subroutine initialize_OBC_segment_reservoirs
+
!> Update the OBC ramp value as a function of time.
!! If called with the optional argument activate=.true., record the
!! value of Time as the beginning of the ramp period.
@@ -4601,7 +4951,7 @@ subroutine update_OBC_ramp(Time, OBC, US, activate)
endif
endif
if (.not.OBC%ramping_is_activated) return
- deltaTime = max( 0., US%s_to_T*time_type_to_real( Time - OBC%ramp_start_time ) )
+ deltaTime = max(0., time_minus_signed(Time, OBC%ramp_start_time, scale=US%s_to_T))
if (deltaTime >= OBC%trunc_ramp_time) then
OBC%ramp_value = 1.0
OBC%ramp = .false. ! This turns off ramping after this call
@@ -4614,8 +4964,7 @@ subroutine update_OBC_ramp(Time, OBC, US, activate)
OBC%ramp_value = wghtA
endif
write(msg(1:12),'(es12.3)') OBC%ramp_value
- call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC"// &
- " ramp to "//trim(msg))
+ call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC ramp to "//trim(msg))
end subroutine update_OBC_ramp
!> register open boundary objects for boundary updates.
@@ -4629,7 +4978,7 @@ subroutine register_OBC(name, param_file, Reg)
if (.not. associated(Reg)) call OBC_registry_init(param_file, Reg)
if (Reg%nobc>=MAX_FIELDS_) then
- write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for &
+ write(mesg, '("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for &
&all the open boundaries being registered via register_OBC.")') Reg%nobc+1
call MOM_error(FATAL,"MOM register_OBC: "//mesg)
endif
@@ -4662,9 +5011,8 @@ subroutine OBC_registry_init(param_file, Reg)
init_calls = init_calls + 1
if (init_calls > 1) then
- write(mesg,'("OBC_registry_init called ",I3, &
- &" times with different registry pointers.")') init_calls
- if (is_root_pe()) call MOM_error(WARNING,"MOM_open_boundary"//mesg)
+ write(mesg,'("OBC_registry_init called ",I0," times with different registry pointers.")') init_calls
+ if (is_root_pe()) call MOM_error(WARNING,"MOM_open_boundary: "//trim(mesg))
endif
end subroutine OBC_registry_init
@@ -4723,15 +5071,80 @@ subroutine segment_tracer_registry_init(param_file, segment)
! Read all relevant parameters and write them to the model log.
if (init_calls == 1) call log_version(param_file, mdl, version, "")
-! Need to call once per segment with tracers...
-! if (init_calls > 1) then
-! write(mesg,'("segment_tracer_registry_init called ",I3, &
-! &" times with different registry pointers.")') init_calls
-! if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer"//mesg)
-! endif
-
end subroutine segment_tracer_registry_init
+!> Initialize all the segment thickness reservoirs.
+subroutine segment_thickness_reservoir_init(GV, US, OBC, param_file)
+ type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters
+ type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure
+ type(unit_scale_type), intent(in) :: US !< Unit scaling type
+ type(ocean_OBC_type), pointer :: OBC !< Open boundary structure
+! real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer
+! !! inflow concentration, including any rescaling to
+! !! put the tracer concentration into its internal units,
+! !! like [S ~> ppt] for salinity.
+! logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer
+! !! inflow concentration.
+! Local variables
+ real :: rescale ! A multiplicatively corrected scaling factor, in units like [S ppt-1 ~> 1] for
+ ! salinity, or other various units depending on what rescaling has occurred previously.
+ integer :: nseg, m, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
+ integer :: fd_id
+ type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list
+ integer, save :: init_calls = 0
+
+! This include declares and sets the variable "version".
+# include "version_variable.h"
+ character(len=40) :: mdl = "segment_thickness_reservoir_init" ! This routine's name.
+
+ if (.not. associated(OBC)) return
+
+ do nseg=1, OBC%number_of_segments
+ segment=>OBC%segment(nseg)
+ if (.not. segment%on_pe) cycle
+
+ if (associated(segment%h_Reg)) &
+ call MOM_error(FATAL,"segment_thickness_reservoir_init: thickness array was previously allocated")
+ allocate(segment%h_Reg)
+
+ isd = segment%HI%isd ; ied = segment%HI%ied
+ jsd = segment%HI%jsd ; jed = segment%HI%jed
+ IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
+ JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB
+
+ fd_id = -1
+ do m=1,segment%num_fields
+ if (lowercase(segment%field(m)%name) == lowercase(segment%h_Reg%name)) fd_id = m
+ enddo
+ segment%h_Reg%scale = US%Z_to_m
+ do m=1,segment%num_fields
+ if (uppercase(segment%field(m)%name) == uppercase(segment%h_Reg%name)) then
+ if (.not. segment%field(m)%use_IO) then
+ rescale = 1.0
+ if ((segment%field(m)%scale /= 0.0) .and. (segment%field(m)%scale /= 1.0)) &
+ rescale = 1.0 / segment%field(m)%scale
+ segment%field(m)%value = rescale * segment%field(m)%value
+ endif
+ endif
+ enddo
+
+ if (segment%is_E_or_W) then
+ allocate(segment%h_Reg%h(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0)
+ allocate(segment%h_Reg%h_res(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0)
+ elseif (segment%is_N_or_S) then
+ allocate(segment%h_Reg%h(isd:ied,JsdB:JedB,1:GV%ke), source=0.0)
+ allocate(segment%h_Reg%h_res(isd:ied,JsdB:JedB,1:GV%ke), source=0.0)
+ endif
+ segment%h_Reg%is_initialized = .false.
+
+ init_calls = init_calls + 1
+
+ ! Read all relevant parameters and write them to the model log.
+ if (init_calls == 1) call log_version(param_file, mdl, version, "")
+ enddo
+
+end subroutine segment_thickness_reservoir_init
+
!> Register a tracer array that is active on an OBC segment, potentially also specifying how the
!! tracer inflow values are specified.
subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, &
@@ -4768,7 +5181,7 @@ subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, &
call segment_tracer_registry_init(param_file, segment)
if (segment%tr_Reg%ntseg>=MAX_FIELDS_) then
- write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for &
+ write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for &
&all the tracers being registered via register_segment_tracer.")') segment%tr_Reg%ntseg+1
call MOM_error(FATAL,"MOM register_segment_tracer: "//mesg)
endif
@@ -4813,11 +5226,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 +5251,20 @@ subroutine segment_tracer_registry_end(Reg)
endif
end subroutine segment_tracer_registry_end
+!> Clean up the segment thickness object
+subroutine segment_thickness_registry_end(Reg)
+ type(OBC_segment_thickness_type), pointer :: Reg !< pointer to thickness reservoir
+
+! Local variables
+
+ if (associated(Reg)) then
+ if (allocated(Reg%h)) deallocate(Reg%h)
+ if (allocated(Reg%h_res)) deallocate(Reg%h_res)
+ deallocate(Reg)
+ endif
+end subroutine segment_thickness_registry_end
+
+!> Registers the temperature and salinity in the segment tracer registry.
subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file)
type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< Unit scaling type
@@ -4845,7 +5272,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
@@ -4853,8 +5280,8 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file)
if (.not. associated(OBC)) return
- do n=1, OBC%number_of_segments
- segment=>OBC%segment(n)
+ do n=1,OBC%number_of_segments
+ segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
if (associated(segment%tr_Reg)) &
@@ -4912,22 +5339,23 @@ 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
+ integer :: ntr_id, fd_id
+ integer :: n, m
type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list
type(tracer_type), pointer :: tr_ptr => NULL()
if (.not. associated(OBC)) return
- do n=1, OBC%number_of_segments
- segment=>OBC%segment(n)
+ do n=1,OBC%number_of_segments
+ segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, tr_name)
! get the obgc field index
@@ -4940,6 +5368,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
@@ -4956,10 +5385,10 @@ subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name)
if (.not. associated(OBC)) return
call pass_var(tr_ptr, G%Domain)
nz = G%ke
- do n=1, OBC%number_of_segments
+ do n=1,OBC%number_of_segments
segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
- 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 +5396,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,12 +5465,9 @@ 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
+ do n=1,OBC%number_of_segments
segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
@@ -5048,13 +5500,68 @@ 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
+!> Set the value of temperatures and salinities on OBC segments
+subroutine fill_thickness_segments(G, GV, US, OBC, h)
+ type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
+ type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure
+ type(unit_scale_type), intent(in) :: US !< Unit scaling
+ type(ocean_OBC_type), pointer :: OBC !< Open boundary structure
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]
+
+ integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz
+ integer :: i, j, k
+ type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list
+
+ if (.not. associated(OBC)) return
+ ! Both temperature and salinity fields
+
+ nz = GV%ke
+
+ do n=1, OBC%number_of_segments
+ segment => OBC%segment(n)
+ if (.not. segment%on_pe) cycle
+
+ isd = segment%HI%isd ; ied = segment%HI%ied
+ jsd = segment%HI%jsd ; jed = segment%HI%jed
+ IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
+ JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB
+
+ ! Fill with thickness
+ if (segment%is_E_or_W) then
+ I=segment%HI%IsdB
+ do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed
+ if (segment%direction == OBC_DIRECTION_W) then
+ segment%h_Reg%h(I,j,k) = h(i+1,j,k)
+ else
+ segment%h_Reg%h(I,j,k) = h(i,j,k)
+ endif
+ enddo ; enddo
+ else
+ J=segment%HI%JsdB
+ do k=1,nz ; do i=segment%HI%isd,segment%HI%ied
+ if (segment%direction == OBC_DIRECTION_S) then
+ segment%h_Reg%h(i,J,k) = h(i,j+1,k)
+ else
+ segment%h_Reg%h(i,J,k) = h(i,j,k)
+ endif
+ enddo ; enddo
+ endif
+ if (.not.segment%h_Reg%is_initialized) then
+ segment%h_Reg%h_res(:,:,:) = segment%h_Reg%h(:,:,:)
+ segment%h_Reg%is_initialized = .true.
+ endif
+ enddo
+
+end subroutine fill_thickness_segments
+
!> Find the region outside of all open boundary segments and
!! make sure it is set to land mask. Gonna need to know global land
!! mask as well to get it right...
@@ -5066,7 +5573,6 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC)
! Local variables
integer :: i, j
- integer :: l_seg
logical :: fatal_error = .False.
real :: min_depth ! The minimum depth for ocean points [Z ~> m]
real :: mask_depth ! The masking depth for ocean points [Z ~> m]
@@ -5115,50 +5621,38 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC)
enddo
do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1
- l_seg = OBC%segnum_u(I,j)
- if (l_seg == OBC_NONE) cycle
-
- if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then
+ if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W
if (color(i,j) == 0.0) color(i,j) = cout
if (color(i+1,j) == 0.0) color(i+1,j) = cin
- elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then
+ elseif (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E
if (color(i,j) == 0.0) color(i,j) = cin
if (color(i+1,j) == 0.0) color(i+1,j) = cout
endif
enddo ; enddo
do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied
- l_seg = OBC%segnum_v(i,J)
- if (l_seg == OBC_NONE) cycle
-
- if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then
+ if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S
if (color(i,j) == 0.0) color(i,j) = cout
if (color(i,j+1) == 0.0) color(i,j+1) = cin
- elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then
+ elseif (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N
if (color(i,j) == 0.0) color(i,j) = cin
if (color(i,j+1) == 0.0) color(i,j+1) = cout
endif
enddo ; enddo
do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied
- l_seg = OBC%segnum_v(i,J)
- if (l_seg == OBC_NONE) cycle
-
- if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then
+ if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S
if (color2(i,j) == 0.0) color2(i,j) = cout
if (color2(i,j+1) == 0.0) color2(i,j+1) = cin
- elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then
+ elseif (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N
if (color2(i,j) == 0.0) color2(i,j) = cin
if (color2(i,j+1) == 0.0) color2(i,j+1) = cout
endif
enddo ; enddo
do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1
- l_seg = OBC%segnum_u(I,j)
- if (l_seg == OBC_NONE) cycle
-
- if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then
+ if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W
if (color2(i,j) == 0.0) color2(i,j) = cout
if (color2(i+1,j) == 0.0) color2(i+1,j) = cin
- elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then
+ elseif (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E
if (color2(i,j) == 0.0) color2(i,j) = cin
if (color2(i+1,j) == 0.0) color2(i+1,j) = cout
endif
@@ -5172,7 +5666,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC)
do j=G%jsd,G%jed ; do i=G%isd,G%ied
if (color(i,j) /= color2(i,j)) then
fatal_error = .True.
- write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I5,",",I5," during\n", &
+ write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I0,",",I0," during\n", &
&"the masking of the outside grid points.")') i, j
call MOM_error(WARNING,"MOM mask_outside_OBCs: "//mesg, all_print=.true.)
endif
@@ -5335,14 +5829,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
@@ -5370,6 +5864,31 @@ subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, res
restart_CS, conversion=US%L_T_to_m_s**2)
endif
+ if (OBC%thickness_x_reservoirs_used) then
+ allocate(OBC%h_res_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0)
+ if (modulo(HI%turns, 2) /= 0) then
+ write(var_name,'("h_res_y")')
+ call register_restart_field(OBC%h_res_x(:,:,:), var_name, .false., restart_CS, &
+ longname="Layer thickness for NS OBCs", units="Conc", hor_grid='v')
+ else
+ write(var_name,'("h_res_x")')
+ call register_restart_field(OBC%h_res_x(:,:,:), var_name, .false., restart_CS, &
+ longname="Layer thickness for EW OBCs", units="Conc", hor_grid='u')
+ endif
+ endif
+ if (OBC%thickness_y_reservoirs_used) then
+ allocate(OBC%h_res_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0)
+ if (modulo(HI%turns, 2) /= 0) then
+ write(var_name,'("h_res_x")')
+ call register_restart_field(OBC%h_res_y(:,:,:), var_name, .false., restart_CS, &
+ longname="Layer thickness for EW OBCs", units="Conc", hor_grid='u')
+ else
+ write(var_name,'("h_res_y")')
+ call register_restart_field(OBC%h_res_y(:,:,:), var_name, .false., restart_CS, &
+ longname="Layer thickness for NS OBCs", units="Conc", hor_grid='v')
+ endif
+ endif
+
if (Reg%ntr == 0) return
if (.not. allocated(OBC%tracer_x_reservoirs_used)) then
OBC%ntr = Reg%ntr
@@ -5380,7 +5899,7 @@ subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, res
! This would be coming from user code such as DOME.
if (OBC%ntr /= Reg%ntr) then
! call MOM_error(FATAL, "open_boundary_register_restarts: Inconsistent value for ntr")
- write(mesg,'("Inconsistent values for ntr ", I8," and ",I8,".")') OBC%ntr, Reg%ntr
+ write(mesg,'("Inconsistent values for ntr ", I0," and ",I0,".")') OBC%ntr, Reg%ntr
call MOM_error(WARNING, 'open_boundary_register_restarts: '//mesg)
endif
endif
@@ -5422,7 +5941,7 @@ subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, res
end subroutine open_boundary_register_restarts
!> Update the OBC tracer reservoirs after the tracers have been updated.
-subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg)
+subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, Reg)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through
@@ -5432,11 +5951,10 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg)
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection
!! [H ~> m or kg m-2]
type(ocean_OBC_type), pointer :: OBC !< Open boundary structure
- real, intent(in) :: dt !< time increment [T ~> s]
type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry
! Local variable
- type(OBC_segment_type), pointer :: segment=>NULL()
+ type(OBC_segment_type), pointer :: segment => NULL()
real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell, normalized by the reservoir
! length scale [nondim]
real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell, normalized by the reservoir
@@ -5460,10 +5978,10 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg)
ntr = Reg%ntr
if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
+ segment => OBC%segment(n)
if (.not. associated(segment%tr_Reg)) cycle
- b_in = 0.0; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0
- b_out = 0.0; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0
+ b_in = 0.0 ; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0
+ b_out = 0.0 ; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0
if (segment%is_E_or_W) then
I = segment%HI%IsdB
do j=segment%HI%jsd,segment%HI%jed
@@ -5553,6 +6071,129 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg)
end subroutine update_segment_tracer_reservoirs
+!> Update the OBC thickness reservoirs after the thicknesses have been updated.
+subroutine update_segment_thickness_reservoirs(G, GV, uhr, vhr, h, OBC)
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
+ type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through
+ !! the zonal face [H L2 ~> m3 or kg]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhr !< accumulated volume/mass flux through
+ !! the meridional face [H L2 ~> m3 or kg]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection
+ !! [H ~> m or kg m-2]
+ type(ocean_OBC_type), pointer :: OBC !< Open boundary structure
+
+ ! Local variable
+ type(OBC_segment_type), pointer :: segment=>NULL()
+ real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell, normalized by the reservoir
+ ! length scale [nondim]
+ real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell, normalized by the reservoir
+ ! length scale [nondim]
+ real :: fac1 ! The denominator of the expression for tracer updates [nondim]
+ real :: I_scale ! The inverse of the scaling factor for the tracers.
+ ! For salinity the units would be [ppt S-1 ~> 1]
+ integer :: i, j, k, n, nz, fd_id
+ integer :: ishift, idir, jshift, jdir
+ real :: resrv_lfac_out ! The reservoir inverse length scale scaling factor for the outward
+ ! direction per field [nondim]
+ real :: resrv_lfac_in ! The reservoir inverse length scale scaling factor for the inward
+ ! direction per field [nondim]
+ real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs
+ ! 1 if the length scale of reservoir is zero [nondim]
+ real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights
+ ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward
+ ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward
+ ! It's clear that a_in and a_out cannot be both non-zero [nondim]
+ nz = GV%ke
+
+ if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments
+ segment=>OBC%segment(n)
+ if (.not. associated(segment%h_Reg)) cycle
+ b_in = 0.0 ; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0
+ b_out = 0.0 ; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0
+ if (segment%is_E_or_W) then
+ I = segment%HI%IsdB
+ do j=segment%HI%jsd,segment%HI%jed
+ ! ishift+I corresponds to the nearest interior tracer cell index
+ ! idir switches the sign of the flow so that positive is into the reservoir
+ if (segment%direction == OBC_DIRECTION_W) then
+ ishift = 1 ; idir = -1
+ else
+ ishift = 0 ; idir = 1
+ endif
+ ! Can keep this or take it out, either way
+ if (G%mask2dT(I+ishift,j) == 0.0) cycle
+ ! Update the reservoir thickness concentration implicitly using a Backward-Euler timestep
+ fd_id = segment%h_Reg%fd_index
+ if (fd_id == -1) then
+ resrv_lfac_out = 1.0
+ resrv_lfac_in = 1.0
+ else
+ resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out
+ resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in
+ endif
+ I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale
+ if (allocated(segment%h_Reg%h_res)) then ; do k=1,nz
+ ! Calculate weights. Both a and u_L are nondim. Adding them together has no meaning.
+ ! However, since they cannot be both non-zero, adding them works like a switch.
+ ! When InvLscale_out is 0 and outflow, only interior data is applied to reservoirs
+ ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs
+ a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k)))
+ a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k)))
+ u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Th_InvLscale_out*resrv_lfac_out / &
+ ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j)))
+ u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Th_InvLscale_in*resrv_lfac_in / &
+ ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j)))
+ fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in))
+ segment%h_Reg%h_res(I,j,k) = (1.0/fac1) * &
+ ((1.0-a_out+a_in)*segment%h_Reg%h_res(I,j,k)+ &
+ ((u_L_out+a_out)*h(i+ishift,j,k) - &
+ (u_L_in+a_in)*segment%h_Reg%h(I,j,k)))
+ if (allocated(OBC%h_res_x)) OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(I,j,k)
+ enddo ; endif
+ enddo
+ elseif (segment%is_N_or_S) then
+ J = segment%HI%JsdB
+ do i=segment%HI%isd,segment%HI%ied
+ ! jshift+J corresponds to the nearest interior tracer cell index
+ ! jdir switches the sign of the flow so that positive is into the reservoir
+ if (segment%direction == OBC_DIRECTION_S) then
+ jshift = 1 ; jdir = -1
+ else
+ jshift = 0 ; jdir = 1
+ endif
+ ! Can keep this or take it out, either way
+ if (G%mask2dT(i,j+jshift) == 0.0) cycle
+ ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep
+ fd_id = segment%h_Reg%fd_index
+ if (fd_id == -1) then
+ resrv_lfac_out = 1.0
+ resrv_lfac_in = 1.0
+ else
+ resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out
+ resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in
+ endif
+ I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale
+ if (allocated(segment%h_Reg%h_res)) then ; do k=1,nz
+ a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k)))
+ a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k)))
+ v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Th_InvLscale_out*resrv_lfac_out / &
+ ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J)))
+ v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Th_InvLscale_in*resrv_lfac_in / &
+ ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J)))
+ fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in))
+ segment%h_Reg%h_res(i,J,k) = (1.0/fac1) * &
+ ((1.0-a_out+a_in)*segment%h_Reg%h_res(i,J,k) + &
+ ((v_L_out+a_out)*h(i,j+jshift,k) - &
+ (v_L_in+a_in)*segment%h_Reg%h(i,J,k)))
+ if (allocated(OBC%h_res_y)) OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k)
+ enddo ; endif
+ enddo
+ endif
+ enddo ; endif ; endif
+
+end subroutine update_segment_thickness_reservoirs
+
!> Vertically remap the OBC tracer reservoirs and radiation rates that are filtered in time.
subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
@@ -5626,6 +6267,28 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell)
endif ; enddo
+ ! Vertically remap the reservoir thicknesses?
+ if (associated(segment%h_Reg)) then
+ if (allocated(segment%h_Reg%h_res)) then
+ I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale
+
+ if (present(PCM_cell)) then
+ call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(I,j,:), nz, h2, tr_column, &
+ PCM_cell=PCM)
+ else
+ call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(I,j,:), nz, h2, tr_column)
+ endif
+
+ ! Possibly underflow any very tiny tracer concentrations to 0?
+
+ ! Update tracer concentrations
+ segment%h_Reg%h_res(I,j,:) = tr_column(:)
+ if (allocated(OBC%h_res_x)) then ; do k=1,nz
+ OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(I,j,k)
+ enddo ; endif
+ endif
+ endif
+
if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then
call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%rx_norm_rad(I,j,:), nz, h2, r_norm_col, &
PCM_cell=PCM)
@@ -5693,6 +6356,28 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell)
endif ; enddo
+ ! Vertically remap the reservoir thicknesses?
+ if (associated(segment%h_Reg)) then
+ if (allocated(segment%h_Reg%h_res)) then
+ I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale
+
+ if (present(PCM_cell)) then
+ call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,J,:), nz, h2, tr_column, &
+ PCM_cell=PCM)
+ else
+ call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,J,:), nz, h2, tr_column)
+ endif
+
+ ! Possibly underflow any very tiny tracer concentrations to 0?
+
+ ! Update tracer concentrations
+ segment%h_Reg%h_res(i,J,:) = tr_column(:)
+ if (allocated(OBC%h_res_y)) then ; do k=1,nz
+ OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k)
+ enddo ; endif
+ endif
+ endif
+
if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then
call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%ry_norm_rad(i,J,:), nz, h2, r_norm_col, &
PCM_cell=PCM)
@@ -5741,15 +6426,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 +6446,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 +6504,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 +6523,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,34 +6539,34 @@ 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 ",'// &
- ! '"to fit topography in ",I8," places.")') contractions
+ ! '"to fit topography in ",I0," places.")') contractions
! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg)
! endif
! call sum_across_PEs(dilations)
! if ((dilations > 0) .and. (is_root_pe())) then
! write(mesg,'("Thickness OBCs were dilated ",'// &
- ! '"to fit topography in ",I8," places.")') dilations
+ ! '"to fit topography in ",I0," places.")') dilations
! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg)
! endif
- deallocate(eta)
+
+ deallocate(eta, dz_tot)
end subroutine adjustSegmentEtaToFitBathymetry
!> This is more of a rotate initialization than an actual rotate
subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns)
- type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< Input OBC
- type(dyn_horgrid_type), intent(in) :: G_in !< Input grid metric
+ type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< Input OBC
+ type(dyn_horgrid_type), intent(in) :: G_in !< Input grid
type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC
- type(dyn_horgrid_type), intent(in) :: G !< Rotated grid metric
- integer, intent(in) :: turns !< Number of quarter turns
+ type(dyn_horgrid_type), intent(in) :: G !< Rotated grid
+ integer, intent(in) :: turns !< Number of quarter turns
- integer :: l
+ integer :: c, n, l_seg
- if (OBC_in%number_of_segments==0) return
+ if (OBC_in%number_of_segments == 0) return
! Scalar and logical transfer
OBC%number_of_segments = OBC_in%number_of_segments
@@ -5851,71 +6574,119 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns)
OBC%user_BCs_set_globally = OBC_in%user_BCs_set_globally
! These are conditionally read and set if number_of_segments > 0
- OBC%zero_vorticity = OBC_in%zero_vorticity
- OBC%freeslip_vorticity = OBC_in%freeslip_vorticity
- OBC%computed_vorticity = OBC_in%computed_vorticity
- OBC%specified_vorticity = OBC_in%specified_vorticity
- OBC%zero_strain = OBC_in%zero_strain
- OBC%freeslip_strain = OBC_in%freeslip_strain
- OBC%computed_strain = OBC_in%computed_strain
- OBC%specified_strain = OBC_in%specified_strain
+ OBC%vorticity_config = OBC_in%vorticity_config
+ OBC%strain_config = OBC_in%strain_config
OBC%zero_biharmonic = OBC_in%zero_biharmonic
OBC%silly_h = OBC_in%silly_h
OBC%silly_u = OBC_in%silly_u
+ OBC%reverse_segment_order = OBC_in%reverse_segment_order
! Segment rotation
allocate(OBC%segment(0:OBC%number_of_segments))
- do l = 1, OBC%number_of_segments
- call rotate_OBC_segment_config(OBC_in%segment(l), G_in, OBC%segment(l), G, turns)
- ! Data up to setup_[uv]_point_obc is needed for allocate_obc_segment_data!
- call allocate_OBC_segment_data(OBC, OBC%segment(l))
- call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), turns)
+ do l_seg=1,OBC%number_of_segments
+ call rotate_OBC_segment_config(OBC_in%segment(l_seg), G_in, OBC%segment(l_seg), G, turns)
+ ! Data stored in setup_[uv]_point_obc is needed for allocate_obc_segment_data
+ call allocate_OBC_segment_data(OBC, OBC%segment(l_seg))
enddo
! The horizontal segment map
- allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed))
- allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB))
- call rotate_array_pair(OBC_in%segnum_u, OBC_in%segnum_v, turns, &
- OBC%segnum_u, OBC%segnum_v)
+ allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0)
+ allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=0)
+ call rotate_array_pair(OBC_in%segnum_u, OBC_in%segnum_v, turns, OBC%segnum_u, OBC%segnum_v)
+ call set_segnum_signs(OBC, G)
! These are conditionally enabled during segment configuration
- OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally
- OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally
- OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally
- OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally
+ if (modulo(turns,2) == 0) then
+ OBC%open_u_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally
+ OBC%open_v_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally
+ OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally
+ OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally
+ OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally
+ OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally
+ OBC%specified_u_BCs_exist_globally = OBC_in%specified_u_BCs_exist_globally
+ OBC%specified_v_BCs_exist_globally = OBC_in%specified_v_BCs_exist_globally
+ else ! Swap information for u- and v- OBCs
+ OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally
+ OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally
+ OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally
+ OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally
+ OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally
+ OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally
+ OBC%specified_u_BCs_exist_globally = OBC_in%specified_v_BCs_exist_globally
+ OBC%specified_v_BCs_exist_globally = OBC_in%specified_u_BCs_exist_globally
+ endif
OBC%oblique_BCs_exist_globally = OBC_in%oblique_BCs_exist_globally
- OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally
- OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally
- OBC%specified_u_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally
- OBC%specified_v_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally
OBC%radiation_BCs_exist_globally = OBC_in%radiation_BCs_exist_globally
! These are set by initialize_segment_data
OBC%brushcutter_mode = OBC_in%brushcutter_mode
OBC%update_OBC = OBC_in%update_OBC
- OBC%needs_IO_for_data = OBC_in%needs_IO_for_data
OBC%any_needs_IO_for_data = OBC_in%any_needs_IO_for_data
- OBC%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
- ! remap_z_CS and remap_h_CS are set up by initialize_segment_data, so we copy the fields here.
- if (ASSOCIATED(OBC_in%remap_z_CS)) then
- allocate(OBC%remap_z_CS)
- OBC%remap_z_CS = OBC_in%remap_z_CS
- endif
- if (ASSOCIATED(OBC_in%remap_h_CS)) then
- allocate(OBC%remap_h_CS)
- OBC%remap_h_CS = OBC_in%remap_h_CS
+ ! These are run-time parameters that are read in via open_boundary_config
+ OBC%debug = OBC_in%debug
+ OBC%ramp = OBC_in%ramp
+ OBC%ramping_is_activated = OBC_in%ramping_is_activated
+ OBC%ramp_timescale = OBC_in%ramp_timescale
+ OBC%trunc_ramp_time = OBC_in%trunc_ramp_time
+ OBC%ramp_value = OBC_in%ramp_value
+ OBC%ramp_start_time = OBC_in%ramp_start_time
+ OBC%remap_answer_date = OBC_in%remap_answer_date
+ OBC%check_reconstruction = OBC_in%check_reconstruction
+ OBC%check_remapping = OBC_in%check_remapping
+ OBC%force_bounds_in_subcell = OBC_in%force_bounds_in_subcell
+ OBC%om4_remap_via_sub_cells = OBC_in%om4_remap_via_sub_cells
+ OBC%remappingScheme = OBC_in%remappingScheme
+ OBC%exterior_OBC_bug = OBC_in%exterior_OBC_bug
+ OBC%hor_index_bug = OBC_in%hor_index_bug
+ OBC%n_tide_constituents = OBC_in%n_tide_constituents
+ OBC%add_tide_constituents = OBC_in%add_tide_constituents
+
+ ! These are read in via initialize_obc_tides when n_tide_constituents > 0
+ if (OBC%add_tide_constituents .and. (OBC%n_tide_constituents>0)) then
+ OBC%add_eq_phase = OBC_in%add_eq_phase
+ OBC%add_nodal_terms = OBC_in%add_nodal_terms
+ OBC%time_ref = OBC_in%time_ref
+
+ allocate(OBC%tide_names(OBC%n_tide_constituents))
+ allocate(OBC%tide_frequencies(OBC%n_tide_constituents))
+ allocate(OBC%tide_eq_phases(OBC%n_tide_constituents))
+ allocate(OBC%tide_fn(OBC%n_tide_constituents))
+ allocate(OBC%tide_un(OBC%n_tide_constituents))
+ do c=1,OBC%n_tide_constituents
+ OBC%tide_names(c) = OBC_in%tide_names(c)
+ OBC%tide_frequencies(c) = OBC_in%tide_frequencies(c)
+ OBC%tide_eq_phases(c) = OBC_in%tide_eq_phases(c)
+ OBC%tide_fn(c) = OBC_in%tide_fn(c)
+ OBC%tide_un(c) = OBC_in%tide_un(c)
+ enddo
+
+ if (OBC%add_eq_phase .or. OBC%add_nodal_terms) &
+ OBC%tidal_longitudes = OBC_in%tidal_longitudes
endif
- ! TODO: The OBC registry seems to be a list of "registered" OBC types.
- ! It does not appear to be used, so for now we skip this record.
- !OBC%OBC_Reg => OBC_in%OBC_Reg
end subroutine rotate_OBC_config
!> Rotate the OBC segment configuration data from the input to model index map.
@@ -5927,8 +6698,9 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns)
integer, intent(in) :: turns !< Number of quarter turns
! Global segment indices
- integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain
- integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain
+ integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain global indices
+ integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain global indices
+ integer :: qturns ! The number of quarter turns in the range of 0 to 3
! NOTE: A "rotation" of the OBC segment string would allow us to use
! setup_[uv]_point_obc to set up most of this. For now, we just copy/swap
@@ -5937,6 +6709,8 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns)
! This is set if the segment is in the local grid
segment%on_pe = segment_in%on_pe
+ qturns = modulo(turns, 4)
+
! Transfer configuration flags
segment%Flather = segment_in%Flather
segment%radiation = segment_in%radiation
@@ -5954,19 +6728,9 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns)
segment%open = segment_in%open
segment%gradient = segment_in%gradient
- ! NOTE: [uv]_values_needed are swapped
- segment%u_values_needed = segment_in%v_values_needed
- segment%v_values_needed = segment_in%u_values_needed
- segment%z_values_needed = segment_in%z_values_needed
- segment%g_values_needed = segment_in%g_values_needed
- segment%t_values_needed = segment_in%t_values_needed
- segment%s_values_needed = segment_in%s_values_needed
-
- segment%values_needed = segment_in%values_needed
-
! These are conditionally set if nudged
segment%Velocity_nudging_timescale_in = segment_in%Velocity_nudging_timescale_in
- segment%Velocity_nudging_timescale_out= segment_in%Velocity_nudging_timescale_out
+ segment%Velocity_nudging_timescale_out = segment_in%Velocity_nudging_timescale_out
! Rotate segment indices
@@ -5974,7 +6738,7 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns)
! NOTE: The values stored in the segment are always saved in ascending order,
! e.g. (is < ie). In order to use setup_segment_indices, we reorder the
! indices here to indicate face direction.
- ! Segment indices are also indexed locally, so we remove the halo offset.
+ ! Segment indices are also indexed locally, so here we convert to global indices
if (segment_in%direction == OBC_DIRECTION_N) then
Is_obc_in = segment_in%Ie_obc + G_in%idg_offset
Ie_obc_in = segment_in%Is_obc + G_in%idg_offset
@@ -5991,18 +6755,26 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns)
Je_obc_in = segment_in%Je_obc + G_in%jdg_offset
endif
- ! TODO: This is hardcoded for 90 degrees, and needs to be generalized.
- Is_obc = G_in%jegB - Js_obc_in
- Ie_obc = G_in%JegB - Je_obc_in
- Js_obc = Is_obc_in
- Je_obc = Ie_obc_in
-
- ! Orientation is based on the index ordering, [IJ][se]_obc are re-ordered
- ! after the index is set. So we now need to restore the original order
+ ! Rotate the global indices of the segment according to the number of turns.
+ if (qturns == 0) then
+ Is_obc = Is_obc_in ; Ie_obc = Ie_obc_in
+ Js_obc = Js_obc_in ; Je_obc = Je_obc_in
+ elseif (qturns == 1) then
+ Is_obc = G_in%JegB - Js_obc_in ; Ie_obc = G_in%JegB - Je_obc_in
+ Js_obc = Is_obc_in ; Je_obc = Ie_obc_in
+ elseif (qturns == 2) then
+ Is_obc = G_in%IegB - Is_obc_in ; Ie_obc = G_in%IegB - Ie_obc_in
+ Js_obc = G_in%JegB - Js_obc_in ; Je_obc = G_in%JegB - Je_obc_in
+ elseif (qturns == 3) then
+ Is_obc = Js_obc_in ; Ie_obc = Je_obc_in
+ Js_obc = G_in%IegB - Is_obc_in ; Je_obc = G_in%IegB - Ie_obc_in
+ endif
+ ! Orientation is based on the index ordering, and setup_segment_indices
+ ! is based on the original order in the intput files.
call setup_segment_indices(G, segment, Is_obc, Ie_obc, Js_obc, Je_obc)
- ! Re-order [IJ][se]_obc back to ascending, and remove the halo offset.
+ ! Re-order [IJ][se]_obc back to ascending, and remove the global indexing offset.
if (Is_obc > Ie_obc) then
segment%Is_obc = Ie_obc - G%idg_offset
segment%Ie_obc = Is_obc - G%idg_offset
@@ -6020,134 +6792,474 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns)
endif
! Reconfigure the directional flags
- ! TODO: This is hardcoded for 90 degrees, and needs to be generalized.
- select case (segment_in%direction)
- case (OBC_DIRECTION_N)
- segment%direction = OBC_DIRECTION_W
- segment%is_E_or_W_2 = segment_in%is_N_or_S
- segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe
- segment%is_N_or_S = .false.
- case (OBC_DIRECTION_W)
- segment%direction = OBC_DIRECTION_S
- segment%is_N_or_S = segment_in%is_E_or_W
- segment%is_E_or_W = .false.
- segment%is_E_or_W_2 = .false.
- case (OBC_DIRECTION_S)
- segment%direction = OBC_DIRECTION_E
- segment%is_E_or_W_2 = segment_in%is_N_or_S
- segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe
- segment%is_N_or_S = .false.
- case (OBC_DIRECTION_E)
- segment%direction = OBC_DIRECTION_N
- segment%is_N_or_S = segment_in%is_E_or_W
- segment%is_E_or_W = .false.
- segment%is_E_or_W_2 = .false.
- case (OBC_NONE)
- segment%direction = OBC_NONE
- end select
+ segment%direction = rotate_OBC_segment_direction(segment_in%direction, turns)
+
+ segment%is_E_or_W_2 = ((segment%direction == OBC_DIRECTION_E) .or. &
+ (segment%direction == OBC_DIRECTION_W))
+ segment%is_E_or_W = segment_in%on_PE .and. segment%is_E_or_W_2
+ segment%is_N_or_S = segment_in%on_PE .and. &
+ ((segment%direction == OBC_DIRECTION_N) .or. &
+ (segment%direction == OBC_DIRECTION_S))
! These are conditionally set if Lscale_{in,out} are present
segment%Tr_InvLscale_in = segment_in%Tr_InvLscale_in
segment%Tr_InvLscale_out = segment_in%Tr_InvLscale_out
+ segment%Th_InvLscale_in = segment_in%Th_InvLscale_in
+ segment%Th_InvLscale_out = segment_in%Th_InvLscale_out
+
+ ! This needs to be set
+ segment%num_fields = segment_in%num_fields
end subroutine rotate_OBC_segment_config
-!> Initialize the segments and field-related data of a rotated OBC.
-subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CS, OBC)
- type(ocean_OBC_type), intent(in) :: OBC_in !< OBC on input map
- type(ocean_grid_type), intent(in) :: G !< Rotated grid metric
- type(verticalGrid_type), intent(in) :: GV !< Vertical grid
- type(unit_scale_type), intent(in) :: US !< Unit scaling
- type(param_file_type), intent(in) :: param_file !< Input parameters
- type(thermo_var_ptrs), intent(inout) :: tv !< Tracer fields
- type(MOM_restart_CS), intent(in) :: restart_CS !< Restart CS
- type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC
+!> Return the direction of an OBC segment on after rotation to the new grid. Note that
+!! rotate_OBC_seg_direction(rotate_OBC_seg_direction(direction, turns), -turns) = direction.
+function rotate_OBC_segment_direction(direction, turns) result(rotated_dir)
+ integer, intent(in) :: direction !< The orientation of an OBC segment on the original grid
+ integer, intent(in) :: turns !< Number of quarter turns
+ integer :: rotated_dir !< An integer encoding the new rotated segment direction
+
+ integer :: qturns ! The number of quarter turns in the range of 0 to 3
+
+ qturns = modulo(turns, 4)
+
+ if ((qturns == 0) .or. (direction == OBC_NONE)) then
+ rotated_dir = direction
+ else ! Determine the segment direction on a rotated grid
+ select case (direction)
+ case (OBC_DIRECTION_N)
+ if (qturns == 0) rotated_dir = OBC_DIRECTION_N
+ if (qturns == 1) rotated_dir = OBC_DIRECTION_W
+ if (qturns == 2) rotated_dir = OBC_DIRECTION_S
+ if (qturns == 3) rotated_dir = OBC_DIRECTION_E
+ case (OBC_DIRECTION_W)
+ if (qturns == 0) rotated_dir = OBC_DIRECTION_W
+ if (qturns == 1) rotated_dir = OBC_DIRECTION_S
+ if (qturns == 2) rotated_dir = OBC_DIRECTION_E
+ if (qturns == 3) rotated_dir = OBC_DIRECTION_N
+ case (OBC_DIRECTION_S)
+ if (qturns == 0) rotated_dir = OBC_DIRECTION_S
+ if (qturns == 1) rotated_dir = OBC_DIRECTION_E
+ if (qturns == 2) rotated_dir = OBC_DIRECTION_N
+ if (qturns == 3) rotated_dir = OBC_DIRECTION_W
+ case (OBC_DIRECTION_E)
+ if (qturns == 0) rotated_dir = OBC_DIRECTION_E
+ if (qturns == 1) rotated_dir = OBC_DIRECTION_N
+ if (qturns == 2) rotated_dir = OBC_DIRECTION_W
+ if (qturns == 3) rotated_dir = OBC_DIRECTION_S
+ case (OBC_NONE)
+ rotated_dir = OBC_NONE
+ case default ! This should never happen.
+ rotated_dir = direction
+ end select
+ endif
- logical :: use_temperature
- integer :: l
+end function rotate_OBC_segment_direction
+
+!> Return the that the field would have after being rotated by the given number of quarter turns
+function rotated_field_name(input_name, turns)
+ character(len=*), intent(in) :: input_name !< The unrotated field name
+ integer, intent(in) :: turns !< Number of quarter turns of the grid
+ character(len=len(input_name)) :: rotated_field_name !< The rotated field name
+
+ if (modulo(turns, 2) /= 0) then
+ select case (input_name)
+ case ('U') ; rotated_field_name = 'V'
+ case ('Uamp') ; rotated_field_name = 'Vamp'
+ case ('Uphase') ; rotated_field_name = 'Vphase'
+ case ('V') ; rotated_field_name = 'U'
+ case ('Vamp') ; rotated_field_name = 'Uamp'
+ case ('Vphase') ; rotated_field_name = 'Uphase'
+ case ('DVDX') ; rotated_field_name = 'DUDY'
+ case ('DUDY') ; rotated_field_name = 'DVDX'
+ case default ; rotated_field_name = input_name
+ end select
+ else
+ rotated_field_name = input_name
+ endif
- call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, &
- "If true, Temperature and salinity are used as state "//&
- "variables.", default=.true., do_not_log=.true.)
+end function rotated_field_name
- do l = 1, OBC%number_of_segments
- call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), G%HI%turns)
- enddo
+!> Allocate an array of data for a field on a segment based on the size of a potentially rotated source array
+subroutine allocate_rotated_seg_data(src_array, HI_in, tgt_array, segment)
+ real, dimension(:,:,:), intent(in) :: src_array !< The segment data on the unrotated source grid
+ type(hor_index_type), intent(in) :: HI_in !< Horizontal indices on the source grid
+ real, dimension(:,:,:), allocatable, intent(inout) :: tgt_array !< The segment data that is being allocated
+ type(OBC_segment_type), intent(inout) :: segment !< OBC segment on the target grid
- if (use_temperature) &
- call fill_temp_salt_segments(G, GV, US, OBC, tv)
+ ! Local variables
+ integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nk
+ logical :: corner ! True if this field is discretized at the OBC segment nodes rather than the faces.
- call open_boundary_init(G, GV, US, param_file, OBC, restart_CS)
-end subroutine rotate_OBC_init
+ isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
+ jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB
+ nk = size(src_array, 3)
+ ! Determine whether the source array is allocated at a segment face or at the corners.
+ corner = (size(src_array, 1) == abs(HI_in%IedB - HI_in%IsdB) + 1 ) .and. &
+ (size(src_array, 2) == abs(HI_in%JedB - HI_in%JsdB) + 1 )
-!> Rotate an OBC segment's fields from the input to the model index map.
-subroutine rotate_OBC_segment_data(segment_in, segment, turns)
- type(OBC_segment_type), intent(in) :: segment_in
- type(OBC_segment_type), intent(inout) :: segment
- integer, intent(in) :: turns
+ if (corner) then
+ allocate(tgt_array(IsdB:IedB,JsdB:JedB,nk), source=0.0)
+ elseif (segment%is_E_or_W) then
+ allocate(tgt_array(IsdB:IedB,jsd:jed,nk), source=0.0)
+ elseif (segment%is_N_or_S) then
+ allocate(tgt_array(isd:ied,JsdB:JedB,nk), source=0.0)
+ endif
+end subroutine allocate_rotated_seg_data
- integer :: n
- integer :: num_fields
+!> Write out information about the contents of the OBC control structure
+subroutine write_OBC_info(OBC, G, GV, US)
+ type(ocean_OBC_type), pointer :: OBC !< An open boundary condition control structure
+ type(ocean_grid_type), intent(in) :: G !< Rotated grid metric
+ type(verticalGrid_type), intent(in) :: GV !< Vertical grid
+ type(unit_scale_type), intent(in) :: US !< Unit scaling
- num_fields = segment_in%num_fields
- allocate(segment%field(num_fields))
+ ! Local variables
+ type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list
+ integer :: turns ! Number of index quarter turns
+ integer :: n ! The segment number reported in output
+ integer :: n_seg ! The internal segment number
+ integer :: dir ! This indicates the internal logical orientation of a segment
+ integer :: unrot_dir ! This indicates the logical orientation a segment would have had
+ ! without grid rotation
+ integer :: c ! Used to loop over tidal constituents
+ character(len=1024) :: mesg
+
+ turns = modulo(G%HI%turns, 4)
+
+ write(mesg, '("OBC has ", I0, " segments.")') OBC%number_of_segments
+ call MOM_mesg(mesg, verb=1)
+ ! call MOM_error(WARNING, mesg)
+
+ if (modulo(turns, 2) == 0) then
+ if (OBC%open_u_BCs_exist_globally) call MOM_mesg("open_u_BCs_exist_globally", verb=1)
+ if (OBC%open_v_BCs_exist_globally) call MOM_mesg("open_v_BCs_exist_globally", verb=1)
+ if (OBC%Flather_u_BCs_exist_globally) call MOM_mesg("Flather_u_BCs_exist_globally", verb=1)
+ if (OBC%Flather_v_BCs_exist_globally) call MOM_mesg("Flather_v_BCs_exist_globally", verb=1)
+ if (OBC%nudged_u_BCs_exist_globally) call MOM_mesg("nudged_u_BCs_exist_globally", verb=1)
+ if (OBC%nudged_v_BCs_exist_globally) call MOM_mesg("nudged_v_BCs_exist_globally", verb=1)
+ if (OBC%specified_u_BCs_exist_globally) call MOM_mesg("specified_u_BCs_exist_globally", verb=1)
+ if (OBC%specified_v_BCs_exist_globally) call MOM_mesg("specified_v_BCs_exist_globally", verb=1)
+ else ! The u- and v-directions are swapped.
+ if (OBC%open_v_BCs_exist_globally) call MOM_mesg("open_u_BCs_exist_globally", verb=1)
+ if (OBC%open_u_BCs_exist_globally) call MOM_mesg("open_v_BCs_exist_globally", verb=1)
+ if (OBC%Flather_v_BCs_exist_globally) call MOM_mesg("Flather_u_BCs_exist_globally", verb=1)
+ if (OBC%Flather_u_BCs_exist_globally) call MOM_mesg("Flather_v_BCs_exist_globally", verb=1)
+ if (OBC%nudged_v_BCs_exist_globally) call MOM_mesg("nudged_u_BCs_exist_globally", verb=1)
+ if (OBC%nudged_u_BCs_exist_globally) call MOM_mesg("nudged_v_BCs_exist_globally", verb=1)
+ if (OBC%specified_v_BCs_exist_globally) call MOM_mesg("specified_u_BCs_exist_globally", verb=1)
+ if (OBC%specified_u_BCs_exist_globally) call MOM_mesg("specified_v_BCs_exist_globally", verb=1)
+ endif
- segment%num_fields = segment_in%num_fields
- do n = 1, num_fields
- segment%field(n)%handle = segment_in%field(n)%handle
- segment%field(n)%dz_handle = segment_in%field(n)%dz_handle
-
- if (modulo(turns, 2) /= 0) then
- select case (segment_in%field(n)%name)
- case ('U')
- segment%field(n)%name = 'V'
- case ('Uamp')
- segment%field(n)%name = 'Vamp'
- case ('Uphase')
- segment%field(n)%name = 'Vphase'
- case ('V')
- segment%field(n)%name = 'U'
- case ('Vamp')
- segment%field(n)%name = 'Uamp'
- case ('Vphase')
- segment%field(n)%name = 'Uphase'
- case ('DVDX')
- segment%field(n)%name = 'DUDY'
- case ('DUDY')
- segment%field(n)%name = 'DVDX'
- case default
- segment%field(n)%name = segment_in%field(n)%name
- end select
+ if (OBC%oblique_BCs_exist_globally) call MOM_mesg("oblique_BCs_exist_globally", verb=1)
+ if (OBC%radiation_BCs_exist_globally) call MOM_mesg("radiation_BCs_exist_globally", verb=1)
+ if (OBC%user_BCs_set_globally) call MOM_mesg("user_BCs_set_globally", verb=1)
+ if (OBC%update_OBC) call MOM_mesg("update_OBC", verb=1)
+ if (OBC%update_OBC_seg_data) call MOM_mesg("update_OBC_seg_data", verb=1)
+ if (OBC%any_needs_IO_for_data) call MOM_mesg("any_needs_IO_for_data", verb=1)
+ if (OBC%zero_biharmonic) call MOM_mesg("zero_biharmonic", verb=1)
+ if (OBC%brushcutter_mode) call MOM_mesg("brushcutter_mode", verb=1)
+ if (OBC%check_reconstruction) call MOM_mesg("check_reconstruction", verb=1)
+ if (OBC%check_remapping) call MOM_mesg("check_remapping", verb=1)
+ if (OBC%force_bounds_in_subcell) call MOM_mesg("force_bounds_in_subcell", verb=1)
+ if (OBC%om4_remap_via_sub_cells) call MOM_mesg("om4_remap_via_sub_cells", verb=1)
+ if (OBC%exterior_OBC_bug) call MOM_mesg("exterior_OBC_bug", verb=1)
+ if (OBC%hor_index_bug) call MOM_mesg("hor_index_bug", verb=1)
+ if (OBC%debug) call MOM_mesg("debug", verb=1)
+ if (OBC%ramp) call MOM_mesg("ramp", verb=1)
+ if (OBC%ramping_is_activated) call MOM_mesg("ramping_is_activated", verb=1)
+ write(mesg, '("n_tide_constituents ", I0)') OBC%n_tide_constituents
+ call MOM_mesg(mesg, verb=1)
+ if (OBC%n_tide_constituents > 0) then
+ do c=1,OBC%n_tide_constituents
+ write(mesg, '(" properties ", 4ES16.6)') &
+ US%s_to_T*OBC%tide_frequencies(c), OBC%tide_eq_phases(c), OBC%tide_fn(c), OBC%tide_un(c)
+ call MOM_mesg(trim(OBC%tide_names(c))//mesg, verb=1)
+ enddo
+ endif
+ if (OBC%ramp) then
+ write(mesg, '("ramp_values ", 3ES16.6)') OBC%ramp_timescale, OBC%trunc_ramp_time, OBC%ramp_value
+ call MOM_mesg(mesg, verb=1)
+ endif
+ write(mesg, '("gamma_uv ", ES16.6)') OBC%gamma_uv
+ call MOM_mesg(mesg, verb=1)
+ write(mesg, '("rx_max ", ES16.6)') OBC%rx_max
+ call MOM_mesg(mesg, verb=1)
+
+ call MOM_mesg("remappingScheme = "//trim(OBC%remappingScheme), verb=1)
+
+ do n=1,OBC%number_of_segments
+ n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n
+ segment => OBC%segment(n_seg)
+ dir = segment%direction
+
+ unrot_dir = rotate_OBC_segment_direction(dir, -turns)
+ write(mesg, '(" Segment ", I0, " has direction ", I0)') n, unrot_dir
+ if (unrot_dir == OBC_DIRECTION_N) write(mesg, '(" Segment ", I0, " is Northern")') n
+ if (unrot_dir == OBC_DIRECTION_S) write(mesg, '(" Segment ", I0, " is Southern")') n
+ if (unrot_dir == OBC_DIRECTION_E) write(mesg, '(" Segment ", I0, " is Eastern")') n
+ if (unrot_dir == OBC_DIRECTION_W) write(mesg, '(" Segment ", I0, " is Western")') n
+ call MOM_mesg(mesg, verb=1)
+
+ ! write(mesg, '(" range:", 4(1x,I0))') segment%Is_obc, segment%Ie_obc, segment%Js_obc, segment%Je_obc
+ if (modulo(turns, 2) == 0) then
+ write(mesg, '(" size: ", I0," ",I0)') 1+abs(segment%Ie_obc-segment%Is_obc), 1+abs(segment%Je_obc-segment%Js_obc)
else
- segment%field(n)%name = segment_in%field(n)%name
+ write(mesg, '(" size: ", I0," ",I0)') 1+abs(segment%Je_obc-segment%Js_obc), 1+abs(segment%Ie_obc-segment%Is_obc)
+ endif
+ call MOM_mesg(mesg, verb=1)
+
+ if (segment%on_pe) call MOM_mesg(" Segment is on PE.", verb=1)
+
+ if (segment%Flather) call MOM_mesg(" Flather", verb=1)
+ if (segment%radiation) call MOM_mesg(" radiation", verb=1)
+ if (segment%radiation_tan) call MOM_mesg(" radiation_tan", verb=1)
+ if (segment%radiation_grad) call MOM_mesg(" radiation_grad", verb=1)
+ if (segment%oblique) call MOM_mesg(" oblique", verb=1)
+ if (segment%oblique_tan) call MOM_mesg(" oblique_tan", verb=1)
+ if (segment%oblique_grad) call MOM_mesg(" oblique_grad", verb=1)
+ if (segment%nudged) call MOM_mesg(" nudged", verb=1)
+ if (segment%nudged_tan) call MOM_mesg(" nudged_tan", verb=1)
+ if (segment%nudged_grad) call MOM_mesg(" nudged_grad", verb=1)
+ if (segment%specified) call MOM_mesg(" specified", verb=1)
+ if (segment%specified_tan) call MOM_mesg(" specified_tan", verb=1)
+ if (segment%specified_grad) call MOM_mesg(" specified_grad", verb=1)
+ if (segment%open) call MOM_mesg(" open", verb=1)
+ if (segment%gradient) call MOM_mesg(" gradient", verb=1)
+ if (modulo(turns, 2) == 0) then
+ if (segment%is_N_or_S) call MOM_mesg(" is_N_or_S", verb=1)
+ if (segment%is_E_or_W) call MOM_mesg(" is_E_or_W", verb=1)
+ else ! The x- and y-directions are swapped.
+ if (segment%is_E_or_W) call MOM_mesg(" is_N_or_S", verb=1)
+ if (segment%is_N_or_S) call MOM_mesg(" is_E_or_W", verb=1)
+ endif
+! if (segment%is_E_or_W_2) call MOM_mesg(" is_E_or_W_2", verb=1)
+ if (segment%temp_segment_data_exists) call MOM_mesg(" temp_segment_data_exists", verb=1)
+ if (segment%salt_segment_data_exists) call MOM_mesg(" salt_segment_data_exists", verb=1)
+
+ write(mesg, '(" Tr_InvLscale_out ", ES16.6)') segment%Tr_InvLscale_out*US%m_to_L
+ call MOM_mesg(mesg, verb=1)
+ write(mesg, '(" Tr_InvLscale_in ", ES16.6)') segment%Tr_InvLscale_in*US%m_to_L
+ call MOM_mesg(mesg, verb=1)
+ write(mesg, '(" Th_InvLscale_out ", ES16.6)') segment%Th_InvLscale_out*US%m_to_L
+ call MOM_mesg(mesg, verb=1)
+ write(mesg, '(" Th_InvLscale_in ", ES16.6)') segment%Th_InvLscale_in*US%m_to_L
+ call MOM_mesg(mesg, verb=1)
+
+ enddo
+
+ call chksum_OBC_segments(OBC, G, GV, US, 0)
+
+end subroutine write_OBC_info
+
+!> Write checksums and perhaps some or all of the values of all the allocated arrays on the OBC segments.
+subroutine chksum_OBC_segments(OBC, G, GV, US, nk)
+ type(ocean_OBC_type), intent(in) :: OBC !< An open boundary condition control structure
+ type(ocean_grid_type), intent(in) :: G !< Rotated grid metric
+ type(verticalGrid_type), intent(in) :: GV !< Vertical grid
+ type(unit_scale_type), intent(in) :: US !< Unit scaling
+ integer, intent(in) :: nk !< The number of layers to print
+
+ ! Local variables
+ integer :: n ! The segment number reported in output
+ integer :: n_seg ! The internal segment number
+
+ do n=1,OBC%number_of_segments
+ n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n
+
+ call chksum_OBC_segment_data(OBC%segment(n_seg), GV, US, nk, n)
+ enddo
+
+end subroutine chksum_OBC_segments
+
+
+!> Write checksums and perhaps some or all of the values of all the allocated arrays on a single OBC segment.
+subroutine chksum_OBC_segment_data(segment, GV, US, nk, nseg_out)
+ type(OBC_segment_type), intent(in) :: segment !< Segment type to checksum
+ type(verticalGrid_type), intent(in) :: GV !< Vertical grid
+ type(unit_scale_type), intent(in) :: US !< Unit scaling
+ integer, intent(in) :: nk !< The number of layers to print
+ integer, intent(in) :: nseg_out !< The segment number reported in output
+
+ ! Local variables
+ real :: norm ! A sign change used when rotating a normal component [nondim]
+ real :: tang ! A sign change used when rotating a tangential component [nondim]
+ character(len=8) :: sn, segno
+ integer :: dir ! This indicates the internal logical orientation of a segment
+
+ dir = segment%direction
+
+ write(segno, '(I0)') nseg_out
+ sn = '('//trim(segno)//')'
+
+ ! Turn each segment and write it as though it is an eastern face.
+ norm = 0.0 ; tang = 0.0
+ if (dir == OBC_DIRECTION_E) then
+ norm = 1.0 ; tang = 1.0
+ elseif (dir == OBC_DIRECTION_N) then
+ norm = 1.0 ; tang = -1.0
+ elseif (dir == OBC_DIRECTION_W) then
+ norm = -1.0 ; tang = -1.0
+ elseif (dir == OBC_DIRECTION_S) then
+ norm = -1.0 ; tang = 1.0
endif
- if (allocated(segment_in%field(n)%buffer_src)) then
- call allocate_rotated_array(segment_in%field(n)%buffer_src, &
- lbound(segment_in%field(n)%buffer_src), turns, &
- segment%field(n)%buffer_src)
- call rotate_array(segment_in%field(n)%buffer_src, turns, &
- segment%field(n)%buffer_src)
+ if (allocated(segment%Htot)) call write_2d_array_vals("Htot"//trim(sn), segment%Htot, dir, nk, unscale=GV%H_to_mks)
+ if (allocated(segment%dZtot)) call write_2d_array_vals("dZtot"//trim(sn), segment%dZtot, dir, nk, unscale=US%Z_to_m)
+ if (allocated(segment%SSH)) call write_2d_array_vals("SSH"//trim(sn), segment%SSH, dir, nk, unscale=US%Z_to_m)
+ if (allocated(segment%normal_vel)) &
+ call write_3d_array_vals("normal_vel"//trim(sn), segment%normal_vel, dir, nk, unscale=norm*US%L_T_to_m_s)
+ if (allocated(segment%normal_vel_bt)) &
+ call write_2d_array_vals("normal_vel_bt"//trim(sn), segment%normal_vel_bt, dir, nk, unscale=norm*US%L_T_to_m_s)
+ if (allocated(segment%tangential_vel)) &
+ call write_3d_array_vals("tangential_vel"//trim(sn), segment%tangential_vel, dir, nk, unscale=tang*US%L_T_to_m_s)
+ if (allocated(segment%tangential_grad)) &
+ call write_3d_array_vals("tangential_grad"//trim(sn), segment%tangential_grad, dir, nk, &
+ unscale=tang*norm*US%s_to_T)
+ if (allocated(segment%normal_trans)) &
+ call write_3d_array_vals("normal_trans"//trim(sn), segment%normal_trans, dir, nk, &
+ unscale=norm*GV%H_to_mks*US%L_T_to_m_s*US%L_to_m)
+ if (allocated(segment%grad_normal)) &
+ call write_3d_array_vals("grad_normal"//trim(sn), segment%grad_normal, dir, nk, unscale=norm*tang*US%L_T_to_m_s)
+ if (allocated(segment%grad_tan)) &
+ call write_3d_array_vals("grad_tan"//trim(sn), segment%grad_tan, dir, nk, unscale=1.0*US%L_T_to_m_s)
+ if (allocated(segment%grad_gradient)) &
+ call write_3d_array_vals("grad_gradient"//trim(sn), segment%grad_gradient, dir, nk, unscale=norm*US%s_to_T)
+
+ if (allocated(segment%rx_norm_rad)) &
+ call write_3d_array_vals("rxy_norm_rad"//trim(sn), segment%rx_norm_rad, dir, nk, unscale=1.0)
+ if (allocated(segment%ry_norm_rad)) &
+ call write_3d_array_vals("rxy_norm_rad"//trim(sn), segment%ry_norm_rad, dir, nk, unscale=1.0)
+ if (segment%is_E_or_W) then
+ if (allocated(segment%rx_norm_obl)) &
+ call write_3d_array_vals("rx_norm_obl"//trim(sn), segment%rx_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2)
+ if (allocated(segment%ry_norm_obl)) &
+ call write_3d_array_vals("ry_norm_obl"//trim(sn), segment%ry_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2)
+ else ! The x- and y- directions are swapped.
+ if (allocated(segment%ry_norm_obl)) &
+ call write_3d_array_vals("rx_norm_obl"//trim(sn), segment%ry_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2)
+ if (allocated(segment%rx_norm_obl)) &
+ call write_3d_array_vals("ry_norm_obl"//trim(sn), segment%rx_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2)
endif
- segment%field(n)%nk_src = segment_in%field(n)%nk_src
+ if (allocated(segment%cff_normal)) &
+ call write_3d_array_vals("cff_normal"//trim(sn), segment%cff_normal, dir, nk, unscale=US%L_T_to_m_s**2)
+ if (allocated(segment%nudged_normal_vel)) &
+ call write_3d_array_vals("nudged_normal_vel"//trim(sn), segment%nudged_normal_vel, dir, nk, &
+ unscale=norm*US%L_T_to_m_s)
+ if (allocated(segment%nudged_tangential_vel)) &
+ call write_3d_array_vals("nudged_tangential_vel"//trim(sn), segment%nudged_tangential_vel, dir, nk, &
+ unscale=tang*US%L_T_to_m_s)
+ if (allocated(segment%nudged_tangential_grad)) &
+ call write_3d_array_vals("nudged_tangential_grad"//trim(sn), segment%nudged_tangential_grad, dir, nk, &
+ unscale=tang*norm*US%s_to_T)
- 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)
+ contains
+
+ !> Write out the values in a named 2-d segment data array
+ subroutine write_2d_array_vals(name, Array, seg_dir, nkp, unscale)
+ character(len=*), intent(in) :: name !< The name of the variable
+ real, dimension(:,:), intent(in) :: Array !< The 2-d array to write [A ~> a]
+ integer, intent(in) :: seg_dir !< The direction of the segment
+ integer, intent(in) :: nkp !< Print all the values if this is greater than 0
+ real, optional, intent(in) :: unscale !< A factor that undoes the scaling of the array [a A-1 ~> 1]
+ ! Local variables
+ real :: scale ! A factor that undoes the scaling of the array [a A-1 ~> 1]
+ character(len=1024) :: mesg
+ character(len=24) :: val
+ integer :: i, j, n, iounit
+
+ scale = 1.0 ; if (present(unscale)) scale = unscale
+ iounit = stderr
+
+ if (nkp > 0) then
+ write(iounit, '(2X,A,":")') trim(name)
+ mesg = "" ; n = 0
+ if ((seg_dir == OBC_DIRECTION_N) .or. (seg_dir == OBC_DIRECTION_W)) then
+ do j=size(Array,2),1,-1 ; do i=size(Array,1),1,-1
+ write(val, '(ES16.6)') scale*Array(i,j)
+ mesg = trim(mesg)//" "//trim(val) ; n = n + 1
+ if (n >= 12) then
+ write(iounit, '(2X,A)') trim(mesg)
+ mesg = "" ; n = 0
+ endif
+ enddo ; enddo
+ else
+ do j=1,size(Array,2) ; do i=1,size(Array,1)
+ write(val, '(ES16.6)') scale*Array(i,j)
+ mesg = trim(mesg)//" "//trim(val) ; n = n + 1
+ if (n >= 12) then
+ write(iounit, '(2X,A)') trim(mesg)
+ mesg = "" ; n = 0
+ endif
+ enddo ; enddo
+ endif
+ if (n > 0) write(iounit, '(2X,A)') trim(mesg)
endif
- segment%field(n)%value = segment_in%field(n)%value
- enddo
+ 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
- segment%temp_segment_data_exists = segment_in%temp_segment_data_exists
- segment%salt_segment_data_exists = segment_in%salt_segment_data_exists
-end subroutine rotate_OBC_segment_data
+end subroutine chksum_OBC_segment_data
!> \namespace mom_open_boundary
!! This module implements some aspects of internal open boundary
diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90
index e24d4954cb..dfe0183fb0 100644
--- a/src/core/MOM_porous_barriers.F90
+++ b/src/core/MOM_porous_barriers.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Module for calculating curve fit for porous topography.
!written by sjd
module MOM_porous_barriers
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE
use MOM_error_handler, only : MOM_error, FATAL
use MOM_grid, only : ocean_grid_type
@@ -24,7 +26,7 @@ module MOM_porous_barriers
#include
!> The control structure for the MOM_porous_barriers module
-type, public :: porous_barrier_CS; private
+type, public :: porous_barrier_CS ; private
logical :: initialized = .false. !< True if this control structure has been initialized.
type(diag_ctrl), pointer :: &
diag => Null() !< A structure to regulate diagnostic output timing
@@ -89,8 +91,8 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt)
call cpu_clock_begin(id_clock_porous_barrier)
- is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke
- Isq = G%IscB; Ieq = G%IecB; Jsq = G%JscB; Jeq = G%JecB
+ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = GV%ke
+ Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
if (CS%answer_date < 20220806) then
dmask = 0.0
@@ -139,7 +141,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt)
endif
! v-points
- do J=Jsq,Jeq ; do i=is,ie; do_I(i,J) = .False. ; enddo ; enddo
+ do J=Jsq,Jeq ; do i=is,ie ; do_I(i,J) = .False. ; enddo ; enddo
do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then
call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), &
@@ -216,8 +218,8 @@ subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt)
call cpu_clock_begin(id_clock_porous_barrier)
- is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke
- Isq = G%IscB; Ieq = G%IecB; Jsq = G%JscB; Jeq = G%JecB
+ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = GV%ke
+ Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
if (CS%answer_date < 20220806) then
dmask = 0.0
@@ -307,11 +309,14 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt)
real :: dz_neglect ! A negligible height difference [Z ~> m]
integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq
- is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke
- Isq = G%IscB; Ieq = G%IecB; Jsq = G%JscB; Jeq = G%JecB
+ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = GV%ke
+ Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
! currently no treatment for using optional find_eta arguments if present
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: eta)
call find_eta(h, tv, G, GV, US, eta, halo_size=1)
+ !$omp target exit data map(from: eta)
dz_neglect = GV%dZ_subroundoff
diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90
index 909c2e9a6a..119337dd49 100644
--- a/src/core/MOM_stoch_eos.F90
+++ b/src/core/MOM_stoch_eos.F90
@@ -1,7 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides the ocean stochastic equation of state
module MOM_stoch_eos
-! This file is part of MOM6. See LICENSE.md for the license.
use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl
use MOM_error_handler, only : MOM_error, FATAL
use MOM_file_parser, only : get_param, param_file_type
@@ -16,7 +19,7 @@ module MOM_stoch_eos
use MOM_verticalGrid, only : verticalGrid_type
!use random_numbers_mod, only : getRandomNumbers, initializeRandomNumberStream, randomNumberStream
-implicit none; private
+implicit none ; private
#include
public MOM_stoch_eos_init
@@ -30,9 +33,9 @@ module MOM_stoch_eos
type, public :: MOM_stoch_eos_CS ; private
real, allocatable :: l2_inv(:,:) !< One over sum of the T cell side side lengths squared [L-2 ~> m-2]
real, allocatable :: rgauss(:,:) !< nondimensional random Gaussian [nondim]
- real :: tfac=0.27 !< Nondimensional decorrelation time factor, ~1/3.7 [nondim]
- real :: amplitude=0.624499 !< Nondimensional standard deviation of Gaussian [nondim]
- integer :: seed !< PRNG seed
+ real :: tfac = 0.27 !< Nondimensional decorrelation time factor, ~1/3.7 [nondim]
+ real :: amplitude = 0.624499 !< Nondimensional standard deviation of Gaussian [nondim]
+ integer :: seed !< PRNG seed
type(PRNG) :: rn_CS !< PRNG control structure
real, allocatable :: pattern(:,:) !< Random pattern for stochastic EOS [nondim]
real, allocatable :: phi(:,:) !< temporal correlation stochastic EOS [nondim]
diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90
index d9ca19985f..78ef287dfc 100644
--- a/src/core/MOM_transcribe_grid.F90
+++ b/src/core/MOM_transcribe_grid.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Module with routines for copying information from a shared dynamic horizontal
!! grid to an ocean-specific horizontal grid and the reverse.
module MOM_transcribe_grid
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : rotate_array, rotate_array_pair
use MOM_domains, only : pass_var, pass_vector
use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, AGRID, BGRID_NE, CORNER
@@ -56,6 +58,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US)
oG%dyT(i,j) = dG%dyT(i+ido,j+jdo)
oG%areaT(i,j) = dG%areaT(i+ido,j+jdo)
oG%bathyT(i,j) = dG%bathyT(i+ido,j+jdo) - oG%Z_ref
+ oG%meanSL(i,j) = dG%meanSL(i+ido,j+jdo) + oG%Z_ref
oG%dF_dx(i,j) = dG%dF_dx(i+ido,j+jdo)
oG%dF_dy(i,j) = dG%dF_dy(i+ido,j+jdo)
@@ -145,6 +148,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US)
! Update the halos in case the dynamic grid has smaller halos than the ocean grid.
call pass_var(oG%areaT, oG%Domain)
call pass_var(oG%bathyT, oG%Domain)
+ call pass_var(oG%meanSL, oG%Domain)
call pass_var(oG%geoLonT, oG%Domain)
call pass_var(oG%geoLatT, oG%Domain)
call pass_vector(oG%dxT, oG%dyT, oG%Domain, To_All+Scalar_Pair, AGRID)
@@ -217,6 +221,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US)
dG%dyT(i,j) = oG%dyT(i+ido,j+jdo)
dG%areaT(i,j) = oG%areaT(i+ido,j+jdo)
dG%bathyT(i,j) = oG%bathyT(i+ido,j+jdo) + oG%Z_ref
+ dG%meanSL(i,j) = oG%meanSL(i+ido,j+jdo) - oG%Z_ref
dG%dF_dx(i,j) = oG%dF_dx(i+ido,j+jdo)
dG%dF_dy(i,j) = oG%dF_dy(i+ido,j+jdo)
@@ -307,6 +312,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US)
! Update the halos in case the dynamic grid has smaller halos than the ocean grid.
call pass_var(dG%areaT, dG%Domain)
call pass_var(dG%bathyT, dG%Domain)
+ call pass_var(dG%meanSL, dG%Domain)
call pass_var(dG%geoLonT, dG%Domain)
call pass_var(dG%geoLatT, dG%Domain)
call pass_vector(dG%dxT, dG%dyT, dG%Domain, To_All+Scalar_Pair, AGRID)
diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90
index bd449d0b39..26ada953b2 100644
--- a/src/core/MOM_unit_tests.F90
+++ b/src/core/MOM_unit_tests.F90
@@ -1,8 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Invokes unit tests in all modules that have them
module MOM_unit_tests
-! This file is part of MOM6. See LICENSE.md for the license.
-
+use MOM_array_transform, only : symmetric_sum_unit_tests
+use MOM_diag_buffers, only : diag_buffer_unit_tests_2d, diag_buffer_unit_tests_3d
use MOM_error_handler, only : MOM_error, FATAL, is_root_pe
use MOM_hor_bnd_diffusion, only : near_boundary_unit_tests
use MOM_intrinsic_functions, only : intrinsic_functions_unit_tests
@@ -33,6 +37,8 @@ subroutine unit_tests(verbosity)
if (is_root_pe()) then ! The following need only be tested on 1 PE
if (string_functions_unit_tests(verbose)) call MOM_error(FATAL, &
"MOM_unit_tests: string_functions_unit_tests FAILED")
+ if (symmetric_sum_unit_tests(verbose)) call MOM_error(FATAL, &
+ "MOM_unit_tests: symmetric_sum_unit_tests FAILED")
if (EOS_unit_tests(verbose)) call MOM_error(FATAL, &
"MOM_unit_tests: EOS_unit_tests FAILED")
if (remapping_unit_tests(verbose)) call MOM_error(FATAL, &
@@ -49,6 +55,10 @@ subroutine unit_tests(verbosity)
"MOM_unit_tests: CFC_cap_unit_tests FAILED")
if (mixedlayer_restrat_unit_tests(verbose)) call MOM_error(FATAL, &
"MOM_unit_tests: mixedlayer_restrat_unit_tests FAILED")
+ if (diag_buffer_unit_tests_2d(verbose)) call MOM_error(FATAL, &
+ "MOM_unit_tests: diag_buffer_unit_tests_2d FAILED")
+ if (diag_buffer_unit_tests_3d(verbose)) call MOM_error(FATAL, &
+ "MOM_unit_tests: diag_buffer_unit_tests_3d FAILED")
endif
end subroutine unit_tests
diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90
index cc5059bd48..6a6ca15dae 100644
--- a/src/core/MOM_variables.F90
+++ b/src/core/MOM_variables.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides transparent structures with groups of MOM6 variables and supporting routines
module MOM_variables
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : rotate_array, rotate_vector
use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type
use MOM_coupler_types, only : coupler_type_spawn, coupler_type_destructor, coupler_type_initialized
@@ -89,9 +91,9 @@ module MOM_variables
!! When conservative temperature is used, this is
!! constant and exactly 3991.86795711963 J degC-1 kg-1.
logical :: T_is_conT = .false. !< If true, the temperature variable tv%T is
- !! actually the conservative temperature [degC].
+ !! actually the conservative temperature [C ~> degC].
logical :: S_is_absS = .false. !< If true, the salinity variable tv%S is
- !! actually the absolute salinity in units of [gSalt kg-1].
+ !! actually the absolute salinity in units of [S ~> gSalt kg-1].
real :: min_salinity !< The minimum value of salinity when BOUND_SALINITY=True [S ~> ppt].
real, allocatable, dimension(:,:,:) :: SpV_avg
!< The layer averaged in situ specific volume [R-1 ~> m3 kg-1].
@@ -101,8 +103,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
@@ -401,7 +404,7 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, &
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
- isdB = G%isdB ; iedB = G%iedB; jsdB = G%jsdB ; jedB = G%jedB
+ isdB = G%isdB ; iedB = G%iedB ; jsdB = G%jsdB ; jedB = G%jedB
use_temp = .true. ; if (present(use_temperature)) use_temp = use_temperature
alloc_integ = .true. ; if (present(do_integrals)) alloc_integ = do_integrals
@@ -576,12 +579,16 @@ subroutine alloc_BT_cont_type(BT_cont, G, GV, alloc_faces)
"alloc_BT_cont_type called with an associated BT_cont_type pointer.")
allocate(BT_cont)
+ !$omp target enter data map(to: BT_cont)
allocate(BT_cont%FA_u_WW(IsdB:IedB,jsd:jed), source=0.0)
allocate(BT_cont%FA_u_W0(IsdB:IedB,jsd:jed), source=0.0)
allocate(BT_cont%FA_u_E0(IsdB:IedB,jsd:jed), source=0.0)
allocate(BT_cont%FA_u_EE(IsdB:IedB,jsd:jed), source=0.0)
allocate(BT_cont%uBT_WW(IsdB:IedB,jsd:jed), source=0.0)
allocate(BT_cont%uBT_EE(IsdB:IedB,jsd:jed), source=0.0)
+ !$omp target enter data map(to: BT_cont%FA_u_WW, BT_cont%FA_u_W0)
+ !$omp target enter data map(to: BT_cont%FA_u_E0, BT_cont%FA_u_EE)
+ !$omp target enter data map(to: BT_cont%uBT_WW, BT_cont%uBT_EE)
allocate(BT_cont%FA_v_SS(isd:ied,JsdB:JedB), source=0.0)
allocate(BT_cont%FA_v_S0(isd:ied,JsdB:JedB), source=0.0)
@@ -589,10 +596,14 @@ subroutine alloc_BT_cont_type(BT_cont, G, GV, alloc_faces)
allocate(BT_cont%FA_v_NN(isd:ied,JsdB:JedB), source=0.0)
allocate(BT_cont%vBT_SS(isd:ied,JsdB:JedB), source=0.0)
allocate(BT_cont%vBT_NN(isd:ied,JsdB:JedB), source=0.0)
+ !$omp target enter data map(to: BT_cont%FA_v_SS, BT_cont%FA_v_S0)
+ !$omp target enter data map(to: BT_cont%FA_v_N0, BT_cont%FA_v_NN)
+ !$omp target enter data map(to: BT_cont%vBT_SS, BT_cont%vBT_NN)
if (present(alloc_faces)) then ; if (alloc_faces) then
allocate(BT_cont%h_u(IsdB:IedB,jsd:jed,1:nz), source=0.0)
allocate(BT_cont%h_v(isd:ied,JsdB:JedB,1:nz), source=0.0)
+ !$omp target enter data map(to: BT_cont%h_u, BT_cont%h_v)
endif ; endif
end subroutine alloc_BT_cont_type
@@ -603,19 +614,28 @@ subroutine dealloc_BT_cont_type(BT_cont)
if (.not.associated(BT_cont)) return
- deallocate(BT_cont%FA_u_WW) ; deallocate(BT_cont%FA_u_W0)
- deallocate(BT_cont%FA_u_E0) ; deallocate(BT_cont%FA_u_EE)
+ !$omp target exit data map(delete: BT_cont%FA_u_EE, BT_cont%FA_u_E0)
+ !$omp target exit data map(delete: BT_cont%FA_u_W0, BT_cont%FA_u_WW)
+ !$omp target exit data map(delete: BT_cont%uBT_WW, BT_cont%uBT_EE)
+ deallocate(BT_cont%FA_u_EE) ; deallocate(BT_cont%FA_u_E0)
+ deallocate(BT_cont%FA_u_W0) ; deallocate(BT_cont%FA_u_WW)
deallocate(BT_cont%uBT_WW) ; deallocate(BT_cont%uBT_EE)
- deallocate(BT_cont%FA_v_SS) ; deallocate(BT_cont%FA_v_S0)
- deallocate(BT_cont%FA_v_N0) ; deallocate(BT_cont%FA_v_NN)
+ !$omp target exit data map(delete: BT_cont%FA_v_NN, BT_cont%FA_v_N0)
+ !$omp target exit data map(delete: BT_cont%FA_v_S0, BT_cont%FA_v_SS)
+ !$omp target exit data map(delete: BT_cont%vBT_SS, BT_cont%vBT_NN)
+ deallocate(BT_cont%FA_v_NN) ; deallocate(BT_cont%FA_v_N0)
+ deallocate(BT_cont%FA_v_S0) ; deallocate(BT_cont%FA_v_SS)
deallocate(BT_cont%vBT_SS) ; deallocate(BT_cont%vBT_NN)
- if (allocated(BT_cont%h_u)) deallocate(BT_cont%h_u)
- if (allocated(BT_cont%h_v)) deallocate(BT_cont%h_v)
+ ! These are always allocated in pairs.
+ if (allocated(BT_cont%h_u) .and. allocated(BT_cont%h_v)) then
+ !$omp target exit data map(delete: BT_cont%h_u, BT_cont%h_v)
+ deallocate(BT_cont%h_u, BT_cont%h_v)
+ endif
+ !$omp target exit data map(delete: BT_cont)
deallocate(BT_cont)
-
end subroutine dealloc_BT_cont_type
!> Diagnostic checksums on various elements of a thermo_var_ptrs type for debugging.
diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90
index 4713fb6797..ef6d9d8eb0 100644
--- a/src/core/MOM_verticalGrid.F90
+++ b/src/core/MOM_verticalGrid.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides a transparent vertical ocean grid type and supporting routines
module MOM_verticalGrid
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
use MOM_unit_scaling, only : unit_scale_type
@@ -74,7 +76,7 @@ module MOM_verticalGrid
real :: H_to_m !< A constant that translates distances in the units of thickness
!! to m [m H-1 ~> 1 or m3 kg-1].
real :: H_to_Pa !< A constant that translates the units of thickness to pressure
- !! [Pa H-1 = kg m-1 s-2 H-1 ~> kg m-2 s-2 or m s-2].
+ !! [Pa H-1 ~> kg m-2 s-2 or m s-2].
real :: H_to_Z !< A constant that translates thickness units to the units of
!! depth [Z H-1 ~> 1 or m3 kg-1].
real :: Z_to_H !< A constant that translates depth units to thickness units
@@ -131,7 +133,7 @@ subroutine verticalGridInit( param_file, GV, US )
call get_param(param_file, mdl, "RHO_0", GV%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "BOUSSINESQ", GV%Boussinesq, &
diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90
index 30f080382c..e8c116d99c 100644
--- a/src/diagnostics/MOM_PointAccel.F90
+++ b/src/diagnostics/MOM_PointAccel.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Debug accelerations at a given point
!!
!! The two subroutines in this file write out all of the terms
@@ -7,8 +11,6 @@
!! often this is done for debugging purposes.
module MOM_PointAccel
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl
use MOM_domains, only : pe_here
use MOM_error_handler, only : MOM_error, NOTE
@@ -148,7 +150,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st
enddo
ke = k
if (ke < ks) then
- ks = 1; ke = nz; write(file,'("U: Unable to set ks & ke.")')
+ ks = 1 ; ke = nz ; write(file,'("U: Unable to set ks & ke.")')
endif
if (CS%full_column) then
ks = 1 ; ke = nz
@@ -157,8 +159,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st
call get_date(CS%Time, yr, mo, day, hr, minute, sec)
call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday)
write (file,'(/,"--------------------------")')
- write (file,'(/,"Time ",i5,i4,F6.2," U-velocity violation at ",I4,": ",2(I3), &
- & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') &
+ write (file,'(/,"Time ",I0," ",I0," ",F6.2," U-velocity violation at ",I0,": ",I0,", ",I0, &
+ & " (",F7.2," E ",F7.2," N) Layers ",I0," to ",I0,". dt = ",1PG10.4)') &
yr, yearday, (REAL(sec)/3600.0), pe_here(), I, j, &
G%geoLonCu(I,j), G%geoLatCu(I,j), ks, ke, US%T_to_s*dt
@@ -488,7 +490,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st
enddo
ke = k
if (ke < ks) then
- ks = 1; ke = nz; write(file,'("V: Unable to set ks & ke.")')
+ ks = 1 ; ke = nz ; write(file,'("V: Unable to set ks & ke.")')
endif
if (CS%full_column) then
ks = 1 ; ke = nz
@@ -497,8 +499,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st
call get_date(CS%Time, yr, mo, day, hr, minute, sec)
call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday)
write (file,'(/,"--------------------------")')
- write (file,'(/,"Time ",i5,i4,F6.2," V-velocity violation at ",I4,": ",2(I3), &
- & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') &
+ write (file,'(/,"Time ",I0," ",I0," ",F6.2," V-velocity violation at ",I0,": ",I0,", ",I0, &
+ & " (",F7.2," E ",F7.2," N) Layers ",I0," to ",I0,". dt = ",1PG10.4)') &
yr, yearday, (REAL(sec)/3600.0), pe_here(), i, J, &
G%geoLonCv(i,J), G%geoLatCv(i,J), ks, ke, US%T_to_s*dt
@@ -769,8 +771,8 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS)
CS%T => MIS%T ; CS%S => MIS%S
CS%u_accel_bt => MIS%u_accel_bt ; CS%v_accel_bt => MIS%v_accel_bt
CS%u_prev => MIS%u_prev ; CS%v_prev => MIS%v_prev
- CS%u_av => MIS%u_av; if (.not.associated(MIS%u_av)) CS%u_av => MIS%u(:,:,:)
- CS%v_av => MIS%v_av; if (.not.associated(MIS%v_av)) CS%v_av => MIS%v(:,:,:)
+ CS%u_av => MIS%u_av ; if (.not.associated(MIS%u_av)) CS%u_av => MIS%u(:,:,:)
+ CS%v_av => MIS%v_av ; if (.not.associated(MIS%v_av)) CS%v_av => MIS%v(:,:,:)
! Read all relevant parameters and write them to the model log.
call log_version(param_file, mdl, version, "", debugging=.true.)
diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90
index 85af39e377..56efe2fd42 100644
--- a/src/diagnostics/MOM_debugging.F90
+++ b/src/diagnostics/MOM_debugging.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides checksumming functions for debugging
!!
!! This module contains subroutines that perform various error checking and
@@ -6,8 +10,6 @@
!! separate we retain the ability to set up MOM6 and SIS2 debugging separately.
module MOM_debugging
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum, hchksum_pair
use MOM_checksums, only : is_NaN, chksum, MOM_checksums_init
use MOM_coms, only : PE_here, root_PE, num_PEs
@@ -140,11 +142,7 @@ subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, &
integer :: k
do k=1,size(u_comp,3)
- if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k
- elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k
- elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k
- else ; write(mesg_k,'(" Layer",i9," ")') k ; endif
-
+ write(mesg_k,'(" Layer ",i0," ")') k
call check_redundant_vC2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), &
v_comp(:,:,k), G, is, ie, js, je, direction, unscale)
enddo
@@ -196,8 +194,8 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, &
u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j)
enddo ; enddo
- if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//&
- " called with a non-associated auxiliary domain the grid type.")
+ if (.not.associated(G%Domain_aux)) call MOM_error(FATAL, &
+ " check_redundant called with a non-associated auxiliary domain the grid type.")
call pass_vector(u_nonsym, v_nonsym, G%Domain_aux, direction)
do I=IsdB,IedB ; do j=jsd,jed ; u_resym(I,j) = u_comp(I,j) ; enddo ; enddo
@@ -215,7 +213,7 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, &
if (u_resym(i,j) /= u_comp(i,j) .and. &
redundant_prints(3) < max_redundant_prints) then
write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", &
- & 1pe12.4," at i,j = ",2i4," on pe ",i4)') &
+ & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') &
sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here()
write(0,'(A130)') trim(mesg)//trim(mesg2)
redundant_prints(3) = redundant_prints(3) + 1
@@ -225,7 +223,7 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, &
if (v_resym(i,j) /= v_comp(i,j) .and. &
redundant_prints(3) < max_redundant_prints) then
write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", &
- & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') &
+ & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') &
sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, &
G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here()
write(0,'(A155)') trim(mesg)//trim(mesg2)
@@ -253,11 +251,7 @@ subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je, unscale)
integer :: k
do k=1,size(array,3)
- if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k
- elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k
- elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k
- else ; write(mesg_k,'(" Layer",i9," ")') k ; endif
-
+ write(mesg_k,'(" Layer ",i0," ")') k
call check_redundant_sB2d(trim(mesg)//trim(mesg_k), array(:,:,k), &
G, is, ie, js, je, unscale)
enddo
@@ -300,8 +294,8 @@ subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je, unscale)
a_nonsym(i,j) = array(i,j)
enddo ; enddo
- if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//&
- " called with a non-associated auxiliary domain the grid type.")
+ if (.not.associated(G%Domain_aux)) call MOM_error(FATAL, &
+ " check_redundant called with a non-associated auxiliary domain the grid type.")
call pass_vector(a_nonsym, a_nonsym, G%Domain_aux, &
direction=To_All+Scalar_Pair, stagger=BGRID_NE)
@@ -320,7 +314,7 @@ subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je, unscale)
if (a_resym(i,j) /= array(i,j) .and. &
redundant_prints(2) < max_redundant_prints) then
write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", &
- & 1pe12.4," at i,j = ",2i4," on pe ",i4)') &
+ & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') &
sc*array(i,j), sc*a_resym(i,j), sc*(array(i,j)-a_resym(i,j)), i, j, pe_here()
write(0,'(A130)') trim(mesg)//trim(mesg2)
redundant_prints(2) = redundant_prints(2) + 1
@@ -353,11 +347,7 @@ subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, &
integer :: k
do k=1,size(u_comp,3)
- if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k
- elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k
- elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k
- else ; write(mesg_k,'(" Layer",i9," ")') k ; endif
-
+ write(mesg_k,'(" Layer ",i0," ")') k
call check_redundant_vB2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), &
v_comp(:,:,k), G, is, ie, js, je, direction, unscale)
enddo
@@ -409,8 +399,8 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, &
u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j)
enddo ; enddo
- if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//&
- " called with a non-associated auxiliary domain the grid type.")
+ if (.not.associated(G%Domain_aux)) call MOM_error(FATAL, &
+ " check_redundant called with a non-associated auxiliary domain the grid type.")
call pass_vector(u_nonsym, v_nonsym, G%Domain_aux, direction, stagger=BGRID_NE)
do I=IsdB,IedB ; do J=JsdB,JedB
@@ -429,7 +419,7 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, &
if (u_resym(i,j) /= u_comp(i,j) .and. &
redundant_prints(2) < max_redundant_prints) then
write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", &
- & 1pe12.4," at i,j = ",2i4," on pe ",i4)') &
+ & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') &
sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here()
write(0,'(A130)') trim(mesg)//trim(mesg2)
redundant_prints(2) = redundant_prints(2) + 1
@@ -439,7 +429,7 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, &
if (v_resym(i,j) /= v_comp(i,j) .and. &
redundant_prints(2) < max_redundant_prints) then
write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", &
- & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') &
+ & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') &
sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, &
G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here()
write(0,'(A155)') trim(mesg)//trim(mesg2)
@@ -466,11 +456,7 @@ subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je, unscale)
integer :: k
do k=1,size(array,3)
- if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k
- elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k
- elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k
- else ; write(mesg_k,'(" Layer",i9," ")') k ; endif
-
+ write(mesg_k,'(" Layer ",i0," ")') k
call check_redundant_sT2d(trim(mesg)//trim(mesg_k), array(:,:,k), &
G, is, ie, js, je, unscale)
enddo
@@ -520,7 +506,7 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je, unscale)
if (a_nonsym(i,j) /= array(i,j) .and. &
redundant_prints(1) < max_redundant_prints) then
write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", &
- & 1pe12.4," at i,j = ",2i4," on pe ",i4)') &
+ & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') &
sc*array(i,j), sc*a_nonsym(i,j), sc*(array(i,j)-a_nonsym(i,j)), i, j, pe_here()
write(0,'(A130)') trim(mesg)//trim(mesg2)
redundant_prints(1) = redundant_prints(1) + 1
@@ -553,11 +539,7 @@ subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, &
integer :: k
do k=1,size(u_comp,3)
- if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k
- elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k
- elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k
- else ; write(mesg_k,'(" Layer",i9," ")') k ; endif
-
+ write(mesg_k,'(" Layer ",i0," ")') k
call check_redundant_vT2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), &
v_comp(:,:,k), G, is, ie, js, je, direction, unscale)
enddo
@@ -616,7 +598,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, &
if (u_nonsym(i,j) /= u_comp(i,j) .and. &
redundant_prints(1) < max_redundant_prints) then
write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", &
- & 1pe12.4," at i,j = ",2i4," on pe ",i4)') &
+ & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') &
sc*u_comp(i,j), sc*u_nonsym(i,j), sc*(u_comp(i,j)-u_nonsym(i,j)), i, j, pe_here()
write(0,'(A130)') trim(mesg)//trim(mesg2)
redundant_prints(1) = redundant_prints(1) + 1
@@ -626,7 +608,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, &
if (v_nonsym(i,j) /= v_comp(i,j) .and. &
redundant_prints(1) < max_redundant_prints) then
write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", &
- & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') &
+ & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') &
sc*v_comp(i,j), sc*v_nonsym(i,j), sc*(v_comp(i,j)-v_nonsym(i,j)), i, j, &
G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here()
write(0,'(A155)') trim(mesg)//trim(mesg2)
@@ -659,7 +641,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 +673,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 +705,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 +740,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 +773,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 +806,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..b981da9af1 100644
--- a/src/diagnostics/MOM_diagnose_KdWork.F90
+++ b/src/diagnostics/MOM_diagnose_KdWork.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides diagnostics of work due to a given diffusivity
module MOM_diagnose_kdwork
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl, time_type, post_data, register_diag_field
use MOM_diag_mediator, only : register_scalar_field
use MOM_error_handler, only : MOM_error, FATAL, WARNING
@@ -32,13 +34,13 @@ module MOM_diagnose_kdwork
! 3d varying Kd contributions
real, pointer, dimension(:,:,:) :: &
Bflx_salt => NULL(), & !< Salinity contribution to buoyancy flux at interfaces
- !! [H Z T-3 ~> m2 s-3 or kg m-1 s-3 = W m-3]
+ !! [H Z T-3 ~> m2 s-3 or W m-3]
Bflx_temp => NULL(), & !< Temperature contribution to buoyancy flux at interfaces
- !! [H Z T-3 ~> m2 s-3 or kg m-1 s-3 = W m-3]
+ !! [H Z T-3 ~> m2 s-3 or W m-3]
Bflx_salt_dz => NULL(), & !< Salinity contribution to integral of buoyancy flux over layer
- !! [H Z2 T-3 ~> m3 s-3 or kg m-1 s-3 = W m-2]
+ !! [H Z2 T-3 ~> m3 s-3 or W m-2]
Bflx_temp_dz => NULL(), & !< Temperature contribution to integral of buoyancy flux over layer
- !! [H Z2 T-3 ~> m3 s-3 or kg m-1 s-3 = W m-2]
+ !! [H Z2 T-3 ~> m3 s-3 or W m-2]
! The following are all allocatable arrays that store copies of process driven Kd, so that
! the process driven buoyancy flux and work can be derived at the end of the time step.
Kd_salt => NULL(), & !< total diapycnal diffusivity of salt at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1]
@@ -123,7 +125,7 @@ subroutine KdWork_Diagnostics(G,GV,US,diag,VBF,N2_Salt,N2_Temp,dz)
integer :: i, j, k, nz, isc, iec, jsc, jec
- isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ;
+ isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec
nz = GV%ke
@@ -340,7 +342,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
@@ -740,11 +742,11 @@ subroutine diagnoseKdWork(G, GV, N2, Kd, Bdif_flx, dz, Bdif_flx_dz)
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), &
intent(in) :: Kd !< Diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), &
- intent(out) :: Bdif_flx !< Buoyancy flux [H Z T-3 ~> m2 s-3 or kg m-1 s-3 = W m-3]
+ intent(out) :: Bdif_flx !< Buoyancy flux [H Z T-3 ~> m2 s-3 or W m-3]
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
intent(in), optional :: dz !< Grid spacing [Z ~> m]
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
- intent(out), optional :: Bdif_flx_dz !< Buoyancy flux over layer [H Z2 T-3 ~> m3 s-3 or kg s-3 = W m-2]
+ intent(out), optional :: Bdif_flx_dz !< Buoyancy flux over layer [H Z2 T-3 ~> m3 s-3 or W m-2]
integer :: i, j, k
@@ -753,13 +755,13 @@ subroutine diagnoseKdWork(G, GV, N2, Kd, Bdif_flx, dz, Bdif_flx_dz)
!$OMP parallel do default(shared)
do K=2,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec
Bdif_flx(i,j,K) = - N2(i,j,K) * Kd(i,j,K)
- enddo ; enddo; enddo
+ enddo ; enddo ; enddo
if (present(Bdif_flx_dz) .and. present(dz)) then
!$OMP parallel do default(shared)
do K=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec
Bdif_flx_dz(i,j,k) = 0.5*(Bdif_flx(i,j,K)+Bdif_flx(i,j,K+1))*dz(i,j,k)
- enddo ; enddo; enddo
+ enddo ; enddo ; enddo
endif
end subroutine diagnoseKdWork
@@ -783,37 +785,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..b2b231cb37 100644
--- a/src/diagnostics/MOM_diagnose_MLD.F90
+++ b/src/diagnostics/MOM_diagnose_MLD.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides functions for some diabatic processes such as fraxil, brine rejection,
!! tendency due to surface flux divergence.
module MOM_diagnose_mld
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data
use MOM_diag_mediator, only : diag_ctrl
use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain
@@ -246,7 +248,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 +280,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 +320,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 +337,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 +407,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 +425,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..958eebdbe3 100644
--- a/src/diagnostics/MOM_diagnostics.F90
+++ b/src/diagnostics/MOM_diagnostics.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Calculates any requested diagnostic quantities
!! that are not calculated in the various subroutines.
!! Diagnostic quantities are requested by allocating them memory.
module MOM_diagnostics
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : reproducing_sum
use MOM_coupler_types, only : coupler_type_send_data
use MOM_density_integrals, only : int_density_dz
@@ -20,11 +22,12 @@ module MOM_diagnostics
use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type
use MOM_domains, only : To_North, To_East
use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain
-use MOM_EOS, only : cons_temp_to_pot_temp, abs_saln_to_prac_saln
+use MOM_EOS, only : cons_temp_to_pot_temp, pot_temp_to_cons_temp
+use MOM_EOS, only : prac_saln_to_abs_saln, abs_saln_to_prac_saln
use MOM_error_handler, only : MOM_error, FATAL, WARNING
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_grid, only : ocean_grid_type
-use MOM_interface_heights, only : find_eta
+use MOM_interface_heights, only : find_eta, find_dz_for_eta, find_col_mass
use MOM_spatial_means, only : global_area_mean, global_layer_mean
use MOM_spatial_means, only : global_volume_mean, global_area_integral
use MOM_tracer_registry, only : tracer_registry_type, post_tracer_transport_diagnostics
@@ -33,13 +36,13 @@ module MOM_diagnostics
use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, surface
use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units, get_flux_units
use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init
+use Recon1d_EPPM_CWK, only : EPPM_CWK
implicit none ; private
#include
public calculate_diagnostic_fields, register_time_deriv, write_static_fields
-public find_eta
public register_surface_diags, post_surface_dyn_diags, post_surface_thermo_diags
public register_transport_diags, post_transport_diagnostics
public MOM_diagnostics_init, MOM_diagnostics_end
@@ -57,6 +60,10 @@ module MOM_diagnostics
!! barotropic wave speed [nondim].
real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of
!! calculating the equivalent barotropic wave speed [H ~> m or kg m-2].
+ logical :: accurate_thick_cello !< If true, use the same careful integrals to find the diagnosed
+ !! non-Boussinesq layer thicknesses as are used to find the free
+ !! surface height, instead of using an approximate thickness
+ !! based on division by the mid-layer density.
type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to
!! regulate the timing of diagnostic output.
@@ -98,6 +105,9 @@ module MOM_diagnostics
integer :: id_cg_ebt = -1, id_Rd_ebt = -1
integer :: id_p_ebt = -1
integer :: id_temp_int = -1, id_salt_int = -1
+ integer :: id_absscint = -1, id_pfscint = -1
+ integer :: id_scint = -1
+ integer :: id_chcint = -1, id_phcint = -1
integer :: id_mass_wt = -1, id_col_mass = -1
integer :: id_masscello = -1, id_masso = -1
integer :: id_volcello = -1
@@ -115,6 +125,7 @@ module MOM_diagnostics
integer :: id_drho_dT = -1, id_drho_dS = -1
integer :: id_h_pre_sync = -1
integer :: id_tosq = -1, id_sosq = -1
+ integer :: id_t20d = -1, id_t17d = -1
!>@}
type(wave_speed_CS) :: wave_speed !< Wave speed control struct
@@ -209,6 +220,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
real :: Rcv(SZI_(G),SZJ_(G),SZK_(GV)) ! Coordinate variable potential density [R ~> kg m-3].
real :: work_3d(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary work array in various units
! including [nondim] and [H ~> m or kg m-2].
+ real :: dz_lay(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m]
real :: uh_tmp(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary zonal transport [H L2 T-1 ~> m3 s-1 or kg s-1]
real :: vh_tmp(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary meridional transport [H L2 T-1 ~> m3 s-1 or kg s-1]
real :: mass_cell(SZI_(G),SZJ_(G)) ! The vertically integrated mass in a grid cell [R Z L2 ~> kg]
@@ -218,7 +230,6 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
real :: CFL_cg1(SZI_(G),SZJ_(G)) ! CFL for first baroclinic gravity wave speed, either based on the
! overall grid spacing or just one direction [nondim]
-
! tmp array for surface properties
real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa]
real :: wt, wt_p ! The fractional weights of two successive values when interpolating from
@@ -312,22 +323,31 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
call post_data(CS%id_uv, uv, CS%diag)
endif
- ! Find the interface heights, relative either to a reference height or to the bottom [Z ~> m].
- if (CS%id_e > 0) then
- call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref)
+ ! Find the layer thicknesses in [Z ~> m] that can be used to determine interface heights
+ if ((CS%id_e > 0) .or. (CS%id_e_D > 0) .or. &
+ ((CS%id_thkcello>0 .or. CS%id_volcello>0) .and. (CS%accurate_thick_cello))) &
+ call find_dz_for_eta(h, tv, G, GV, US, dz_lay)
+
+ if ((CS%id_e > 0) .or. (CS%id_e_D > 0)) then
+ ! Find the interface heights, relative a reference height or to the bottom [Z ~> m]
+ do j=js,je ; do i=is,ie ; eta(i,j,nz+1) = -(G%bathyT(i,j) + G%Z_ref) ; enddo ; enddo
+ do k=nz,1,-1 ; do j=js,je ; do i=is,ie
+ eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,K)
+ enddo ; enddo ; enddo
if (CS%id_e > 0) call post_data(CS%id_e, eta, CS%diag)
+
if (CS%id_e_D > 0) then
+ ! Find the interface heights, relative to the bottom [Z ~> m]
do k=1,nz+1 ; do j=js,je ; do i=is,ie
eta(i,j,k) = eta(i,j,k) + (G%bathyT(i,j) + G%Z_ref)
enddo ; enddo ; enddo
+ ! This is more accurate but changes answers in the e_D diagnostic:
+ ! do j=js,je ; do i=is,ie ; eta(i,j,nz+1) = 0.0 ; enddo ; enddo
+ ! do k=nz,1,-1 ; do j=js,je ; do i=is,ie
+ ! eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,K)
+ ! enddo ; enddo ; enddo
call post_data(CS%id_e_D, eta, CS%diag)
endif
- elseif (CS%id_e_D > 0) then
- call find_eta(h, tv, G, GV, US, eta)
- do k=1,nz+1 ; do j=js,je ; do i=is,ie
- eta(i,j,k) = eta(i,j,k) + G%bathyT(i,j)
- enddo ; enddo ; enddo
- call post_data(CS%id_e_D, eta, CS%diag)
endif
! mass per area of grid cell (for Boussinesq, use Rho0)
@@ -335,7 +355,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
call post_data(CS%id_masscello, h, CS%diag)
endif
- ! mass of liquid ocean (for Bouss, use Rho0). The reproducing sum requires the use of MKS units.
+ ! mass of liquid ocean (for Bouss, use Rho0) [R Z L2 ~> kg]
if (CS%id_masso > 0) then
mass_cell(:,:) = 0.0
do k=1,nz ; do j=js,je ; do i=is,ie
@@ -352,9 +372,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
call post_data(CS%id_thkcello, h, CS%diag)
else
do k=1,nz ; do j=js,je ; do i=is,ie
- work_3d(i,j,k) = GV%H_to_Z*h(i,j,k)
+ dz_lay(i,j,k) = GV%H_to_Z*h(i,j,k)
enddo ; enddo ; enddo
- call post_data(CS%id_thkcello, work_3d, CS%diag)
+ call post_data(CS%id_thkcello, dz_lay, CS%diag)
endif ; endif
if (CS%id_volcello > 0) then ! volcello = h*area for Boussinesq
do k=1,nz ; do j=js,je ; do i=is,ie
@@ -362,37 +382,41 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
enddo ; enddo ; enddo
call post_data(CS%id_volcello, work_3d, CS%diag)
endif
- else ! thkcello = dp/(rho*g) for non-Boussinesq
- EOSdom(:) = EOS_domain(G%HI)
- do j=js,je
- if (associated(p_surf)) then ! Pressure loading at top of surface layer [R L2 T-2 ~> Pa]
- do i=is,ie
- pressure_1d(i) = p_surf(i,j)
- enddo
- else
- do i=is,ie
- pressure_1d(i) = 0.0
- enddo
- endif
- do k=1,nz ! Integrate vertically downward for pressure
- do i=is,ie ! Pressure for EOS at the layer center [R L2 T-2 ~> Pa]
- pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k)
- enddo
- ! Store in-situ density [R ~> kg m-3] in work_3d
- call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, &
- tv%eqn_of_state, EOSdom)
- do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d
- work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i)
- enddo
- do i=is,ie ! Pressure for EOS at the bottom interface [R L2 T-2 ~> Pa]
- pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k)
- enddo
- enddo ! k
- enddo ! j
- if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, work_3d, CS%diag)
+ else ! thkcello is approximately dp/(rho*g) in non-Boussinesq mode.
+ if (.not.CS%accurate_thick_cello) then
+ ! This is only an approximate calculation of dz_lay that does not use the careful integrals
+ ! found in find_dz_for_eta that mirror what is done for the pressure gradient calculations.
+ EOSdom(:) = EOS_domain(G%HI)
+ do j=js,je
+ if (associated(p_surf)) then ! Pressure loading at top of surface layer [R L2 T-2 ~> Pa]
+ do i=is,ie
+ pressure_1d(i) = p_surf(i,j)
+ enddo
+ else
+ do i=is,ie
+ pressure_1d(i) = 0.0
+ enddo
+ endif
+ do k=1,nz ! Integrate vertically downward for pressure
+ do i=is,ie ! Pressure for EOS at the layer center [R L2 T-2 ~> Pa]
+ pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k)
+ enddo
+ ! Store in-situ density [R ~> kg m-3] in work_3d
+ call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, &
+ tv%eqn_of_state, EOSdom)
+ do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d
+ dz_lay(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i)
+ enddo
+ do i=is,ie ! Pressure for EOS at the bottom interface [R L2 T-2 ~> Pa]
+ pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k)
+ enddo
+ enddo ! k
+ enddo ! j
+ endif ! Otherwise dz_lay is set in the call to find_dz_for_eta above.
+ if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, dz_lay, CS%diag)
if (CS%id_volcello > 0) then
do k=1,nz ; do j=js,je ; do i=is,ie ! volcello = dp/(rho*g)*area for non-Boussinesq
- work_3d(i,j,k) = US%Z_to_m*US%L_to_m**2*G%areaT(i,j) * work_3d(i,j,k)
+ work_3d(i,j,k) = US%Z_to_m*US%L_to_m**2*G%areaT(i,j) * dz_lay(i,j,k)
enddo ; enddo ; enddo
call post_data(CS%id_volcello, work_3d, CS%diag)
endif
@@ -410,7 +434,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
call cons_temp_to_pot_temp(tv%T(:,j,k), tv%S(:,j,k), work_3d(:,j,k), tv%eqn_of_state, EOSdom)
enddo ; enddo
if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, work_3d, CS%diag)
- if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT)
+ if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag)
! volume mean potential temperature
if (CS%id_thetaoga>0) then
thetaoga = global_volume_mean(work_3d, h, G, GV, tmp_scale=US%C_to_degC)
@@ -450,7 +474,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
endif
else
! Internal T&S variables are potential temperature & practical salinity
- if (CS%id_tob > 0) call post_data(CS%id_tob, tv%T(:,:,nz), CS%diag, mask=G%mask2dT)
+ if (CS%id_tob > 0) call post_data(CS%id_tob, tv%T(:,:,nz), CS%diag)
if (CS%id_tosq > 0) then
do k=1,nz ; do j=js,je ; do i=is,ie
work_3d(i,j,k) = tv%T(i,j,k)*tv%T(i,j,k)
@@ -486,7 +510,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
call abs_saln_to_prac_saln(tv%S(:,j,k), work_3d(:,j,k), tv%eqn_of_state, EOSdom)
enddo ; enddo
if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, work_3d, CS%diag)
- if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT)
+ if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag)
! volume mean salinity
if (CS%id_soga>0) then
soga = global_volume_mean(work_3d, h, G, GV, tmp_scale=US%S_to_ppt)
@@ -526,7 +550,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, &
endif
else
! Internal T&S variables are potential temperature & practical salinity
- if (CS%id_sob > 0) call post_data(CS%id_sob, tv%S(:,:,nz), CS%diag, mask=G%mask2dT)
+ if (CS%id_sob > 0) call post_data(CS%id_sob, tv%S(:,:,nz), CS%diag)
if (CS%id_sosq > 0) then
do k=1,nz ; do j=js,je ; do i=is,ie
work_3d(i,j,k) = tv%S(i,j,k)*tv%S(i,j,k)
@@ -891,7 +915,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS)
!! as setting the surface pressure to 0.
type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a
!! previous call to diagnostics_init.
-
+ ! Local variables
real, dimension(SZI_(G),SZJ_(G)) :: &
z_top, & ! Height of the top of a layer or the ocean [Z ~> m].
z_bot, & ! Height of the bottom of a layer (for id_mass) or the
@@ -903,12 +927,19 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS)
btm_pres,&! The pressure at the ocean bottom, or CMIP variable 'pbo'.
! This is the column mass multiplied by gravity plus the pressure
! at the ocean surface [R L2 T-2 ~> Pa].
- dpress, & ! Change in hydrostatic pressure across a layer [R L2 T-2 ~> Pa].
- tr_int ! vertical integral of a tracer times density,
+ tr_int,& ! vertical integral of a tracer times density,
! (Rho_0 in a Boussinesq model) [Conc R Z ~> Conc kg m-2].
- real :: IG_Earth ! Inverse of gravitational acceleration [T2 Z L-2 ~> s2 m-1].
+ d17,& ! Depth of 17 degC isotherm [Z ~> m]
+ d20 ! Depth of 20 degC isotherm [Z ~> m]
+ real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! Temporary array [defined at each usage]
+ real :: IG_Earth ! Inverse of gravitational acceleration [T2 Z L-2 ~> s2 m-1].
+ real :: Ttop, Tbot ! Temperature at top/bottom of cell [C ~> degC]
+ type(EPPM_CWK) :: PPM ! Class for reconstruction
+ real :: d_from_ssh(0:GV%ke) ! eta-z (Distance from surface) [Z ~> m]
+ real :: dz ! Layer thickness in Z [Z ~> m]
integer :: i, j, k, is, ie, js, je, nz
+ integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
if (CS%id_mass_wt > 0) then
@@ -936,59 +967,149 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS)
endif
if (CS%id_col_ht > 0) then
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: z_top)
call find_eta(h, tv, G, GV, US, z_top)
+ !$omp target exit data map(from: z_top)
do j=js,je ; do i=is,ie
z_bot(i,j) = z_top(i,j) + G%bathyT(i,j)
enddo ; enddo
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
+ if (CS%id_pbo > 0) then
+ call find_col_mass(h, tv, G, GV, US, mass, btm_pres, p_surf)
+ call post_data(CS%id_pbo, btm_pres, CS%diag)
+ else
+ call find_col_mass(h, tv, G, GV, US, mass)
+ endif
+ if (CS%id_col_mass > 0) call post_data(CS%id_col_mass, mass, CS%diag)
+ endif
+ if (CS%id_t20d > 0 .or. CS%id_t17d > 0) then
+ call PPM%init(GV%ke, h_neglect=0.)
+ do j=js,je ; do i=is,ie
+ ! Pre-calculate the interface depths relative to the surface
+ if (GV%Boussinesq) then
+ d_from_ssh(0) = 0.
do k=1,nz
- do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1
- z_top(i,j) = z_bot(i,j)
- z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k)
- enddo ; enddo
- call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, &
- G%HI, tv%eqn_of_state, US, dpress)
- do j=js,je ; do i=is,ie
- mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth
- enddo ; enddo
+ d_from_ssh(k) = d_from_ssh(k-1) + h(i,j,k) * GV%H_to_Z
enddo
else
- do k=1,nz ; do j=js,je ; do i=is,ie
- mass(i,j) = mass(i,j) + (GV%H_to_Z*GV%Rlay(k))*h(i,j,k)
- enddo ; enddo ; enddo
+ ! Non-Boussinesq: use pre-computed layer-average specific volumes from tv%SpV_avg,
+ ! which are more accurate than cell-center specific volumes and correctly account
+ ! for surface pressure (including under ice-shelves).
+ d_from_ssh(0) = 0.
+ do k=1,nz
+ d_from_ssh(k) = d_from_ssh(k-1) + ( h(i,j,k) * GV%H_to_RZ ) * tv%SpV_avg(i,j,k)
+ enddo
endif
+ call PPM%reconstruct(h(i,j,:), tv%T(i,j,:))
+ d17(i,j) = d_from_ssh(nz)
+ d20(i,j) = d_from_ssh(nz)
+ do k=nz,1,-1
+ Ttop = PPM%f(k, 0.)
+ Tbot = PPM%f(k, 1.)
+ if ( Tbot>Ttop ) cycle ! The cell is inverted, skip to next
+ if ( 20.=0
+ if ( Tbot<=17. .and. 17.<=Ttop ) then
+ ! The 17 degC isotherm is within the cell which is non-negatively stratified
+ d17(i,j) = d_from_ssh(k-1) + dz * PPM%x(k, 17.)
+ elseif ( Ttop<17. ) then
+ ! The 17 degC isotherm is above the top of the cell
+ d17(i,j) = d_from_ssh(k-1)
+ endif
+ if ( Tbot<=20. .and. 20.<=Ttop ) then
+ ! The 20 degC isotherm is within the cell which is non-negatively stratified
+ d20(i,j) = d_from_ssh(k-1) + dz * PPM%x(k, 20.)
+ elseif ( Ttop<20. ) then
+ ! The 20 degC isotherm is above the top of the cell
+ d20(i,j) = d_from_ssh(k-1)
+ endif
+ enddo
+ enddo ; enddo
+ call PPM%destroy()
+ if (CS%id_t17d > 0) call post_data(CS%id_t17d, d17, CS%diag)
+ if (CS%id_t20d > 0) call post_data(CS%id_t20d, d20, CS%diag)
+ endif
+
+ ! Practical salinity expressed as salt mass content
+ if (CS%id_scint > 0) then
+ EOSdom(:) = EOS_domain(G%HI)
+ if (tv%S_is_absS) then
+ do k=1,nz ; do j=js,je
+ call abs_saln_to_prac_saln(tv%S(:,j,k), tmp(:,j,k), tv%eqn_of_state, EOSdom) ! "tmp" [S ~> psu]
+ do i=is,ie
+ tmp(i,j,k) = ( GV%H_to_RZ * h(i,j,k) ) * tmp(i,j,k) ! "tmp" [R Z S ~> kg m-2]
+ enddo
+ enddo ; enddo
else
do k=1,nz ; do j=js,je ; do i=is,ie
- mass(i,j) = mass(i,j) + GV%H_to_RZ*h(i,j,k)
+ tmp(i,j,k) = ( GV%H_to_RZ * h(i,j,k) ) * tv%S(i,j,k) ! "tmp" [R Z S ~> kg m-2]
enddo ; enddo ; enddo
endif
- if (CS%id_col_mass > 0) then
- call post_data(CS%id_col_mass, mass, CS%diag)
+ call post_data(CS%id_scint, tmp, CS%diag)
+ endif
+ ! Absolute salinities expressed as salt mass content
+ if (CS%id_absscint > 0 .or. CS%id_pfscint > 0) then
+ EOSdom(:) = EOS_domain(G%HI)
+ if (tv%S_is_absS) then
+ do k=1,nz ; do j=js,je ; do i=is,ie
+ tmp(i,j,k) = ( GV%H_to_RZ * h(i,j,k) ) * tv%S(i,j,k) ! "tmp" [R Z S ~> kg m-2]
+ enddo ; enddo ; enddo
+ else
+ do k=1,nz ; do j=js,je
+ call prac_saln_to_abs_saln(tv%S(:,j,k), tmp(:,j,k), tv%eqn_of_state, EOSdom) ! "tmp" [S ~> ppt]
+ do i=is,ie
+ tmp(i,j,k) = ( GV%H_to_RZ * h(i,j,k) ) * tmp(i,j,k) ! [R Z S ~> kg m-2]
+ enddo
+ enddo ; enddo
endif
- if (CS%id_pbo > 0) then
- do j=js,je ; do i=is,ie ; btm_pres(i,j) = 0.0 ; enddo ; enddo
- ! 'pbo' is defined as the sea water pressure at the sea floor
- ! pbo = (mass * g) + p_surf
- ! where p_surf is the sea water pressure at sea water surface.
- do j=js,je ; do i=is,ie
- btm_pres(i,j) = GV%g_Earth * mass(i,j)
- if (associated(p_surf)) then
- btm_pres(i,j) = btm_pres(i,j) + p_surf(i,j)
- endif
+ if (CS%id_absscint > 0) call post_data(CS%id_absscint, tmp, CS%diag)
+ ! Based on the definitions in https://www.teos-10.org/pubs/gsw/pdf/TEOS-10_Manual.pdf
+ ! The preformed salinity, S*, is the conserved salinity used in models (page 8).
+ ! Although we appear to be labeling tv%S absolute salinity, we do not use the function
+ ! that calculates the "absolute salinity anomaly ratio" which accounts for the
+ ! geographic variations in the types of dissolved salts.
+ ! Hence, I think there is no difference between preformed and absolute salinity
+ ! for the current implementation of TEOS-10 and so we post the same data for
+ ! absscint and pfscint. -AJA
+ if (CS%id_pfscint > 0) call post_data(CS%id_pfscint, tmp, CS%diag)
+ endif
+ ! Potential temperature expressed as heat content
+ if (CS%id_phcint > 0) then
+ EOSdom(:) = EOS_domain(G%HI)
+ if (tv%T_is_conT) then
+ do k=1,nz ; do j=js,je
+ call cons_temp_to_pot_temp(tv%T(:,j,k), tv%S(:,j,k), tmp(:,j,k), tv%eqn_of_state, EOSdom) ! "tmp" [C ~> degC]
+ do i=is,ie
+ tmp(i,j,k) = ( ( tv%C_p * GV%H_to_RZ ) * h(i,j,k) ) * tmp(i,j,k) ! "tmp" [ Q R Z ~> J m-2]
+ enddo
+ enddo ; enddo
+ else
+ do k=1,nz ; do j=js,je ; do i=is,ie
+ tmp(i,j,k) = ( ( tv%C_p * GV%H_to_RZ ) * h(i,j,k) ) * tv%T(i,j,k) ! "tmp" [Q R Z ~> J m-2]
+ enddo ; enddo ; enddo
+ endif
+ call post_data(CS%id_phcint, tmp, CS%diag)
+ endif
+ ! Conservative temperature expressed as heat content
+ if (CS%id_chcint > 0) then
+ EOSdom(:) = EOS_domain(G%HI)
+ if (tv%T_is_conT) then
+ do k=1,nz ; do j=js,je ; do i=is,ie
+ tmp(i,j,k) = ( ( tv%C_p * GV%H_to_RZ ) * h(i,j,k) ) * tv%T(i,j,k) ! "tmp" [Q R Z ~> J m-2]
+ enddo ; enddo ; enddo
+ else
+ do k=1,nz ; do j=js,je
+ call pot_temp_to_cons_temp(tv%T(:,j,k), tv%S(:,j,k), tmp(:,j,k), tv%eqn_of_state, EOSdom) ! "tmp" [C ~> degC]
+ do i=is,ie
+ tmp(i,j,k) = ( ( tv%C_p * GV%H_to_RZ ) * h(i,j,k) ) * tmp(i,j,k) ! "tmp" [ Q R Z ~> J m-2]
+ enddo
enddo ; enddo
- call post_data(CS%id_pbo, btm_pres, CS%diag)
endif
+ call post_data(CS%id_chcint, tmp, CS%diag)
endif
end subroutine calculate_vertical_integrals
@@ -1490,20 +1611,20 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh)
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
if (IDs%id_ssh > 0) &
- call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT)
+ call post_data(IDs%id_ssh, ssh, diag)
if (IDs%id_ssu > 0) &
- call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu)
+ call post_data(IDs%id_ssu, sfc_state%u, diag)
if (IDs%id_ssv > 0) &
- call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv)
+ call post_data(IDs%id_ssv, sfc_state%v, diag)
if (IDs%id_speed > 0) then
do j=js,je ; do i=is,ie
speed(i,j) = sqrt(0.5*((sfc_state%u(I-1,j)**2) + (sfc_state%u(I,j)**2)) + &
0.5*((sfc_state%v(i,J-1)**2) + (sfc_state%v(i,J)**2)))
enddo ; enddo
- call post_data(IDs%id_speed, speed, diag, mask=G%mask2dT)
+ call post_data(IDs%id_speed, speed, diag)
endif
if (IDs%id_ssu_east > 0 .or. IDs%id_ssv_north > 0) then
@@ -1513,8 +1634,8 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh)
ssv_north(i,j) = ((0.5*(sfc_state%v(i,J-1) + sfc_state%v(i,J))) * G%cos_rot(i,j)) - &
((0.5*(sfc_state%u(I-1,j) + sfc_state%u(I,j))) * G%sin_rot(i,j))
enddo ; enddo
- if (IDs%id_ssu_east > 0 ) call post_data(IDs%id_ssu_east, ssu_east, diag, mask=G%mask2dT)
- if (IDs%id_ssv_north > 0 ) call post_data(IDs%id_ssv_north, ssv_north, diag, mask=G%mask2dT)
+ if (IDs%id_ssu_east > 0 ) call post_data(IDs%id_ssu_east, ssu_east, diag)
+ if (IDs%id_ssv_north > 0 ) call post_data(IDs%id_ssv_north, ssv_north, diag)
endif
end subroutine post_surface_dyn_diags
@@ -1562,12 +1683,12 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv
do j=js,je ; do i=is,ie
zos(i,j) = ssh_ibc(i,j) - G%mask2dT(i,j)*zos_area_mean
enddo ; enddo
- if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT)
+ if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag)
if (IDs%id_zossq > 0) then
do j=js,je ; do i=is,ie
work_2d(i,j) = zos(i,j)*zos(i,j)
enddo ; enddo
- call post_data(IDs%id_zossq, work_2d, diag, mask=G%mask2dT)
+ call post_data(IDs%id_zossq, work_2d, diag)
endif
endif
@@ -1588,7 +1709,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv
do j=js,je ; do i=is,ie
work_2d(i,j) = tv%frazil(i,j) * I_time_int
enddo ; enddo
- call post_data(IDs%id_fraz, work_2d, diag, mask=G%mask2dT)
+ call post_data(IDs%id_fraz, work_2d, diag)
endif
! post time-averaged salt deficit
@@ -1596,7 +1717,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv
do j=js,je ; do i=is,ie
work_2d(i,j) = tv%salt_deficit(i,j) * I_time_int
enddo ; enddo
- call post_data(IDs%id_salt_deficit, work_2d, diag, mask=G%mask2dT)
+ call post_data(IDs%id_salt_deficit, work_2d, diag)
endif
! post temperature of P-E+R
@@ -1604,7 +1725,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv
do j=js,je ; do i=is,ie
work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int)
enddo ; enddo
- call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT)
+ call post_data(IDs%id_Heat_PmE, work_2d, diag)
endif
! post geothermal heating or internal heat source/sinks
@@ -1612,50 +1733,50 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv
do j=js,je ; do i=is,ie
work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int)
enddo ; enddo
- call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT)
+ call post_data(IDs%id_intern_heat, work_2d, diag)
endif
if (tv%T_is_conT) then
! Internal T&S variables are conservative temperature & absolute salinity
- if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT)
+ if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag)
! Use TEOS-10 function calls convert T&S diagnostics from conservative temp
! to potential temperature.
EOSdom(:) = EOS_domain(G%HI)
do j=js,je
call cons_temp_to_pot_temp(sfc_state%SST(:,j), sfc_state%SSS(:,j), work_2d(:,j), tv%eqn_of_state, EOSdom)
enddo
- if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag, mask=G%mask2dT)
+ if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag)
else
! Internal T&S variables are potential temperature & practical salinity
- if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT)
+ if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag)
endif
if (tv%S_is_absS) then
! Internal T&S variables are conservative temperature & absolute salinity
- if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT)
+ if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag)
! Use TEOS-10 function calls convert T&S diagnostics from absolute salinity
! to practical salinity.
EOSdom(:) = EOS_domain(G%HI)
do j=js,je
call abs_saln_to_prac_saln(sfc_state%SSS(:,j), work_2d(:,j), tv%eqn_of_state, EOSdom)
enddo
- if (IDs%id_sss > 0) call post_data(IDs%id_sss, work_2d, diag, mask=G%mask2dT)
+ if (IDs%id_sss > 0) call post_data(IDs%id_sss, work_2d, diag)
else
! Internal T&S variables are potential temperature & practical salinity
- if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT)
+ if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag)
endif
if (IDs%id_sst_sq > 0) then
do j=js,je ; do i=is,ie
work_2d(i,j) = sfc_state%SST(i,j)*sfc_state%SST(i,j)
enddo ; enddo
- call post_data(IDs%id_sst_sq, work_2d, diag, mask=G%mask2dT)
+ call post_data(IDs%id_sst_sq, work_2d, diag)
endif
if (IDs%id_sss_sq > 0) then
do j=js,je ; do i=is,ie
work_2d(i,j) = sfc_state%SSS(i,j)*sfc_state%SSS(i,j)
enddo ; enddo
- call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT)
+ call post_data(IDs%id_sss_sq, work_2d, diag)
endif
call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag))
@@ -1826,6 +1947,12 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag
"If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//&
"See REMAPPING_USE_OM4_SUBCELLS for details. "//&
"We recommend setting this option to false.", default=om4_remap_via_sub_cells)
+ call get_param(param_file, mdl, "ACCURATE_NONBOUS_THICK_CELLO", CS%accurate_thick_cello, &
+ "If true, use the same careful integrals to find the diagnosed non-Boussinesq "//&
+ "layer thicknesses as are used to find the free surface height, instead of "//&
+ "using an approximate thickness based on division by the mid-layer density.", &
+ default=.false., do_not_log=GV%Boussinesq)
+ if (GV%Boussinesq) CS%accurate_thick_cello = .false.
call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
"This sets the default value for the various _ANSWER_DATE parameters.", &
default=99991231)
@@ -1931,6 +2058,51 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag
CS%id_abssosga = register_scalar_field('ocean_model', 'ssabss_global', Time, diag, &
long_name='Global Area Average Sea Surface Absolute Salinity', &
units='psu', conversion=US%S_to_ppt, standard_name='sea_surface_absolute_salinity')
+
+ ! 2d column integrated
+ CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, &
+ 'Density weighted column integrated potential temperature', &
+ 'degC kg m-2', conversion=US%C_to_degC*US%RZ_to_kg_m2, &
+ cmor_field_name='opottempmint', &
+ cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature', &
+ cmor_standard_name='Depth integrated density times potential temperature')
+ CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, &
+ 'Density weighted column integrated salinity', &
+ 'psu kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, v_extensive=.true., &
+ cmor_field_name='somint', &
+ cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity', &
+ cmor_standard_name='Depth integrated density times salinity')
+
+ ! 3d vertically integrated
+ CS%id_absscint = register_diag_field('ocean_model', 'absscint', diag%axesTL, Time, &
+ 'Integral wrt depth of seawater absolute salinity expressed as salt mass content', &
+ units='kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, v_extensive=.true., &
+ standard_name='integral_wrt_depth_of_sea_water_absolute_salinity_expressed_as_salt_mass_content')
+ CS%id_pfscint = register_diag_field('ocean_model', 'pfscint', diag%axesTL, Time, &
+ ' Integral wrt depth of seawater preformed salinity expressed as salt mass content', &
+ units='kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, v_extensive=.true., &
+ standard_name='integral_wrt_depth_of_sea_water_preformed_salinity_expressed_as_salt_mass_content')
+ CS%id_scint = register_diag_field('ocean_model', 'scint', diag%axesTL, Time, &
+ 'Integral wrt depth of seawater practical salinity expressed as salt mass content', &
+ units='kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, v_extensive=.true., &
+ standard_name='integral_wrt_depth_of_sea_water_practical_salinity_expressed_as_salt_mass_content')
+ CS%id_chcint = register_diag_field('ocean_model', 'chcint', diag%axesTL, Time, &
+ 'Depth Integrated Seawater Conservative Temperature Expressed As Heat Content', &
+ units='J m-2', conversion=US%Q_to_J_kg*US%RZ_to_kg_m2, v_extensive=.true., &
+ standard_name='integral_wrt_depth_of_sea_water_conservative_temperature_expressed_as_heat_content')
+ CS%id_phcint = register_diag_field('ocean_model', 'phcint', diag%axesTL, Time, &
+ 'Integrated Ocean Heat Content from Potential Temperature', &
+ units='J m-2', conversion=US%Q_to_J_kg*US%RZ_to_kg_m2, v_extensive=.true., &
+ standard_name='integral_wrt_depth_of_sea_water_potential_temperature_expressed_as_heat_content')
+
+ CS%id_t20d = register_diag_field('ocean_model', 't20d', diag%axesT1, Time, &
+ 'Depth of 20 degree Celsius Isotherm', &
+ units='m', conversion=US%Z_to_m, &
+ standard_name='depth_of_isosurface_of_sea_water_potential_temperature')
+ CS%id_t17d = register_diag_field('ocean_model', 't17d', diag%axesT1, Time, &
+ 'Depth of 17 degree Celsius Isotherm', &
+ units='m', conversion=US%Z_to_m, &
+ standard_name='depth_of_isosurface_of_sea_water_potential_temperature')
endif
CS%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, &
@@ -2117,22 +2289,6 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag
CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, &
'The column mass for calculating mass-weighted average properties', 'kg m-2', conversion=US%RZ_to_kg_m2)
- if (use_temperature) then
- CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, &
- 'Density weighted column integrated potential temperature', &
- 'degC kg m-2', conversion=US%C_to_degC*US%RZ_to_kg_m2, &
- cmor_field_name='opottempmint', &
- cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature', &
- cmor_standard_name='Depth integrated density times potential temperature')
-
- CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, &
- 'Density weighted column integrated salinity', &
- 'psu kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, &
- cmor_field_name='somint', &
- cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity', &
- cmor_standard_name='Depth integrated density times salinity')
- endif
-
CS%id_col_mass = register_diag_field('ocean_model', 'col_mass', diag%axesT1, Time, &
'The column integrated in situ density', 'kg m-2', conversion=US%RZ_to_kg_m2)
@@ -2364,6 +2520,7 @@ subroutine write_static_fields(G, GV, US, tv, diag)
x_cell_method='mean', y_cell_method='mean', area_cell_method='mean')
if (id > 0) then
do j=G%jsc,G%jec ; do i=G%isc,G%iec ; work_2d(i,j) = G%bathyT(i,j)+G%Z_ref ; enddo ; enddo
+ ! A mask argument is required here because masks are not applied to static fields by default.
call post_data(id, work_2d, diag, .true., mask=G%mask2dT)
endif
diff --git a/src/diagnostics/MOM_harmonic_analysis.F90 b/src/diagnostics/MOM_harmonic_analysis.F90
index f2585d510a..8f0eb9c87e 100644
--- a/src/diagnostics/MOM_harmonic_analysis.F90
+++ b/src/diagnostics/MOM_harmonic_analysis.F90
@@ -1,30 +1,35 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Inline harmonic analysis (conventional)
module MOM_harmonic_analysis
-use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, get_date, increment_date, &
- operator(+), operator(-), operator(<), operator(>), operator(>=)
+use MOM_time_manager, only : time_type, real_to_time, time_to_real, time_minus_signed
+use MOM_time_manager, only : set_date, get_date, increment_date
+use MOM_time_manager, only : operator(+), operator(-), operator(<), operator(>), operator(>=)
use MOM_grid, only : ocean_grid_type
use MOM_unit_scaling, only : unit_scale_type
use MOM_file_parser, only : param_file_type, get_param
-use MOM_io, only : file_exists, open_ASCII_file, READONLY_FILE, close_file, &
- MOM_infra_file, vardesc, MOM_field, &
- var_desc, create_MOM_file, SINGLE_FILE, MOM_write_field
+use MOM_io, only : file_exists, open_ASCII_file, READONLY_FILE, close_file
+use MOM_io, only : MOM_infra_file, vardesc, MOM_field
+use MOM_io, only : var_desc, create_MOM_file, SINGLE_FILE, MOM_write_field
use MOM_error_handler, only : MOM_mesg, MOM_error, NOTE
+use MOM_tidal_forcing, only : astro_longitudes, astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency
implicit none ; private
-public HA_init, HA_register, HA_accum_FtF, HA_accum_FtSSH
+public HA_init, HA_accum
#include
-integer, parameter :: MAX_CONSTITUENTS = 10 !< The maximum number of tidal constituents
-
!> The private control structure for storing the HA info of a particular field
type, private :: HA_type
character(len=16) :: key = "none" !< Name of the field of which harmonic analysis is to be performed
character(len=1) :: grid !< The grid on which the field is defined ('h', 'q', 'u', or 'v')
real :: old_time = -1.0 !< The time of the previous accumulating step [T ~> s]
real, allocatable :: ref(:,:) !< The initial field in arbitrary units [A]
+ real, allocatable :: FtF(:,:) !< Accumulator of (F' * F) [nondim]
real, allocatable :: FtSSH(:,:,:) !< Accumulator of (F' * SSH_in) in arbitrary units [A]
!>@{ Lower and upper bounds of input data
integer :: is, ie, js, je
@@ -44,15 +49,14 @@ module MOM_harmonic_analysis
time_start, & !< Start time of harmonic analysis
time_end, & !< End time of harmonic analysis
time_ref !< Reference time (t = 0) used to calculate tidal forcing
- real, dimension(MAX_CONSTITUENTS) :: &
+ real, allocatable, dimension(:) :: &
freq, & !< The frequency of a tidal constituent [T-1 ~> s-1]
phase0, & !< The phase of a tidal constituent at time 0 [rad]
tide_fn, & !< Amplitude modulation of tides by nodal cycle [nondim].
tide_un !< Phase modulation of tides by nodal cycle [rad].
- real, allocatable :: FtF(:,:) !< Accumulator of (F' * F) for all fields [nondim]
integer :: nc !< The number of tidal constituents in use
integer :: length !< Number of fields of which harmonic analysis is to be performed
- character(len=16) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent
+ character(len=4), allocatable, dimension(:) :: const_name !< The name of each constituent
character(len=255) :: path !< Path to directory where output will be written
type(unit_scale_type) :: US !< A dimensional unit scaling type
type(HA_node), pointer :: list => NULL() !< A linked list for storing the HA info of different fields
@@ -62,27 +66,144 @@ module MOM_harmonic_analysis
!> This subroutine sets static variables used by this module and initializes CS%list.
!! THIS MUST BE CALLED AT THE END OF tidal_forcing_init.
-subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, tide_fn, tide_un, CS)
+subroutine HA_init(Time, US, param_file, nc, CS)
type(time_type), intent(in) :: Time !< The current model time
- type(time_type), intent(in) :: time_ref !< Reference time (t = 0) used to calculate tidal forcing
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters
- real, intent(in) :: freq(MAX_CONSTITUENTS) !< The frequency of a tidal constituent [T-1 ~> s-1]
- real, intent(in) :: phase0(MAX_CONSTITUENTS) !< The phase of a tidal constituent at time 0 [rad]
- real, intent(in) :: tide_fn(MAX_CONSTITUENTS) !< Amplitude modulation of tides by nodal cycle [nondim].
- real, intent(in) :: tide_un(MAX_CONSTITUENTS) !< Phase modulation of tides by nodal cycle [rad].
integer, intent(in) :: nc !< The number of tidal constituents in use
- character(len=16), intent(in) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent
type(harmonic_analysis_CS), intent(out) :: CS !< Control structure of the MOM_harmonic_analysis module
! Local variables
+ logical :: tides !< True if tidal forcing module is enabled
+ logical :: use_eq_phase !< If true, tidal forcing is phase-shifted to match
+ !! equilibrium tide. Set to false if providing tidal phases
+ !! that have already been shifted by the
+ !! astronomical/equilibrium argument
+ logical :: add_nodal_terms !< If true, insert terms for the 18.6 year modulation when
+ !! calculating tidal forcing.
+ integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing (year, month, day)
+ integer, dimension(3) :: nodal_ref_date !< Date to calculate nodal modulation for (year, month, day)
+ type(time_type) :: nodal_time !< Model time to calculate nodal modulation for.
+ type(astro_longitudes) :: tidal_longitudes !< Astronomical longitudes used to calculate
+ !! tidal phases at t = 0.
+ type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing
+ character(len=50) :: const_name !< Names of all tidal constituents to be harmonically analyzed
+ integer :: c
+
type(HA_type) :: ha1 !< A temporary, null field used for initializing CS%list
real :: HA_start_time !< Start time of harmonic analysis [T ~> s]
real :: HA_end_time !< End time of harmonic analysis [T ~> s]
+ logical :: HA_ssh, HA_ubt, HA_vbt
character(len=40) :: mdl="MOM_harmonic_analysis" !< This module's name
character(len=255) :: mesg
integer :: year, month, day, hour, minute, second
+ call get_param(param_file, mdl, "TIDES", tides, &
+ "If true, apply tidal momentum forcing.", default=.false., do_not_log=.true.)
+ call get_param(param_file, mdl, "TIDE_USE_EQ_PHASE", use_eq_phase, &
+ "If true, add the equilibrium phase argument to the specified tidal phases.", &
+ old_name="OBC_TIDE_ADD_EQ_PHASE", default=.false., do_not_log=tides)
+ call get_param(param_file, mdl, "TIDE_ADD_NODAL", add_nodal_terms, &
+ "If true, include 18.6 year nodal modulation in the boundary tidal forcing.", &
+ old_name="OBC_TIDE_ADD_NODAL", default=.false., do_not_log=tides)
+ call get_param(param_file, mdl, "TIDE_REF_DATE", tide_ref_date, &
+ "Reference date to use for tidal calculations and equilibrium phase.", &
+ old_name="OBC_TIDE_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides)
+ call get_param(param_file, mdl, "TIDE_NODAL_REF_DATE", nodal_ref_date, &
+ "Fixed reference date to use for nodal modulation.", &
+ old_name="OBC_TIDE_NODAL_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides)
+ call get_param(param_file, mdl, "HA_CONSTITUENTS", const_name, &
+ "Names of tidal constituents to be harmonically analyzed. "//&
+ "They don't have to be the same as those used in MOM_tidal_forcing.", &
+ fail_if_missing=.true.)
+
+ if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0.
+ CS%time_ref = set_date(1, 1, 1, 0, 0, 0)
+ else
+ if (.not. use_eq_phase) then
+ ! Using a reference date but not using phase relative to equilibrium.
+ ! This makes sense as long as either phases are overridden, or
+ ! correctly simulating tidal phases is not desired.
+ call MOM_mesg('Tidal phases will *not* be corrected with equilibrium arguments.')
+ endif
+ CS%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0)
+ endif
+
+ ! Initialize reference time for tides and find relevant lunar and solar
+ ! longitudes at the reference time.
+ if (use_eq_phase) call astro_longitudes_init(CS%time_ref, tidal_longitudes)
+
+ ! If the nodal correction is based on a different time, initialize that.
+ ! Otherwise, it can use N from the time reference.
+ if (add_nodal_terms) then
+ if (sum(nodal_ref_date) /= 0) then
+ ! A reference date was provided for the nodal correction
+ nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3))
+ call astro_longitudes_init(nodal_time, nodal_longitudes)
+ elseif (use_eq_phase) then
+ ! Astronomical longitudes were already calculated for use in equilibrium phases,
+ ! so use nodal longitude from that.
+ nodal_longitudes = tidal_longitudes
+ else
+ ! Tidal reference time is a required parameter, so calculate the longitudes from that.
+ call astro_longitudes_init(CS%time_ref, nodal_longitudes)
+ endif
+ endif
+
+ allocate(CS%const_name(nc))
+ allocate(CS%freq(nc))
+ allocate(CS%phase0(nc))
+ allocate(CS%tide_fn(nc))
+ allocate(CS%tide_un(nc))
+
+ ! Tidal constituents for harmonic analysis can be different from those defined in MOM_tidal_forcing
+ read(const_name, *) CS%const_name
+
+ ! For major tidal constituents, tidal parameters defined in MOM_tidal_forcing will be used.
+ ! For those not available in MOM_tidal_forcing, parameters needs to be defined in MOM_input.
+ do c=1,nc
+ call get_param(param_file, mdl, "HA_"//trim(CS%const_name(c))//"_FREQ", &
+ CS%freq(c), "Frequency of the "//trim(CS%const_name(c))//&
+ " constituent. This is used if USE_HA is true and "//trim(CS%const_name(c))//&
+ " is in HA_CONSTITUENTS.", units="rad s-1", scale=US%T_to_s, default=0.0)
+ if (CS%freq(c)<=0.0) then
+ select case (trim(CS%const_name(c)))
+ case ('M4')
+ CS%freq(c) = tidal_frequency('M2') * 2
+ case ('M6')
+ CS%freq(c) = tidal_frequency('M2') * 3
+ case ('M8')
+ CS%freq(c) = tidal_frequency('M2') * 4
+ case ('S4')
+ CS%freq(c) = tidal_frequency('S2') * 2
+ case ('S6')
+ CS%freq(c) = tidal_frequency('S2') * 3
+ case ('MK3')
+ CS%freq(c) = tidal_frequency('M2') + tidal_frequency('K1')
+ case ('MS4')
+ CS%freq(c) = tidal_frequency('M2') + tidal_frequency('S2')
+ case ('MN4')
+ CS%freq(c) = tidal_frequency('M2') + tidal_frequency('N2')
+ case default
+ CS%freq(c) = tidal_frequency(trim(CS%const_name(c)))
+ end select
+ endif
+
+ call get_param(param_file, mdl, "HA_"//trim(CS%const_name(c))//"_PHASE_T0", CS%phase0(c), &
+ "Phase of the "//trim(CS%const_name(c))//" tidal constituent at time 0. "//&
+ "This is only used if USE_HA is true and "//trim(CS%const_name(c))// &
+ " is in HA_CONSTITUENTS.", units="radians", default=0.0)
+ if (use_eq_phase) CS%phase0(c) = eq_phase(trim(CS%const_name(c)), tidal_longitudes)
+
+ ! Nodal modulation should be turned off for tidal constituents not available in MOM_tidal_forcing
+ if (add_nodal_terms) then
+ call nodal_fu(trim(trim(CS%const_name(c))), nodal_longitudes%N, CS%tide_fn(c), CS%tide_un(c))
+ else
+ CS%tide_fn(c) = 1.0
+ CS%tide_un(c) = 0.0
+ endif
+ enddo
+
! Determine CS%time_start and CS%time_end
call get_param(param_file, mdl, "HA_START_TIME", HA_start_time, &
"Start time of harmonic analysis, in units of days after "//&
@@ -118,8 +239,8 @@ subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name,
if (HA_start_time <= 0.0) HA_start_time = 0.0
endif
- CS%time_start = Time + real_to_time(US%T_to_s * HA_start_time)
- CS%time_end = Time + real_to_time(US%T_to_s * HA_end_time)
+ CS%time_start = Time + real_to_time(HA_start_time, unscale=US%T_to_s)
+ CS%time_end = Time + real_to_time(HA_end_time, unscale=US%T_to_s)
call get_date(Time, year, month, day, hour, minute, second)
write(mesg,*) "MOM_harmonic_analysis: run segment starts on ", year, month, day, hour, minute, second
@@ -136,23 +257,26 @@ subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name,
"Path to output files for runtime harmonic analysis.", default="./")
! Populate some parameters of the control structure
- CS%time_ref = time_ref
- CS%freq = freq
- CS%phase0 = phase0
- CS%tide_fn = tide_fn
- CS%tide_un = tide_un
CS%nc = nc
- CS%const_name = const_name
CS%length = 0
CS%US = US
- allocate(CS%FtF(2*nc+1,2*nc+1), source=0.0)
-
! Initialize CS%list
allocate(CS%list)
CS%list%this = ha1
nullify(CS%list%next)
+ ! Register variables/fields to be analyzed
+ call get_param(param_file, mdl, "HA_SSH", HA_ssh, &
+ "If true, perform harmonic analysis of sea serface height.", default=.false.)
+ if (HA_ssh) call HA_register('ssh', 'h', CS)
+ call get_param(param_file, mdl, "HA_UBT", HA_ubt, &
+ "If true, perform harmonic analysis of zonal barotropic velocity.", default=.false.)
+ if (HA_ubt) call HA_register('ubt', 'u', CS)
+ call get_param(param_file, mdl, "HA_VBT", HA_vbt, &
+ "If true, perform harmonic analysis of meridional barotropic velocity.", default=.false.)
+ if (HA_vbt) call HA_register('vbt', 'v', CS)
+
end subroutine HA_init
!> This subroutine registers each of the fields on which HA is to be performed.
@@ -177,60 +301,11 @@ subroutine HA_register(key, grid, CS)
end subroutine HA_register
-!> This subroutine accumulates the temporal basis functions in FtF.
-!! The tidal constituents are those used in MOM_tidal_forcing, plus the mean (of zero frequency).
-!! Only the main diagonal and entries below it are calculated, which are needed for Cholesky decomposition.
-subroutine HA_accum_FtF(Time, CS)
- type(time_type), intent(in) :: Time !< The current model time
- type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module
-
- ! Local variables
- real :: now !< The relative time compared with tidal reference [T ~> s]
- real :: cosomegat, sinomegat, ccosomegat, ssinomegat !< The components of the phase [nondim]
- integer :: nc, c, icos, isin, cc, iccos, issin
-
- ! Exit the accumulator in the following cases
- if (.not. CS%HAready) return
- if (CS%length == 0) return
- if (Time < CS%time_start) return
- if (Time > CS%time_end) return
-
- nc = CS%nc
- now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref)
-
- !< First entry, corresponding to the zero frequency constituent (mean)
- CS%FtF(1,1) = CS%FtF(1,1) + 1.0
-
- do c=1,nc
- icos = 2*c
- isin = 2*c+1
- cosomegat = CS%tide_fn(c) * cos(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c)))
- sinomegat = CS%tide_fn(c) * sin(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c)))
-
- ! First column, corresponding to the zero frequency constituent (mean)
- CS%FtF(icos,1) = CS%FtF(icos,1) + cosomegat
- CS%FtF(isin,1) = CS%FtF(isin,1) + sinomegat
-
- do cc=1,c
- iccos = 2*cc
- issin = 2*cc+1
- ccosomegat = CS%tide_fn(cc) * cos(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc)))
- ssinomegat = CS%tide_fn(cc) * sin(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc)))
-
- ! Interior of the matrix, corresponding to the products of cosine and sine terms
- CS%FtF(icos,iccos) = CS%FtF(icos,iccos) + cosomegat * ccosomegat
- CS%FtF(icos,issin) = CS%FtF(icos,issin) + cosomegat * ssinomegat
- CS%FtF(isin,iccos) = CS%FtF(isin,iccos) + sinomegat * ccosomegat
- CS%FtF(isin,issin) = CS%FtF(isin,issin) + sinomegat * ssinomegat
- enddo ! cc=1,c
- enddo ! c=1,nc
-
-end subroutine HA_accum_FtF
-
-!> This subroutine accumulates the temporal basis functions in FtSSH and then calls HA_write to compute
+!> This subroutine accumulates the temporal basis functions in FtF and FtSSH and then calls HA_write to compute
!! harmonic constants and write results. The tidal constituents are those used in MOM_tidal_forcing, plus the
-!! mean (of zero frequency).
-subroutine HA_accum_FtSSH(key, data, Time, G, CS)
+!! mean (of zero frequency). For FtF, only the main diagonal and entries below it are calculated, which are needed
+!! for Cholesky decomposition.
+subroutine HA_accum(key, data, Time, G, CS)
character(len=*), intent(in) :: key !< Name of the current field
real, dimension(:,:), intent(in) :: data !< Input data of which harmonic analysis is to be performed [A]
type(time_type), intent(in) :: Time !< The current model time
@@ -242,8 +317,8 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS)
type(HA_node), pointer :: tmp
real :: now !< The relative time compared with the tidal reference [T ~> s]
real :: dt !< The current time step size of the accumulator [T ~> s]
- real :: cosomegat, sinomegat !< The components of the phase [nondim]
- integer :: nc, i, j, k, c, icos, isin, is, ie, js, je
+ real :: cosomegat, sinomegat, ccosomegat, ssinomegat !< The components of the phase [nondim]
+ integer :: nc, i, j, k, c, cc, icos, isin, iccos, issin, is, ie, js, je
character(len=128) :: mesg
! Exit the accumulator in the following cases
@@ -262,9 +337,9 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS)
enddo
nc = CS%nc
- now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref)
+ now = time_minus_signed(Time, CS%time_ref, scale=CS%US%s_to_T)
- ! Additional processing at the initial accumulating step
+ !!! Additional processing at the initial accumulating step !!!
if (ha1%old_time < 0.0) then
ha1%old_time = now
@@ -278,6 +353,7 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS)
ha1%je = UBOUND(data,2) ; je = ha1%je
allocate(ha1%ref(is:ie,js:je), source=0.0)
+ allocate(ha1%FtF(2*nc+1,2*nc+1), source=0.0)
allocate(ha1%FtSSH(is:ie,js:je,2*nc+1), source=0.0)
ha1%ref(:,:) = data(:,:)
endif
@@ -287,6 +363,35 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS)
is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je
+ !!! Accumulator of FtF !!!
+ !< First entry, corresponding to the zero frequency constituent (mean)
+ ha1%FtF(1,1) = ha1%FtF(1,1) + 1.0
+
+ do c=1,nc
+ icos = 2*c
+ isin = 2*c+1
+ cosomegat = CS%tide_fn(c) * cos(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c)))
+ sinomegat = CS%tide_fn(c) * sin(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c)))
+
+ ! First column, corresponding to the zero frequency constituent (mean)
+ ha1%FtF(icos,1) = ha1%FtF(icos,1) + cosomegat
+ ha1%FtF(isin,1) = ha1%FtF(isin,1) + sinomegat
+
+ do cc=1,c
+ iccos = 2*cc
+ issin = 2*cc+1
+ ccosomegat = CS%tide_fn(cc) * cos(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc)))
+ ssinomegat = CS%tide_fn(cc) * sin(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc)))
+
+ ! Interior of the matrix, corresponding to the products of cosine and sine terms
+ ha1%FtF(icos,iccos) = ha1%FtF(icos,iccos) + cosomegat * ccosomegat
+ ha1%FtF(icos,issin) = ha1%FtF(icos,issin) + cosomegat * ssinomegat
+ ha1%FtF(isin,iccos) = ha1%FtF(isin,iccos) + sinomegat * ccosomegat
+ ha1%FtF(isin,issin) = ha1%FtF(isin,issin) + sinomegat * ssinomegat
+ enddo ! cc=1,c
+ enddo ! c=1,nc
+
+ !!! Accumulator of FtSSH !!!
!< First entry, corresponding to the zero frequency constituent (mean)
do j=js,je ; do i=is,ie
ha1%FtSSH(i,j,1) = ha1%FtSSH(i,j,1) + (data(i,j) - ha1%ref(i,j))
@@ -304,9 +409,10 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS)
enddo ; enddo
enddo ! c=1,nc
- ! Compute harmonic constants and write output as Time approaches CS%time_end
- ! This guarantees that HA_write will be called before Time becomes larger than CS%time_end
- if (time_type_to_real(CS%time_end - Time) <= dt) then
+ !!! Compute harmonic constants and write output as Time approaches CS%time_end !!!
+ ! This guarantees that HA_write will be called before Time becomes larger than CS%time_end.
+ ! Result of subtracting time types is always >= 0, which is acceptable here.
+ if (time_to_real(CS%time_end - Time, scale=CS%US%s_to_T) <= dt) then
call HA_write(ha1, Time, G, CS)
write(mesg,*) "MOM_harmonic_analysis: harmonic analysis done, key = ", trim(ha1%key)
@@ -318,7 +424,7 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS)
deallocate(ha1%FtSSH)
endif
-end subroutine HA_accum_FtSSH
+end subroutine HA_accum
!> This subroutine computes the harmonic constants and write output for the current field
subroutine HA_write(ha1, Time, G, CS)
@@ -342,7 +448,7 @@ subroutine HA_write(ha1, Time, G, CS)
allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0)
! Compute the harmonic coefficients
- call HA_solver(ha1, nc, CS%FtF, FtSSHw)
+ call HA_solver(ha1, nc, ha1%FtF, FtSSHw)
! Output file name
call get_date(Time, year, month, day, hour, minute, second)
@@ -448,6 +554,17 @@ end subroutine HA_solver
!> \namespace harmonic_analysis
!!
+!! Major revision (August, 2025)
+!!
+!! This module is now independent of MOM_tidal_forcing, providing more flexibility for performing harmonic analyses
+!! on tidal constituents not available in MOM_tidal_forcing (e.g., MK3, M4), with the following conditions:
+!! 1) For tidal constituents not available in MOM_tidal_forcing, the frequencies and equilibrium phases (if used)
+!! must be specified manually in MOM_input.
+!! 2) If any tidal constituents not available in MOM_tidal_forcing are used, the nodal modulation cannot be added.
+!! Or, if nodal modulation is added, then harmonic analysis can only be performed on major tidal constituents.
+!!
+!! Original version (April, 2024)
+!!
!! This module computes the harmonic constants which can be used to reconstruct the tidal elevation (or other
!! fields) through SSH = F * x, where F is an nt-by-2*nc matrix (nt is the number of time steps and nc is the
!! number of tidal constituents) containing the cosine/sine functions for each frequency evaluated at each time
@@ -461,7 +578,7 @@ end subroutine HA_solver
!! running and stored in the arrays FtF and FtSSH, respectively. The FtF matrix is inverted as needed before
!! computing and writing out the harmonic constants.
!!
-!! Ed Zaron and William Xu (chengzhu.xu@oregonstate.edu), April 2024.
+!! Ed Zaron and William Xu (chengzhu.xu@oregonstate.edu)
end module MOM_harmonic_analysis
diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90
index ddfe0452a0..77b7b863ce 100644
--- a/src/diagnostics/MOM_obsolete_diagnostics.F90
+++ b/src/diagnostics/MOM_obsolete_diagnostics.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides a mechanism for recording diagnostic variables that are no longer
!! valid, along with their replacement name if appropriate.
module MOM_obsolete_diagnostics
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl, found_in_diagtable
use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : param_file_type, log_version, get_param
@@ -52,7 +54,7 @@ subroutine register_obsolete_diagnostics(param_file, diag)
if (diag_found(diag, 'KPP_dTdt', 'KPP_NLT_dTdt')) foundEntry = .true.
if (diag_found(diag, 'KPP_dSdt', 'KPP_NLT_dSdt')) foundEntry = .true.
- if (causeFatal) then; errType = FATAL
+ if (causeFatal) then ; errType = FATAL
else ; errType = WARNING ; endif
if (foundEntry .and. is_root_pe()) &
call MOM_error(errType, 'MOM_obsolete_diagnostics: Obsolete diagnostics found in diag_table.')
diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90
index f81f2a7574..10807a9aca 100644
--- a/src/diagnostics/MOM_obsolete_params.F90
+++ b/src/diagnostics/MOM_obsolete_params.F90
@@ -1,7 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Methods for testing for, and list of, obsolete run-time parameters.
module MOM_obsolete_params
-! This file is part of MOM6. See LICENSE.md for the license.
! This module was first conceived and written by Robert Hallberg, July 2010.
use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe
@@ -108,10 +111,23 @@ subroutine find_obsolete_params(param_file)
call obsolete_real(param_file, "MIN_Z_DIAG_INTERVAL")
call obsolete_char(param_file, "Z_OUTPUT_GRID_FILE")
+ call obsolete_logical(param_file, "CFL_BASED_TRUNCATIONS", .true.)
+ call obsolete_logical(param_file, "KD_BACKGROUND_VIA_KDML_BUG", .false.)
+ call obsolete_logical(param_file, "USE_DIABATIC_TIME_BUG", .false.)
+
call read_param(param_file, "INTERPOLATE_SPONGE_TIME_SPACE", test_logic)
call obsolete_logical(param_file, "NEW_SPONGES", warning_val=test_logic, &
hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.")
+ test_logic = .true. ; call read_param(param_file, "BOUND_KH", test_logic)
+ call obsolete_logical(param_file, "BETTER_BOUND_KH", warning_val=test_logic, hint="Use BOUND_KH alone.")
+ test_logic = .true. ; call read_param(param_file, "BOUND_AH", test_logic)
+ call obsolete_logical(param_file, "BETTER_BOUND_AH", warning_val=test_logic, hint="Use BOUND_AH alone.")
+
+ test_logic = .false. ; call read_param(param_file, "UNSPLIT_DT_VISC_BUG", test_logic)
+ call obsolete_logical(param_file, "FIX_UNSPLIT_DT_VISC_BUG", warning_val=(.not.test_logic), &
+ hint="Use UNSPLIT_DT_VISC_BUG instead, but with the reversed meaning.")
+
call obsolete_logical(param_file, "SMOOTH_RI", hint="Instead use N_SMOOTH_RI.")
call obsolete_logical(param_file, "INTERNAL_TIDE_CORNER_ADVECT", .false.)
@@ -201,7 +217,7 @@ subroutine obsolete_char(param_file, varname, warning_val, hint)
logical :: var_is_set ! True if this value was read by read_param.
logical :: only_warn
- test_string = ''; call read_param(param_file, varname, test_string, set=var_is_set)
+ test_string = '' ; call read_param(param_file, varname, test_string, set=var_is_set)
hint_msg = " " ; if (present(hint)) hint_msg = hint
if (var_is_set) then
@@ -238,8 +254,8 @@ subroutine obsolete_real(param_file, varname, warning_val, hint, only_warn)
logical :: issue_warning
character(len=128) :: hint_msg
- test_val = -9e35; call read_param(param_file, varname, test_val, set=var_is_set)
- warn_val = -9e35; if (present(warning_val)) warn_val = warning_val
+ test_val = -9e35 ; call read_param(param_file, varname, test_val, set=var_is_set)
+ warn_val = -9e35 ; if (present(warning_val)) warn_val = warning_val
hint_msg = " " ; if (present(hint)) hint_msg = hint
issue_warning = .false. ; if (present(only_warn)) issue_warning = only_warn
@@ -266,8 +282,8 @@ subroutine obsolete_int(param_file, varname, warning_val, hint)
integer :: test_val, warn_val
character(len=128) :: hint_msg
- test_val = -123456788; call read_param(param_file, varname, test_val, set=var_is_set)
- warn_val = -123456788; if (present(warning_val)) warn_val = warning_val
+ test_val = -123456788 ; call read_param(param_file, varname, test_val, set=var_is_set)
+ warn_val = -123456788 ; if (present(warning_val)) warn_val = warning_val
hint_msg = " " ; if (present(hint)) hint_msg = hint
if (var_is_set) then
diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90
index bc0b05b477..1d63334a23 100644
--- a/src/diagnostics/MOM_spatial_means.F90
+++ b/src/diagnostics/MOM_spatial_means.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Functions and routines to take area, volume, mass-weighted, layerwise, zonal or meridional means
module MOM_spatial_means
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=)
use MOM_coms, only : EFP_to_real, real_to_EFP, EFP_sum_across_PEs
use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real
diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90
index 42187a6455..9903408124 100644
--- a/src/diagnostics/MOM_sum_output.F90
+++ b/src/diagnostics/MOM_sum_output.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Reports integrated quantities for monitoring the model state
module MOM_sum_output
-! This file is part of MOM6. See LICENSE.md for the license.
-
use iso_fortran_env, only : int64
use MOM_checksums, only : is_NaN, field_checksum
use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs
@@ -115,6 +117,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 +241,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", &
@@ -405,9 +411,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci
real :: QRZL2_to_J ! The combination of unit rescaling factors to convert integrated heat
! content into mks units [J Q-1 R-1 Z-1 L-2 ~> 1]
real :: J_to_QRZL2 ! The combination of unit rescaling factors to rescale integrated heat
- ! content from mks units into the internal units of MOM6 [Q R Z L J-1 ~> 1]
+ ! content from mks units into the internal units of MOM6 [Q R Z L2 J-1 ~> 1]
real :: kg_to_RZL2 ! The combination of unit rescaling factors to rescale masses from
- ! mks units into the internal units of MOM6 [R Z L kg-1 ~> 1]
+ ! mks units into the internal units of MOM6 [R Z L2 kg-1 ~> 1]
real :: salt_to_kg ! A factor used to rescale salt contents [kg R-1 Z-1 L-2 ~> nondim]
integer :: num_nc_fields ! The number of fields that will actually go into
! the NetCDF file.
@@ -419,8 +425,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]
@@ -560,7 +566,10 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci
do k=1,nz ; vol_lay(k) = (1.0 / GV%Rho0) * mass_lay(k) ; enddo
else
if (CS%do_APE_calc) then
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: eta)
call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref)
+ !$omp target exit data map(from: eta)
do k=1,nz ; do j=js,je ; do i=is,ie
tmp1(i,j,k) = (eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j)
enddo ; enddo ; enddo
@@ -834,7 +843,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)
@@ -848,17 +858,16 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci
elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday
else ; write(day_str, '(ES15.9)') reday ; endif
- if (n < 1000000) then ; write(n_str, '(I6)') n
- elseif (n < 10000000) then ; write(n_str, '(I7)') n
- elseif (n < 100000000) then ; write(n_str, '(I8)') n
- else ; write(n_str, '(I10)') n ; endif
+ if (n < 1000000) then ; write(n_str, '(I6)') n
+ else ; write(n_str, '(I0)') n ; endif
- if (date_stamped) then
+ date_str = trim(mesg_intro)//trim(day_str)
+ if (date_stamped) &
write(date_str,'("MOM Date",i7,2("/",i2.2)," ",i2.2,2(":",i2.2))') &
iyear, imonth, iday, ihour, iminute, isecond
- else
- date_str = trim(mesg_intro)//trim(day_str)
- endif
+ 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 +881,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/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90
index 7abdab0a90..9ce2af08f4 100644
--- a/src/diagnostics/MOM_wave_speed.F90
+++ b/src/diagnostics/MOM_wave_speed.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Routines for calculating baroclinic wave speeds
module MOM_wave_speed
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl
use MOM_error_handler, only : MOM_error, FATAL, WARNING
use MOM_file_parser, only : log_version
@@ -135,7 +137,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N
real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1]
real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5]
real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times
- ! thicknesses [R-1 H ~> m4 kg-1 or m], negative for stable stratification.
+ ! thicknesses [H R-1 ~> m4 kg-1 or m], negative for stable stratification.
real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2].
real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and
! its derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim].
@@ -550,8 +552,9 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N
! Determine whether N2 estimates should not be allowed to increase with depth.
if (l_mono_N2_column_fraction>0.) then
if (GV%Boussinesq .or. GV%semi_Boussinesq) then
- below_mono_N2_frac = ((G%bathyT(i,j)+G%Z_ref) - GV%H_to_Z*sum_hc < &
- l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref))
+ below_mono_N2_frac = &
+ (max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) - GV%H_to_Z * sum_hc < &
+ l_mono_N2_column_fraction * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0))
else
below_mono_N2_frac = (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i))
endif
@@ -852,7 +855,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s
real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1]
real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5]
real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times
- ! thicknesses [R-1 H ~> m4 kg-1 or m], negative for stable stratification.
+ ! thicknesses [H R-1 ~> m4 kg-1 or m], negative for stable stratification.
real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2].
real :: tol_Hfrac ! Layers that together are smaller than this fraction of
! the total water column can be merged for efficiency [nondim].
@@ -879,13 +882,10 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s
real :: mode_struct(SZK_(GV)+1) ! The mode structure [nondim], but it is also temporarily
! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6.
real :: mode_struct_fder(SZK_(GV)) ! The mode structure 1st derivative [Z-1 ~> m-1], but it is also temporarily
- ! in units of [Z-1 L2 T-2 ~> m s-2] after it is modified inside of tdma6.
+ ! in units of [L2 Z-1 T-2 ~> m s-2] after it is modified inside of tdma6.
real :: mode_struct_sq(SZK_(GV)+1) ! The square of mode structure [nondim]
real :: mode_struct_fder_sq(SZK_(GV)) ! The square of mode structure 1st derivative [Z-2 ~> m-2]
-
- real :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2]
- real :: ms_sq ! The sum of the square of the values returned from tdma6 [L4 T-4 ~> m4 s-4]
real :: w2avg ! A total for renormalization [H L4 T-4 ~> m5 s-4 or kg m2 s-4]
real, parameter :: a_int = 0.5 ! Integral total for normalization [nondim]
real :: renorm ! Normalization factor [T2 L-2 ~> s2 m-2]
@@ -1372,7 +1372,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s
! Find other eigen values if c1 is of significant magnitude, > cn_thresh
nrootsfound = 0 ! number of extra roots found (not including 1st root)
if ((nmodes > 1) .and. (kc >= nmodes+1) .and. (cn(i,j,1) > CS%c1_thresh)) then
- ! Set the the range to look for the other desired eigen values
+ ! Set the range to look for the other desired eigen values
! set min value just greater than the 1st root (found above)
lamMin = lam_1*(1.0 + tol_solve)
! set max value based on a low guess at wavespeed for highest mode
@@ -1402,15 +1402,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s
! function changes sign but has a local max/min in interval,
! try subdividing interval as many times as necessary (or sub_it_max).
! loop that increases number of subintervals:
- !call MOM_error(WARNING, "determinant changes sign"// &
- ! "but has a local max/min in interval;"//&
- ! " reduce increment in lam.")
+ !call MOM_error(WARNING, "determinant changes sign "// &
+ ! "but has a local max/min in interval; "//&
+ ! "reduce increment in lam.")
! begin subdivision loop -------------------------------------------
sub_rootfound = .false. ! initialize
do sub_it=1,sub_it_max
nsub = 2**sub_it ! number of subintervals; nsub=2,4,8,...
! loop over each subinterval:
- do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7;...
+ do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7; ...
xl_sub = xl + lamInc/(nsub)*sub
call tridiag_det(Igu, Igl, 2, kc, xl_sub, det_sub, ddet_sub, &
row_scale=c2_scale)
@@ -1429,8 +1429,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s
! sub intervals, try subdividing again unless sub_it_max has been reached.
if (sub_it == sub_it_max) then
call MOM_error(WARNING, "wave_speed: root not found "// &
- " after sub_it_max subdivisions of original"// &
- " interval.")
+ "after sub_it_max subdivisions of original "// &
+ "interval.")
endif ! sub_it == sub_it_max
enddo ! sub_it-loop-------------------------------------------------
endif ! det_l*ddet_l < 0.0
diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90
index 4c7f86668c..754f293b69 100644
--- a/src/equation_of_state/MOM_EOS.F90
+++ b/src/equation_of_state/MOM_EOS.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides subroutines for quantities specific to the equation of state
module MOM_EOS
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
use MOM_EOS_linear, only : linear_EOS, avg_spec_vol_linear
use MOM_EOS_linear, only : int_density_dz_linear, int_spec_vol_dp_linear
@@ -17,7 +19,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 +36,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
@@ -50,7 +52,9 @@ module MOM_EOS
public calculate_TFreeze
public convert_temp_salt_for_TEOS10
public cons_temp_to_pot_temp
+public pot_temp_to_cons_temp
public abs_saln_to_prac_saln
+public prac_saln_to_abs_saln
public gsw_sp_from_sr
public gsw_sr_from_sp
public gsw_pt_from_ct
@@ -66,6 +70,7 @@ module MOM_EOS
interface calculate_density
module procedure calculate_density_scalar
module procedure calculate_density_1d
+ module procedure calculate_density_2d
module procedure calculate_stanley_density_scalar
module procedure calculate_stanley_density_1d
end interface calculate_density
@@ -80,6 +85,7 @@ module MOM_EOS
interface calculate_density_derivs
module procedure calculate_density_derivs_scalar, calculate_density_derivs_array
module procedure calculate_density_derivs_1d
+ module procedure calculate_density_derivs_2d
end interface calculate_density_derivs
!> Calculate the derivatives of specific volume with temperature and salinity from T, S, and P
@@ -115,11 +121,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
@@ -171,7 +185,7 @@ module MOM_EOS
character*(12), parameter :: EOS_ROQUET_RHO_STRING = "ROQUET_RHO" !< A string for specifying the equation of state
character*(12), parameter :: EOS_ROQUET_SPV_STRING = "ROQUET_SPV" !< A string for specifying the equation of state
character*(12), parameter :: EOS_JACKETT06_STRING = "JACKETT_06" !< A string for specifying the equation of state
-character*(12), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING !< The default equation of state
+character*(12), parameter :: EOS_DEFAULT = EOS_WRIGHT_FULL_STRING !< The default equation of state
integer, parameter :: TFREEZE_LINEAR = 1 !< A named integer specifying a freezing point expression
integer, parameter :: TFREEZE_MILLERO = 2 !< A named integer specifying a freezing point expression
@@ -345,6 +359,66 @@ subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale)
end subroutine calculate_density_1d
+
+!> 2D version...
+subroutine calculate_density_2d(T, S, pressure, rho, EOS, dom, rho_ref)
+ real, intent(in) :: T(:,:)
+ !< Potential temperature referenced to the surface [C ~> degC]
+ real, intent(in) :: S(:,:)
+ !< Salinity [S ~> ppt]
+ real, intent(in) :: pressure(:,:)
+ !< Pressure [R L2 T-2 ~> Pa]
+ real, intent(inout) :: rho(:,:)
+ !< Density (in-situ if pressure is local) [R ~> kg m-3]
+ type(EOS_type), intent(in) :: EOS
+ !< Equation of state structure
+ integer, optional, intent(in) :: dom(2,2)
+ !< The domain of indices to work on, taking into account that arrays start
+ !! at 1.
+ real, optional, intent(in) :: rho_ref
+ !< A reference density [R ~> kg m-3]
+
+ real, dimension(size(rho,1), size(rho,2)) :: pres
+ ! Pressure converted to [Pa]
+ real, dimension(size(rho,1), size(rho,2)) :: Ta
+ ! Temperature converted to [degC]
+ real, dimension(size(rho,1), size(rho,2)) :: Sa
+ ! Salinity converted to [ppt]
+ integer :: is, ie, js, je, npts
+ integer :: domain(2,2)
+
+ if (present(dom)) then
+ domain(:,:) = dom(:,:)
+ else
+ domain(1,:) = [1, size(rho,1)]
+ domain(2,:) = [1, size(rho,2)]
+ endif
+
+ if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%R_to_kg_m3 == 1.0) .and. &
+ (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then
+ call EOS%type%calculate_density_array_2d(T, S, pressure, rho, domain, &
+ rho_ref=rho_ref)
+ else ! This is the same as above, but with some extra work to rescale variables.
+ is = domain(1,1) ; ie = domain(1,2)
+ js = domain(2,1) ; je = domain(2,2)
+
+ pres(is:ie, js:je) = EOS%RL2_T2_to_Pa * pressure(is:ie, js:je)
+ Ta(is:ie, js:je) = EOS%C_to_degC * T(is:ie, js:je)
+ Sa(is:ie, js:je) = EOS%S_to_ppt * S(is:ie, js:je)
+
+ if (present(rho_ref)) then
+ call EOS%type%calculate_density_array_2d(Ta, Sa, pres, rho, domain, &
+ rho_ref=EOS%R_to_kg_m3*rho_ref)
+ else
+ call EOS%type%calculate_density_array_2d(Ta, Sa, pres, rho, domain)
+ endif
+ endif
+
+ if (EOS%kg_m3_to_R /= 1.) &
+ rho(is:ie, js:je) = EOS%kg_m3_to_R * rho(is:ie, js:je)
+end subroutine calculate_density_2d
+
+
!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs
!! including the variance of T, S and covariance of T-S,
!! potentially limiting the domain of indices that are worked on.
@@ -408,7 +482,6 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s
real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific
!! volume in combination with scaling stored in EOS [various]
- real, dimension(size(specvol)) :: rho ! Density [kg m-3]
integer :: j
if (.not. allocated(EOS%type)) call MOM_error(FATAL, &
@@ -529,28 +602,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 +656,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 +667,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 +703,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 +729,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 +739,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 +749,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 +795,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
@@ -757,6 +894,64 @@ subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, do
end subroutine calculate_density_derivs_1d
+!> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs.
+subroutine calculate_density_derivs_2d(T, S, pressure, drho_dT, drho_dS, EOS, dom)
+ real, intent(in) :: T(:,:)
+ !< Potential temperature referenced to the surface [degC]
+ real, intent(in) :: S(:,:)
+ !< Salinity [ppt]
+ real, intent(in) :: pressure(:,:)
+ !< Pressure [Pa]
+ real, intent(inout) :: drho_dT(:,:)
+ !< The partial derivative of density with potential temperature
+ !! [kg m-3 degC-1] or other units determinedby the optional scale argument
+ real, intent(inout) :: drho_dS(:,:)
+ !< The partial derivative of density with salinity, in [kg m-3 ppt-1] or
+ !! other units determined by the optional scale argument
+ type(EOS_type), intent(in) :: EOS
+ !< Equation of state structure
+ integer, optional, intent(in) :: dom(2,2)
+ !< The domain of indices to work on, taking into account that arrays start
+
+ ! Local variables
+ real :: Ta(size(T,1), size(T,2))
+ ! Temperature converted to [degC]
+ real :: Sa(size(S,1), size(S,2))
+ ! Salinity converted to [ppt]
+ real :: press(size(pressure,1), size(pressure,2))
+ ! Pressure converted to [Pa]
+ integer :: is, ie, js, je, npts
+ integer :: domain(2,2)
+
+ if (present(dom)) then
+ domain(:,:) = dom(:,:)
+ else
+ domain(1,:) = [1, size(drho_dT, 1)]
+ domain(2,:) = [1, size(drho_dT, 2)]
+ endif
+ is = domain(1,1) ; ie = domain(1,2)
+ js = domain(2,1) ; je = domain(2,2)
+
+ if (.not. allocated(EOS%type)) call MOM_error(FATAL, &
+ "calculate_density_derivs_array: EOS%form_of_EOS is not valid.")
+
+ if (all([EOS%RL2_T2_to_Pa, EOS%C_to_degC, EOS%S_to_ppt] == 1.)) then
+ call EOS%type%calculate_density_derivs_2d(T, S, pressure, drho_dT, drho_dS, domain)
+ else
+ press(is:ie, js:je) = EOS%RL2_T2_to_Pa * pressure(is:ie, js:je)
+ Ta(is:ie, js:je) = EOS%C_to_degC * T(is:ie, js:je)
+ Sa(is:ie, js:je) = EOS%S_to_ppt * S(is:ie, js:je)
+
+ call EOS%type%calculate_density_derivs_2d(Ta, Sa, press, drho_dT, drho_dS, domain)
+ endif
+
+ if (EOS%kg_m3_to_R * EOS%C_to_degC /= 1.) &
+ drho_dT(is:ie, js:je) = EOS%kg_m3_to_R * EOS%C_to_degC * drho_dT(is:ie, js:je)
+ if (EOS%kg_m3_to_R * EOS%S_to_ppt /= 1.) &
+ drho_dS(is:ie, js:je) = EOS%kg_m3_to_R * EOS%S_to_ppt * drho_dS(is:ie, js:je)
+end subroutine calculate_density_derivs_2d
+
+
!> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar
!! to a one-element array
subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS, scale)
@@ -779,8 +974,6 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS
real :: pres(1) ! Pressure converted to [Pa]
real :: Ta(1) ! Temperature converted to [degC]
real :: Sa(1) ! Salinity converted to [ppt]
- real :: dR_dT(1) ! A copy of drho_dT in mks units [kg m-3 degC-1]
- real :: dR_dS(1) ! A copy of drho_dS in mks units [kg m-3 ppt-1]
pres(1) = EOS%RL2_T2_to_Pa*pressure
Ta(1) = EOS%C_to_degC * T
@@ -1140,7 +1333,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 +1353,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 +1463,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 +1473,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 +1552,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 +1564,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 +1658,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 +1716,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 +1762,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 +1816,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 +1853,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 +1867,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 +1901,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 +1912,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 +1920,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)
@@ -1843,7 +2077,6 @@ subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale)
!! while the default is equivalent to EOS%ppt_to_S.
! Local variables
- real, dimension(size(S)) :: Sa ! Salinity converted to [ppt]
real :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S PSU-1 ~> 1]
real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from
! reference salinity to practical salinity [PSU ppt-1]
@@ -1884,7 +2117,6 @@ subroutine prac_saln_to_abs_saln(S, absSaln, EOS, dom, scale)
!! while the default is equivalent to EOS%ppt_to_S.
! Local variables
- real, dimension(size(S)) :: Sp ! Salinity converted to [ppt]
real :: S_scale ! A factor to convert absolute salinity from ppt to the desired units [S ppt-1 ~> 1]
real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from
! practical salinity to reference salinity [PSU ppt-1]
@@ -2013,9 +2245,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
@@ -2073,7 +2305,6 @@ logical function test_TS_conversion_consistency(T_cons, S_abs, T_pot, S_prac, EO
real :: Ttol ! Roundoff error on a typical value of temperatures [degC]
logical :: test_OK ! True if a particular test is consistent.
logical :: OK ! True if all checks so far are consistent.
- integer :: i, j, n
OK = .true.
@@ -2121,7 +2352,6 @@ logical function test_TFr_consistency(S_test, p_test, EOS, verbose, EOS_name, TF
real, dimension(-3:3,-3:3) :: S ! Salinities at the test value and perturbed points [S ~> ppt]
real, dimension(-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa]
real, dimension(-3:3,-3:3,2) :: TFr ! Freezing point at the test value and perturbed points [C ~> degC]
- character(len=200) :: mesg
real :: dS ! Magnitude of salinity perturbations [S ~> ppt]
real :: dp ! Magnitude of pressure perturbations [R L2 T-2 ~> Pa]
! real :: tol ! The nondimensional tolerance from roundoff [nondim]
diff --git a/src/equation_of_state/MOM_EOS_Jackett06.F90 b/src/equation_of_state/MOM_EOS_Jackett06.F90
index 1ef7456e96..4c0705f717 100644
--- a/src/equation_of_state/MOM_EOS_Jackett06.F90
+++ b/src/equation_of_state/MOM_EOS_Jackett06.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The equation of state using the Jackett et al 2006 expressions that are often used in Hycom
module MOM_EOS_Jackett06
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
implicit none ; private
diff --git a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90
index 205b6e2b55..852f62fb73 100644
--- a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90
+++ b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The equation of state for specific volume (SpV) using the expressions of Roquet et al. 2015
module MOM_EOS_Roquet_Spv
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
implicit none ; private
diff --git a/src/equation_of_state/MOM_EOS_Roquet_rho.F90 b/src/equation_of_state/MOM_EOS_Roquet_rho.F90
index 1a5cc7b49c..1e80c63c5a 100644
--- a/src/equation_of_state/MOM_EOS_Roquet_rho.F90
+++ b/src/equation_of_state/MOM_EOS_Roquet_rho.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The equation of state using the expressions of Roquet et al. (2015) that are used in NEMO
module MOM_EOS_Roquet_rho
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
implicit none ; private
diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90
index 17f2f5156f..9f63dd9b3b 100644
--- a/src/equation_of_state/MOM_EOS_TEOS10.F90
+++ b/src/equation_of_state/MOM_EOS_TEOS10.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The equation of state using the TEOS10 expressions
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 +13,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_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90
index 6051c0fb0a..93ac54d0ac 100644
--- a/src/equation_of_state/MOM_EOS_UNESCO.F90
+++ b/src/equation_of_state/MOM_EOS_UNESCO.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The equation of state using the Jackett and McDougall fits to the UNESCO EOS
module MOM_EOS_UNESCO
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
implicit none ; private
diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90
index 874d3e784e..c2861c451d 100644
--- a/src/equation_of_state/MOM_EOS_Wright.F90
+++ b/src/equation_of_state/MOM_EOS_Wright.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The equation of state using a poor implementation (missing parenthesis and bugs) of the
!! reduced range Wright 1997 expressions
module MOM_EOS_Wright
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
use MOM_hor_index, only : hor_index_type
@@ -67,8 +69,12 @@ module MOM_EOS_Wright
!> Local implementation of generic calculate_density_array for efficiency
procedure :: calculate_density_array => calculate_density_array_buggy_Wright
+ !> Local implementation of generic calculate_density_array_2d for efficiency
+ procedure :: calculate_density_array_2d => calculate_density_array_2d_buggy_Wright
!> Local implementation of generic calculate_spec_vol_array for efficiency
procedure :: calculate_spec_vol_array => calculate_spec_vol_array_buggy_Wright
+ !> Local implementation of generic calculate_density_derivs_2d for efficiency
+ procedure :: calculate_density_derivs_2d => calculate_density_derivs_2d_buggy_Wright
end type buggy_Wright_EOS
@@ -77,8 +83,7 @@ module MOM_EOS_Wright
!> In situ density of sea water using a buggy implementation of Wright, 1997 [kg m-3]
!!
!! This is an elemental function that can be applied to any combination of scalar and array inputs.
-real elemental function density_elem_buggy_Wright(this, T, S, pressure)
- class(buggy_Wright_EOS), intent(in) :: this !< This EOS
+real elemental function density_elem_buggy_Wright_loc(T, S, pressure)
real, intent(in) :: T !< potential temperature relative to the surface [degC].
real, intent(in) :: S !< salinity [PSU].
real, intent(in) :: pressure !< pressure [Pa].
@@ -91,8 +96,20 @@ real elemental function density_elem_buggy_Wright(this, T, S, pressure)
al0 = (a0 + a1*T) +a2*S
p0 = (b0 + b4*S) + T * (b1 + T*(b2 + b3*T) + b5*S)
lambda = (c0 +c4*S) + T * (c1 + T*(c2 + c3*T) + c5*S)
- density_elem_buggy_Wright = (pressure + p0) / (lambda + al0*(pressure + p0))
+ density_elem_buggy_Wright_loc = (pressure + p0) / (lambda + al0*(pressure + p0))
+
+end function density_elem_buggy_Wright_loc
+
+!> Wrapper for density_elem_buggy_Wright_loc created to preserve API while calling
+!! density_elem_buggy_Wright without "this" variable that causes runtime errors on
+!! gpu runs with nvfortran.
+real elemental function density_elem_buggy_Wright(this, T, S, pressure)
+ class(buggy_Wright_EOS), intent(in) :: this !< This EOS
+ real, intent(in) :: T !< potential temperature relative to the surface [degC].
+ real, intent(in) :: S !< salinity [PSU].
+ real, intent(in) :: pressure !< pressure [Pa].
+ density_elem_buggy_Wright = density_elem_buggy_Wright_loc(T, S, pressure)
end function density_elem_buggy_Wright
!> In situ density anomaly of sea water using a buggy implementation of Wright, 1997 [kg m-3]
@@ -175,8 +192,7 @@ end function spec_vol_anomaly_elem_buggy_Wright
!> Calculate the partial derivatives of density with potential temperature and salinity
!! using the buggy implementation of the equation of state, as fit by Wright, 1997
-elemental subroutine calculate_density_derivs_elem_buggy_Wright(this, T, S, pressure, drho_dT, drho_dS)
- class(buggy_Wright_EOS), intent(in) :: this !< This EOS
+elemental subroutine calculate_density_derivs_elem_buggy_Wright_loc( T, S, pressure, drho_dT, drho_dS)
real, intent(in) :: T !< Potential temperature relative to the surface [degC]
real, intent(in) :: S !< Salinity [PSU]
real, intent(in) :: pressure !< Pressure [Pa]
@@ -203,6 +219,23 @@ elemental subroutine calculate_density_derivs_elem_buggy_Wright(this, T, S, pres
drho_dS = I_denom2 * (lambda* (b4 + b5*T) - &
(pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) ))
+end subroutine calculate_density_derivs_elem_buggy_Wright_loc
+
+!> Wrapper for density_elem_buggy_Wright_loc created to preserve API while calling
+!! density_elem_buggy_Wright without "this" variable that causes runtime errors on
+!! gpu runs with nvfortran.
+elemental subroutine calculate_density_derivs_elem_buggy_Wright(this, T, S, pressure, drho_dT, drho_dS)
+ class(buggy_Wright_EOS), intent(in) :: this !< This EOS
+ real, intent(in) :: T !< Potential temperature relative to the surface [degC]
+ real, intent(in) :: S !< Salinity [PSU]
+ real, intent(in) :: pressure !< Pressure [Pa]
+ real, intent(out) :: drho_dT !< The partial derivative of density with potential
+ !! temperature [kg m-3 degC-1]
+ real, intent(out) :: drho_dS !< The partial derivative of density with salinity,
+ !! in [kg m-3 PSU-1]
+
+ call calculate_density_derivs_elem_buggy_Wright_loc(T, S, pressure, drho_dT, drho_dS)
+
end subroutine calculate_density_derivs_elem_buggy_Wright
!> Second derivatives of density with respect to temperature, salinity, and pressure,
@@ -508,12 +541,15 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
else
rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0
endif
+ !$omp target enter data map(alloc: z0pres, al0_2d, p0_2d, lambda_2d, intz)
if (present(Z_0p)) then
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
z0pres(i,j) = Z_0p(i,j)
- enddo ; enddo
+ enddo
else
- z0pres(:,:) = 0.0
+ do concurrent (j=HI%jsd:HI%jed, i=HI%isd:HI%ied)
+ z0pres(i,j) = 0.0
+ enddo
endif
a1s = a1 ; a2s = a2
@@ -540,7 +576,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set
endif
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
al0_2d(i,j) = (a0 + a1s*T(i,j)) + a2s*S(i,j)
p0_2d(i,j) = (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j))
lambda_2d(i,j) = (c0 +c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j))
@@ -562,95 +598,106 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, &
dpa(i,j) = Pa_to_RL2_T2 * (g_Earth*rho_anom*dz - 2.0*eps*rem)
if (present(intz_dpa)) &
intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*g_Earth*rho_anom*dz**2 - dz*(1.0+eps)*rem)
- enddo ; enddo
-
- if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq
- ! hWght is the distance measure by which the cell is violation of
- ! hydrostatic consistency. For large hWght we bias the interpolation of
- ! T & S along the top and bottom integrals, akin to thickness weighting.
- hWght = 0.0
- if (do_massWeight) &
- hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j))
- if (top_massWeight) &
- hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j))
- if (hWght > 0.) then
- hL = (z_t(i,j) - z_b(i,j)) + dz_neglect
- hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect
- hWght = hWght * ( (hL-hR)/(hL+hR) )**2
- iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
- hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
- hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
- else
- hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0
- endif
-
- intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
- do m=2,4
- wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
- wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
-
- al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j))
- p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j))
- lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j))
-
- dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j)))
- p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + &
- (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j))))
-
- I_al0 = 1.0 / al0
- I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave)
- eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps
-
- intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * &
- I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) )
- enddo
- ! Use Boole's rule to integrate the values.
- intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3))
- enddo ; enddo ; endif
-
- if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie
- ! hWght is the distance measure by which the cell is violation of
- ! hydrostatic consistency. For large hWght we bias the interpolation of
- ! T & S along the top and bottom integrals, akin to thickness weighting.
- hWght = 0.0
- if (do_massWeight) &
- hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j))
- if (top_massWeight) &
- hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1))
- if (hWght > 0.) then
- hL = (z_t(i,j) - z_b(i,j)) + dz_neglect
- hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect
- hWght = hWght * ( (hL-hR)/(hL+hR) )**2
- iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
- hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
- hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
- else
- hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0
- endif
-
- intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1)
- do m=2,4
- wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
- wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
-
- al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i,j+1))
- p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i,j+1))
- lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1))
-
- dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1)))
- p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + &
- (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1))))
+ enddo
- I_al0 = 1.0 / al0
- I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave)
- eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps
+ if (present(intx_dpa)) then
+ !$omp target teams loop collapse(2) &
+ !$omp private(hWght, hL, hR, iDenom, hWt_LL, hWt_LR, hWt_RR, hWt_RL, m, wt_L, wt_R, wtT_L, &
+ !$omp wtT_R, al0, p0, lambda, dz, p_ave, I_al0, I_Lzz, eps, eps2, intz)
+ do j=js,je ; do I=Isq,Ieq
+ ! hWght is the distance measure by which the cell is violation of
+ ! hydrostatic consistency. For large hWght we bias the interpolation of
+ ! T & S along the top and bottom integrals, akin to thickness weighting.
+ hWght = 0.0
+ if (do_massWeight) &
+ hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j))
+ if (top_massWeight) &
+ hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j))
+ if (hWght > 0.) then
+ hL = (z_t(i,j) - z_b(i,j)) + dz_neglect
+ hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect
+ hWght = hWght * ( (hL-hR)/(hL+hR) )**2
+ iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
+ hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
+ else
+ hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0
+ endif
+
+ intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j)
+ do m=2,4
+ wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
+
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j))
+
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j)))
+ p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + &
+ (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j))))
+
+ I_al0 = 1.0 / al0
+ I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave)
+ eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps
+
+ intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * &
+ I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) )
+ enddo
+ ! Use Boole's rule to integrate the values.
+ intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3))
+ enddo ; enddo
+ endif
- intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * &
- I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) )
- enddo
- ! Use Boole's rule to integrate the values.
- inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3))
- enddo ; enddo ; endif
+ if (present(inty_dpa)) then
+ !$omp target teams loop collapse(2) &
+ !$omp private(hWght, hL, hR, iDenom, hWt_LL, hWt_LR, hWt_RR, hWt_RL, m, wt_L, wt_R, wtT_L, &
+ !$omp wtT_R, al0, p0, lambda, dz, p_ave, I_al0, I_Lzz, eps, eps2, intz)
+ do J=Jsq,Jeq ; do i=is,ie
+ ! hWght is the distance measure by which the cell is violation of
+ ! hydrostatic consistency. For large hWght we bias the interpolation of
+ ! T & S along the top and bottom integrals, akin to thickness weighting.
+ hWght = 0.0
+ if (do_massWeight) &
+ hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j))
+ if (top_massWeight) &
+ hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1))
+ if (hWght > 0.) then
+ hL = (z_t(i,j) - z_b(i,j)) + dz_neglect
+ hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect
+ hWght = hWght * ( (hL-hR)/(hL+hR) )**2
+ iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR )
+ hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom
+ hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom
+ else
+ hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0
+ endif
+
+ intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1)
+ do m=2,4
+ wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L
+ wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR)
+
+ al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i,j+1))
+ p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i,j+1))
+ lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1))
+
+ dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1)))
+ p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + &
+ (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1))))
+
+ I_al0 = 1.0 / al0
+ I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave)
+ eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps
+
+ intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * &
+ I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) )
+ enddo
+ ! Use Boole's rule to integrate the values.
+ inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3))
+ enddo ; enddo
+ endif
+ !$omp target exit data map(release: z0pres, al0_2d, p0_2d, lambda_2d, intz)
end subroutine int_density_dz_wright
@@ -719,7 +766,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, &
real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1]
real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa]
real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2]
- real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1]
+ real :: al0_scale ! Scaling factor to convert al0 from MKS units [kg m-3 R-1 ~> 1]
real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1]
real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1]
real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa]
@@ -925,12 +972,50 @@ subroutine calculate_density_array_buggy_Wright(this, T, S, pressure, rho, start
enddo
else
do j = start, start+npts-1
- rho(j) = density_elem_buggy_Wright(this, T(j), S(j), pressure(j))
+ rho(j) = density_elem_buggy_Wright_loc(T(j), S(j), pressure(j))
enddo
endif
-
end subroutine calculate_density_array_buggy_Wright
+!> Calculate the in-situ density for 2D arraya inputs and outputs.
+subroutine calculate_density_array_2d_buggy_Wright(this, T, S, pressure, rho, &
+ dom, rho_ref)
+ class(buggy_Wright_EOS), intent(in) :: this
+ !< This EOS
+ real, intent(in) :: T(:,:)
+ !< Potential temperature relative to the surface [degC]
+ real, intent(in) :: S(:,:)
+ !< Salinity [PSU]
+ real, intent(in) :: pressure(:,:)
+ !< Pressure [Pa]
+ real, intent(out) :: rho(:,:)
+ !< In situ density [kg m-3]
+ integer, intent(in) :: dom(2,2)
+ !< Index bounds of domain. First index is rank, second is bounds
+ real, optional, intent(in) :: rho_ref
+ !< A reference density [kg m-3]
+
+ integer :: is, ie, js, je
+ integer :: i, j
+
+ is = dom(1,1) ; ie = dom(1,2)
+ js = dom(2,1) ; je = dom(2,2)
+
+ ! NOTE: There is an implicit copy of `this` which cannot yet be prevented.
+ ! Possibly because Nvidia cannot associate `this` with `EOS%type`.
+
+ if (present(rho_ref)) then
+ do concurrent (j=js:je, i=is:ie)
+ rho(i,j) = density_anomaly_elem_buggy_Wright(this, T(i,j), S(i,j), &
+ pressure(i,j), rho_ref)
+ enddo
+ else
+ do concurrent (j=js:je, i=is:ie)
+ rho(i,j) = density_elem_buggy_Wright_loc( T(i,j), S(i,j), pressure(i,j))
+ enddo
+ endif
+end subroutine calculate_density_array_2d_buggy_Wright
+
!> Calculate the in-situ specific volume for 1D array inputs and outputs.
subroutine calculate_spec_vol_array_buggy_Wright(this, T, S, pressure, specvol, start, npts, spv_ref)
class(buggy_Wright_EOS), intent(in) :: this !< This EOS
@@ -958,6 +1043,38 @@ subroutine calculate_spec_vol_array_buggy_Wright(this, T, S, pressure, specvol,
end subroutine calculate_spec_vol_array_buggy_Wright
+!> Calculate the in-situ density derivatives for 2D array inputs and outputs.
+subroutine calculate_density_derivs_2d_buggy_Wright(this, T, S, pressure, &
+ drho_dT, drho_dS, dom)
+ class(buggy_Wright_EOS), intent(in) :: this
+ !< This EOS
+ real, intent(in) :: T(:,:)
+ !< Potential temperature relative to the surface [degC]
+ real, intent(in) :: S(:,:)
+ !< Salinity [PSU]
+ real, intent(in) :: pressure(:,:)
+ !< Pressure [Pa]
+ real, intent(out) :: drho_dT(:,:)
+ !< Partial derivative of density with potential temperature [kg m-3 degC-1]
+ real, intent(out) :: drho_dS(:,:)
+ !< Partial derivative of density with salinity [kg m-3 PSU-1]
+ integer, intent(in) :: dom(2,2)
+ !< Index bounds of domain. First index is rank, second is bounds
+
+ integer :: is, ie, js, je
+ integer :: i, j
+
+ is = dom(1,1) ; ie = dom(1,2)
+ js = dom(2,1) ; je = dom(2,2)
+
+ ! NOTE: There is an implicit copy of `this` which cannot yet be prevented.
+
+ do concurrent (j=js:je, i=is:ie)
+ call calculate_density_derivs_elem_buggy_Wright_loc( T(i,j), S(i,j), &
+ pressure(i,j), drho_dT(i,j), drho_dS(i,j))
+ enddo
+end subroutine calculate_density_derivs_2d_buggy_Wright
+
!> Set coefficients that can correct bugs un the buggy Wright equation of state.
subroutine set_params_buggy_Wright(this, use_Wright_2nd_deriv_bug)
class(buggy_Wright_EOS), intent(inout) :: this !< This EOS
diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90
index 4be5f2940e..e80af3fdf9 100644
--- a/src/equation_of_state/MOM_EOS_Wright_full.F90
+++ b/src/equation_of_state/MOM_EOS_Wright_full.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The equation of state using the Wright 1997 expressions with full range of data.
module MOM_EOS_Wright_full
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
use MOM_hor_index, only : hor_index_type
@@ -724,7 +726,7 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, &
real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1]
real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa]
real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2]
- real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1]
+ real :: al0_scale ! Scaling factor to convert al0 from MKS units [kg m-3 R-1 ~> 1]
real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1]
real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1]
real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa]
diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90
index 1635f9e809..af7f1dc936 100644
--- a/src/equation_of_state/MOM_EOS_Wright_red.F90
+++ b/src/equation_of_state/MOM_EOS_Wright_red.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The equation of state using the Wright 1997 expressions with reduced range of data.
module MOM_EOS_Wright_red
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
use MOM_hor_index, only : hor_index_type
@@ -726,7 +728,7 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, &
real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1]
real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa]
real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2]
- real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1]
+ real :: al0_scale ! Scaling factor to convert al0 from MKS units [kg m-3 R-1 ~> 1]
real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1]
real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1]
real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa]
diff --git a/src/equation_of_state/MOM_EOS_base_type.F90 b/src/equation_of_state/MOM_EOS_base_type.F90
index a6e5a21309..70d0c113dc 100644
--- a/src/equation_of_state/MOM_EOS_base_type.F90
+++ b/src/equation_of_state/MOM_EOS_base_type.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A generic type for equations of state
module MOM_EOS_base_type
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public EOS_base
@@ -42,6 +44,8 @@ module MOM_EOS_base_type
procedure :: calculate_density_scalar => a_calculate_density_scalar
!> Calculates the in-situ density or density anomaly for array inputs [m3 kg-1]
procedure :: calculate_density_array => a_calculate_density_array
+ !> Calculates the in-situ density or density anomaly for 2d array inputs [m3 kg-1]
+ procedure :: calculate_density_array_2d => a_calculate_density_array_2d
!> Calculates the in-situ specific volume or specific volume anomaly for scalar inputs [m3 kg-1]
procedure :: calculate_spec_vol_scalar => a_calculate_spec_vol_scalar
!> Calculates the in-situ specific volume or specific volume anomaly for array inputs [m3 kg-1]
@@ -50,6 +54,8 @@ module MOM_EOS_base_type
procedure :: calculate_density_derivs_scalar => a_calculate_density_derivs_scalar
!> Calculates the derivatives of density for array inputs
procedure :: calculate_density_derivs_array => a_calculate_density_derivs_array
+ !> Calculates the derivatives of density for array inputs
+ procedure :: calculate_density_derivs_2d => a_calculate_density_derivs_2d
!> Calculates the second derivatives of density for scalar inputs
procedure :: calculate_density_second_derivs_scalar => a_calculate_density_second_derivs_scalar
!> Calculates the second derivatives of density for array inputs
@@ -252,6 +258,36 @@ subroutine a_calculate_density_array(this, T, S, pressure, rho, start, npts, rho
end subroutine a_calculate_density_array
+ !> Calculate the in-situ density for 2D array inputs and outputs.
+ subroutine a_calculate_density_array_2d(this, T, S, pressure, rho, dom, rho_ref)
+ class(EOS_base), intent(in) :: this !< This EOS
+ real, intent(in) :: T(:,:)
+ !< Potential temperature relative to the surface [degC]
+ real, intent(in) :: S(:,:)
+ !< Salinity [PSU]
+ real, intent(in) :: pressure(:,:)
+ !< Pressure [Pa]
+ real, intent(out) :: rho(:,:)
+ !< In situ density [kg m-3]
+ integer, intent(in) :: dom(2,2)
+ !< Index bounds of domain. First index is rank, second is bounds
+ real, optional, intent(in) :: rho_ref
+ !< A reference density [kg m-3]
+
+ integer :: is, ie, js, je
+
+ is = dom(1,1) ; ie = dom(1,2)
+ js = dom(2,1) ; je = dom(2,2)
+
+ if (present(rho_ref)) then
+ rho(is:ie, js:je) = this%density_anomaly_elem(T(is:ie, js:je), &
+ S(is:ie, js:je), pressure(is:ie, js:je), rho_ref)
+ else
+ rho(is:ie, js:je) = this%density_elem(T(is:ie, js:je), S(is:ie, js:je), &
+ pressure(is:ie, js:je))
+ endif
+ end subroutine a_calculate_density_array_2d
+
!> In situ specific volume [m3 kg-1]
real function a_spec_vol_fn(this, T, S, pressure, spv_ref)
class(EOS_base), intent(in) :: this !< This EOS
@@ -350,6 +386,34 @@ subroutine a_calculate_density_derivs_array(this, T, S, pressure, drho_dT, drho_
end subroutine a_calculate_density_derivs_array
+ !> Calculate the derivatives of density with respect to temperature, salinity and pressure
+ !! for array inputs
+ subroutine a_calculate_density_derivs_2d(this, T, S, pressure, drho_dT, drho_dS, dom)
+ class(EOS_base), intent(in) :: this
+ !< This EOS
+ real, intent(in) :: T(:,:)
+ !< Potential temperature relative to the surface [degC]
+ real, intent(in) :: S(:,:)
+ !< Salinity [PSU]
+ real, intent(in) :: pressure(:,:)
+ !< Pressure [Pa]
+ real, intent(out) :: drho_dT(:,:)
+ !< The partial derivative of density with potential temperature
+ !! [kg m-3 degC-1]
+ real, intent(out) :: drho_dS(:,:)
+ !< The partial derivative of density with salinity, in [kg m-3 PSU-1]
+ integer, intent(in) :: dom(2,2)
+ !< Index bounds of domain. First index is rank, second is bounds
+
+ integer :: is, ie, js, je
+
+ is = dom(1,1) ; ie = dom(1,2)
+ js = dom(2,1) ; je = dom(2,2)
+
+ call this%calculate_density_derivs_elem(T(is:ie, js:je), S(is:ie, js:je), &
+ pressure(is:ie, js:je), drho_dt(is:ie, js:je), drho_ds(is:ie, js:je))
+ end subroutine a_calculate_density_derivs_2d
+
!> Calculate the second derivatives of density with respect to temperature, salinity and pressure
!! for scalar inputs
subroutine a_calculate_density_second_derivs_scalar(this, T, S, pressure, &
diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90
index e443970535..28d3ba68a0 100644
--- a/src/equation_of_state/MOM_EOS_linear.F90
+++ b/src/equation_of_state/MOM_EOS_linear.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A simple linear equation of state for sea water with constant coefficients
module MOM_EOS_linear
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_EOS_base_type, only : EOS_base
use MOM_hor_index, only : hor_index_type
@@ -16,9 +18,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 +65,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 +80,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 +95,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 +111,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 +176,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 +195,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 +217,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 +254,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 +290,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 +300,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 +324,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 +355,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 +373,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 +392,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 +414,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 +439,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 +461,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 +481,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 +502,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 +531,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 +552,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 +569,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 +608,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 +634,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 +663,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 +689,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 +706,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/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90
index faa103d094..d55fd0a2b0 100644
--- a/src/equation_of_state/MOM_TFreeze.F90
+++ b/src/equation_of_state/MOM_TFreeze.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Freezing point expressions
module MOM_TFreeze
-! This file is part of MOM6. See LICENSE.md for the license.
-
!********+*********+*********+*********+*********+*********+*********+**
!* The subroutines in this file determine the potential temperature *
!* or conservative temperature at which sea-water freezes. *
diff --git a/src/equation_of_state/MOM_temperature_convert.F90 b/src/equation_of_state/MOM_temperature_convert.F90
index ee4bc21e62..e1cc3b899d 100644
--- a/src/equation_of_state/MOM_temperature_convert.F90
+++ b/src/equation_of_state/MOM_temperature_convert.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Functions to convert between conservative and potential temperature
module MOM_temperature_convert
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public poTemp_to_consTemp, consTemp_to_poTemp
diff --git a/src/framework/MOM_ANN.F90 b/src/framework/MOM_ANN.F90
new file mode 100644
index 0000000000..3086f4e92e
--- /dev/null
+++ b/src/framework/MOM_ANN.F90
@@ -0,0 +1,738 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+!> Implements the general purpose Artificial Neural Network (ANN).
+module MOM_ANN
+
+! This file is part of MOM6. See LICENSE.md for the license
+
+use MOM_io, only : MOM_read_data, field_exists
+use MOM_error_handler, only : MOM_error, FATAL, MOM_mesg
+use numerical_testing_type, only : testing
+
+implicit none ; private
+
+!#include
+
+public ANN_init, ANN_allocate, ANN_apply, ANN_end, ANN_unit_tests
+public ANN_apply_vector_orig, ANN_apply_vector_oi, ANN_apply_array_sio
+public set_layer, set_input_normalization, set_output_normalization
+public ANN_random, randomize_layer
+
+!> Applies ANN to x, returning results in y
+interface ANN_apply
+ module procedure ANN_apply_vector_oi
+ module procedure ANN_apply_array_sio
+end interface ANN_apply
+
+!> Type for a single Linear layer of ANN,
+!! i.e. stores the matrix A and bias b
+!! for matrix-vector multiplication
+!! y = A*x + b.
+type, private :: layer_type ; private
+ integer :: output_width !< Number of rows in matrix A
+ integer :: input_width !< Number of columns in matrix A
+ logical :: activation = .True. !< If true, apply the default activation function
+
+ real, allocatable :: A(:,:) !< Matrix in column-major order
+ !! of size A(output_width, input_width) [nondim]
+ real, allocatable :: b(:) !< bias vector of size output_width [nondim]
+end type layer_type
+
+!> Control structure/type for ANN
+type, public :: ANN_CS ; private
+ ! Parameters
+ integer :: num_layers !< Number of layers in the ANN, including the input and output.
+ !! For example, for ANN with one hidden layer, num_layers = 3.
+ integer, allocatable &
+ :: layer_sizes(:) !< Array of length num_layers, storing the number of neurons in
+ !! each layer.
+
+ type(layer_type), allocatable &
+ :: layers(:) !< Array of length num_layers-1, where each element is the Linear
+ !! transformation between layers defined by Matrix A and vias b.
+
+ real, allocatable :: &
+ input_means(:), & !< Array of length layer_sizes(1) containing the mean of each input feature
+ !! prior to normalization by input_norms [arbitrary].
+ input_norms(:), & !< Array of length layer_sizes(1) containing the *inverse* of the standard
+ !! deviation for each input feature used to normalize (multiply) before
+ !! feeding into the ANN [arbitrary]
+ output_means(:), & !< Array of length layer_sizes(num_layers) containing the mean of each
+ !! output prior to normalization by output_norms [arbitrary].
+ output_norms(:) !< Array of length layer_sizes(num_layers) containing the standard deviation
+ !! each output of the ANN will be multiplied [arbitrary]
+
+ integer, public :: parameters = 0 !< Count of number of parameters
+end type ANN_CS
+
+contains
+
+!> Initialization of ANN. Allocates memory and reads ANN parameters from NetCDF file.
+!! The NetCDF file must contain:
+!! Integer num_layers.
+!! Integer arrays: layer_sizes, input_norms, output_norms
+!! Matrices and biases for Linear layers can be Real(4) or Real(8) and
+!! are named as: A0, b0 for the first layer; A1, b1 for the second layer and so on.
+subroutine ANN_init(CS, NNfile)
+ type(ANN_CS), intent(inout) :: CS !< ANN control structure.
+ character(*), intent(in) :: NNfile !< The name of NetCDF file having neural network parameters
+ ! Local variables
+ integer :: i
+ integer :: num_layers ! Number of layers, including input and output layers
+ integer, allocatable :: layer_sizes(:) ! Number of neurons in each layer
+ character(len=1) :: layer_num_str
+ character(len=3) :: fieldname
+
+ call MOM_mesg('ANN: init from ' // trim(NNfile), 2)
+
+ ! Read the number of layers
+ call MOM_read_data(NNfile, "num_layers", num_layers)
+
+ ! Read size of layers
+ allocate( layer_sizes(num_layers) )
+ call MOM_read_data(NNfile, "layer_sizes", layer_sizes)
+
+ ! Allocates the memory for storing normalization, weights and biases
+ call ANN_allocate(CS, num_layers, layer_sizes)
+ deallocate( layer_sizes )
+
+ ! Read normalization factors
+ if (field_exists(NNfile, 'input_means')) &
+ call MOM_read_data(NNfile, 'input_means', CS%input_means)
+ if (field_exists(NNfile, 'input_norms')) then
+ call MOM_read_data(NNfile, 'input_norms', CS%input_norms)
+ ! We calculate the reciprocal here to avoid repeated divisions later
+ CS%input_norms(:) = 1. / CS%input_norms(:)
+ endif
+ if (field_exists(NNfile, 'output_means')) &
+ call MOM_read_data(NNfile, 'output_means', CS%output_means)
+ if (field_exists(NNfile, 'output_norms')) &
+ call MOM_read_data(NNfile, 'output_norms', CS%output_norms)
+
+ ! Allocate and read matrix A and bias b for each layer
+ do i = 1,CS%num_layers-1
+ CS%layers(i)%input_width = CS%layer_sizes(i)
+ CS%layers(i)%output_width = CS%layer_sizes(i+1)
+
+ ! Reading matrix A
+ write(layer_num_str, '(I0)') i-1
+ fieldname = trim('A') // trim(layer_num_str)
+ call MOM_read_data(NNfile, fieldname, CS%layers(i)%A, &
+ (/1,1,1,1/),(/CS%layers(i)%output_width,CS%layers(i)%input_width,1,1/))
+
+ ! Reading bias b
+ fieldname = trim('b') // trim(layer_num_str)
+ call MOM_read_data(NNfile, fieldname, CS%layers(i)%b)
+ enddo
+
+ ! No activation function for the last layer
+ CS%layers(CS%num_layers-1)%activation = .False.
+
+ if (field_exists(NNfile, 'x_test') .and. field_exists(NNfile, 'y_test') ) &
+ call ANN_test(CS, NNfile)
+
+ call MOM_mesg('ANN: have been read from ' // trim(NNfile), 2)
+
+end subroutine ANN_init
+
+!> Allocate an ANN
+!!
+!! This creates the memory for storing weights and intermediate work arrays, but does not set
+!! the values of weights or biases (not even initializing with zeros).
+subroutine ANN_allocate(CS, num_layers, layer_sizes)
+ type(ANN_CS), intent(inout) :: CS !< ANN control structure
+ integer, intent(in) :: num_layers !< The number of layers, including the input and output layer
+ integer, intent(in) :: layer_sizes(num_layers) !< The number of neurons in each layer
+ ! Local variables
+ integer :: l ! Layer number
+
+ ! Assert that there is always an input and output layer
+ if (num_layers < 2) call MOM_error(FATAL, "The number of layers in an ANN must be >=2")
+
+ CS%num_layers = num_layers
+
+ ! Layers
+ allocate( CS%layer_sizes(CS%num_layers) )
+ CS%layer_sizes(:) = layer_sizes(:)
+
+ ! Input and output normalization values
+ allocate( CS%input_means(CS%layer_sizes(1)), source=0. ) ! Assume zero mean by default
+ allocate( CS%input_norms(CS%layer_sizes(1)), source=1. ) ! Assume unit variance by default
+ allocate( CS%output_means(CS%layer_sizes(CS%num_layers)), source=0. ) ! Assume zero mean by default
+ allocate( CS%output_norms(CS%layer_sizes(CS%num_layers)), source=1. ) ! Assume unit variance by default
+
+ ! Allocate the Linear transformations between layers
+ allocate(CS%layers(CS%num_layers-1))
+ CS%parameters = 2 * CS%layer_sizes(1) ! For input normalization
+
+ ! Allocate matrix A and bias b for each layer
+ do l = 1, CS%num_layers-1
+ CS%layers(l)%input_width = CS%layer_sizes(l)
+ CS%layers(l)%output_width = CS%layer_sizes(l+1)
+
+ allocate( CS%layers(l)%A(CS%layers(l)%output_width, CS%layers(l)%input_width) )
+ allocate( CS%layers(l)%b(CS%layers(l)%output_width) )
+
+ CS%parameters = CS%parameters &
+ + CS%layer_sizes(l) * CS%layer_sizes(l+1) & ! For weights
+ + CS%layer_sizes(l+1) ! For bias
+ enddo
+ CS%parameters = CS%parameters &
+ + 2 * CS%layer_sizes(CS%num_layers) ! For output normalization
+
+end subroutine ANN_allocate
+
+!> Test ANN by comparing the prediction with the test data.
+subroutine ANN_test(CS, NNfile)
+ type(ANN_CS), intent(inout) :: CS !< ANN control structure.
+ character(*), intent(in) :: NNfile !< The name of NetCDF file having neural network parameters
+ ! Local variables
+ real, dimension(:), allocatable :: x_test, y_test, y_pred ! [arbitrary]
+ real :: relative_error ! [arbitrary]
+ character(len=200) :: relative_error_str
+
+ ! Allocate data
+ allocate(x_test(CS%layer_sizes(1)))
+ allocate(y_test(CS%layer_sizes(CS%num_layers)))
+ allocate(y_pred(CS%layer_sizes(CS%num_layers)))
+
+ ! Read test vectors
+ call MOM_read_data(NNfile, 'x_test', x_test)
+ call MOM_read_data(NNfile, 'y_test', y_test)
+
+ ! Compute prediction
+ call ANN_apply_vector_oi(x_test, y_pred, CS)
+
+ relative_error = maxval(abs(y_pred(:) - y_test(:))) / maxval(abs(y_test(:)))
+
+ if (relative_error > 1e-5) then
+ write(relative_error_str, '(ES12.4)') relative_error
+ call MOM_error(FATAL, 'Relative error in ANN prediction is too large: ' // trim(relative_error_str))
+ endif
+
+ deallocate(x_test)
+ deallocate(y_test)
+ deallocate(y_pred)
+end subroutine ANN_test
+
+!> Deallocates memory of ANN
+subroutine ANN_end(CS)
+ type(ANN_CS), intent(inout) :: CS !< ANN control structure.
+ ! Local variables
+ integer :: i
+
+ deallocate(CS%layer_sizes)
+ deallocate(CS%input_means)
+ deallocate(CS%input_norms)
+ deallocate(CS%output_means)
+ deallocate(CS%output_norms)
+
+ do i = 1, CS%num_layers-1
+ deallocate(CS%layers(i)%A)
+ deallocate(CS%layers(i)%b)
+ enddo
+ deallocate(CS%layers)
+
+end subroutine ANN_end
+
+!> The default activation function
+pure elemental function activation_fn(x) result (y)
+ real, intent(in) :: x !< Scalar input value [nondim]
+ real :: y !< Scalar output value [nondim]
+
+ y = max(x, 0.0) ! ReLU activation
+
+end function activation_fn
+
+!> Single application of ANN inference using vector input and output
+!!
+!! This implementation is the simplest using allocation and de-allocation
+!! of temporary arrays
+subroutine ANN_apply_vector_orig(x, y, CS)
+ type(ANN_CS), intent(in) :: CS !< ANN instance
+ real, intent(in) :: x(CS%layer_sizes(1)) !< Inputs [arbitrary]
+ real, intent(inout) :: y(CS%layer_sizes(CS%num_layers)) !< Outputs [arbitrary]
+ ! Local variables
+ real, allocatable :: x_1(:), x_2(:) ! intermediate states [nondim]
+ integer :: i, o ! Input, output indices
+
+ ! Normalize input
+ allocate(x_1(CS%layer_sizes(1)))
+ do i = 1,CS%layer_sizes(1)
+ x_1(i) = ( x(i) - CS%input_means(i) ) * CS%input_norms(i)
+ enddo
+
+ ! Apply Linear layers
+ do i = 1, CS%num_layers-1
+ allocate(x_2(CS%layer_sizes(i+1)))
+ call layer_apply_orig(x_1, x_2, CS%layers(i))
+ deallocate(x_1)
+ allocate(x_1(CS%layer_sizes(i+1)))
+ x_1(:) = x_2(:)
+ deallocate(x_2)
+ enddo
+
+ ! Un-normalize output
+ do o = 1, CS%layer_sizes(CS%num_layers)
+ y(o) = ( x_1(o) * CS%output_norms(o) ) + CS%output_means(o)
+ enddo
+
+ deallocate(x_1)
+
+ contains
+
+ !> Applies linear layer to input data x and stores the result in y with
+ !! y = A*x + b with optional application of the activation function so the
+ !! overall operations is ReLU(A*x + b)
+ subroutine layer_apply_orig(x, y, layer)
+ type(layer_type), intent(in) :: layer !< Linear layer
+ real, intent(in) :: x(layer%input_width) !< Input vector [nondim]
+ real, intent(inout) :: y(layer%output_width) !< Output vector [nondim]
+ ! Local variables
+ integer :: i, o ! Input, output indices
+
+ ! Add bias
+ y(:) = layer%b(:)
+ ! Multiply by kernel
+ do i=1,layer%input_width
+ do o=1,layer%output_width
+ y(o) = y(o) + x(i) * layer%A(o, i)
+ enddo
+ enddo
+ ! Apply activation function
+ if (layer%activation) y(:) = activation_fn(y(:))
+
+ end subroutine layer_apply_orig
+end subroutine ANN_apply_vector_orig
+
+!> Single application of ANN inference using vector input and output
+!!
+!! This implementation avoids repeated reallocation of work arrays and uses the
+!! output index for the fastest (inner-most) loop in the layer matrix multiply.
+subroutine ANN_apply_vector_oi(x, y, CS)
+ type(ANN_CS), intent(in) :: CS !< ANN instance
+ real, intent(in) :: x(CS%layer_sizes(1)) !< Inputs [arbitrary]
+ real, intent(inout) :: y(CS%layer_sizes(CS%num_layers)) !< Outputs [arbitrary]
+ ! Local variables
+ real, allocatable :: x_1(:), x_2(:) ! intermediate states [nondim]
+ integer :: i, o ! Input, output indices
+
+ allocate( x_1( maxval( CS%layer_sizes(:) ) ) )
+ allocate( x_2( maxval( CS%layer_sizes(:) ) ) )
+
+ ! Normalize input
+ do i = 1,CS%layer_sizes(1)
+ x_1(i) = ( x(i) - CS%input_means(i) ) * CS%input_norms(i)
+ enddo
+
+ ! Apply Linear layers
+ do i = 1, CS%num_layers-2, 2
+ call layer_apply_oi(x_1, x_2, CS%layers(i))
+ call layer_apply_oi(x_2, x_1, CS%layers(i+1))
+ enddo
+ if (mod(CS%num_layers,2)==0) then
+ call layer_apply_oi(x_1, x_2, CS%layers(CS%num_layers-1))
+ ! Un-normalize output
+ do o = 1, CS%layer_sizes(CS%num_layers)
+ y(o) = x_2(o) * CS%output_norms(o) + CS%output_means(o)
+ enddo
+ else
+ ! Un-normalize output
+ do o = 1, CS%layer_sizes(CS%num_layers)
+ y(o) = x_1(o) * CS%output_norms(o) + CS%output_means(o)
+ enddo
+ endif
+
+ deallocate(x_1, x_2)
+
+ contains
+
+ !> Applies linear layer to input data x and stores the result in y with
+ !! y = A*x + b with optional application of the activation function so the
+ !! overall operations is ReLU(A*x + b)
+ subroutine layer_apply_oi(x, y, layer)
+ type(layer_type), intent(in) :: layer !< Linear layer
+ real, intent(in) :: x(layer%input_width) !< Input vector [nondim]
+ real, intent(inout) :: y(layer%output_width) !< Output vector [nondim]
+ ! Local variables
+ integer :: i, o ! Input, output indices
+
+ ! Add bias
+ y(:) = layer%b(:)
+ ! Multiply by kernel
+ do i=1,layer%input_width
+ do o=1,layer%output_width
+ y(o) = y(o) + x(i) * layer%A(o, i)
+ enddo
+ enddo
+ ! Apply activation function
+ if (layer%activation) y(:) = activation_fn(y(:))
+
+ end subroutine layer_apply_oi
+end subroutine ANN_apply_vector_oi
+
+!> Single application of ANN inference using array input and output
+!! with (space,feature) indexing
+!!
+!! This implementation uses the space index for the fastest (inner-most) loop
+!! in the layer matrix multiply, with the input index as the next fastest loop,
+!! and uses the weights matrix A(output,index). It also applies the activation
+!! function within the outer loop of the matrix multiply.
+subroutine ANN_apply_array_sio(nij, x, y, CS)
+ type(ANN_CS), intent(in) :: CS !< ANN control structure
+ integer, intent(in) :: nij !< Size of spatial dimension
+ real, intent(in) :: x(nij, CS%layer_sizes(1)) !< input [arbitrary]
+ real, intent(inout) :: y(nij, CS%layer_sizes(CS%num_layers)) !< output [arbitrary]
+ ! Local variables
+ real, allocatable :: x_1(:,:), x_2(:,:) ! intermediate states [nondim]
+ integer :: l, i, o ! Layer, input, output index
+
+ allocate( x_1( nij, maxval( CS%layer_sizes(:) ) ) )
+ allocate( x_2( nij, maxval( CS%layer_sizes(:) ) ) )
+
+ ! Normalize input
+ do i = 1, CS%layer_sizes(1)
+ x_1(:,i) = ( x(:,i) - CS%input_means(i) ) * CS%input_norms(i)
+ enddo
+
+ ! Apply Linear layers
+ do l = 1, CS%num_layers-2, 2
+ call layer_apply_sio(nij, x_1, x_2, CS%layers(l))
+ call layer_apply_sio(nij, x_2, x_1, CS%layers(l+1))
+ enddo
+ if (mod(CS%num_layers,2)==0) then
+ call layer_apply_sio(nij, x_1, x_2, CS%layers(CS%num_layers-1))
+ ! Un-normalize output
+ do o = 1, CS%layer_sizes(CS%num_layers)
+ y(:,o) = x_2(:,o) * CS%output_norms(o) + CS%output_means(o)
+ enddo
+ else
+ ! Un-normalize output
+ do o = 1, CS%layer_sizes(CS%num_layers)
+ y(:,o) = x_1(:,o) * CS%output_norms(o) + CS%output_means(o)
+ enddo
+ endif
+
+ deallocate(x_1, x_2)
+
+ contains
+
+ !> Applies linear layer to input data x and stores the result in y with
+ !! y = A*x + b with optional application of the activation function so the
+ !! overall operations is ReLU(A*x + b)
+ subroutine layer_apply_sio(nij, x, y, layer)
+ type(layer_type), intent(in) :: layer !< Linear layer
+ integer, intent(in) :: nij !< Size of spatial dimension
+ real, intent(in) :: x(nij, layer%input_width) !< Input vector [nondim]
+ real, intent(inout) :: y(nij, layer%output_width) !< Output vector [nondim]
+ ! Local variables
+ integer :: i, o ! Input, output indices
+
+ do o = 1, layer%output_width
+ ! Add bias
+ y(:,o) = layer%b(o)
+ ! Multiply by kernel
+ do i = 1, layer%input_width
+ y(:,o) = y(:,o) + x(:,i) * layer%A(o, i)
+ enddo
+ ! Apply activation function
+ if (layer%activation) y(:,o) = activation_fn(y(:,o))
+ enddo
+
+ end subroutine layer_apply_sio
+end subroutine ANN_apply_array_sio
+
+!> Sets weights and bias for a single layer
+subroutine set_layer(ANN, layer, weights, biases, activation)
+ type(ANN_CS), intent(inout) :: ANN !< ANN control structure
+ integer, intent(in) :: layer !< The number of the layer being adjusted
+ real, intent(in) :: weights(:,:) !< The weights to assign
+ real, intent(in) :: biases(:) !< The biases to assign
+ logical, intent(in) :: activation !< Turn on the activation function
+
+ if ( layer >= ANN%num_layers ) &
+ call MOM_error(FATAL, "MOM_ANN, set_layer: layer is out of range")
+ if ( layer < 1 ) &
+ call MOM_error(FATAL, "MOM_ANN, set_layer: layer should be >= 1")
+
+ if ( size(biases) /= size(ANN%layers(layer)%b) ) &
+ call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of biases")
+ ANN%layers(layer)%b(:) = biases(:)
+
+ if ( size(weights,1) /= size(ANN%layers(layer)%A,1) ) &
+ call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of weights (first dim)")
+ if ( size(weights,2) /= size(ANN%layers(layer)%A,2) ) &
+ call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of weights (second dim)")
+ ANN%layers(layer)%A(:,:) = weights(:,:)
+
+ ANN%layers(layer)%activation = activation
+end subroutine set_layer
+
+!> Sets input normalization
+subroutine set_input_normalization(ANN, means, norms)
+ type(ANN_CS), intent(inout) :: ANN !< ANN control structure
+ real, optional, intent(in) :: means(:) !< The mean of each input
+ real, optional, intent(in) :: norms(:) !< The standard deviation of each input
+
+ if (present(means)) then
+ if ( size(means) /= size(ANN%input_means) ) &
+ call MOM_error(FATAL, "MOM_ANN, set_input_normalization: mismatch in size of means")
+ ANN%input_means(:) = means(:)
+ endif
+
+ if (present(norms)) then
+ if ( size(norms) /= size(ANN%input_norms) ) &
+ call MOM_error(FATAL, "MOM_ANN, set_input_normalization: mismatch in size of norms")
+ ANN%input_norms(:) = norms(:)
+ endif
+
+end subroutine set_input_normalization
+
+!> Sets output normalization
+subroutine set_output_normalization(ANN, means, norms)
+ type(ANN_CS), intent(inout) :: ANN !< ANN control structure
+ real, optional, intent(in) :: means(:) !< The mean of each output
+ real, optional, intent(in) :: norms(:) !< The standard deviation of each output
+
+ if (present(means)) then
+ if ( size(means) /= size(ANN%output_means) ) &
+ call MOM_error(FATAL, "MOM_ANN, set_output_normalization: mismatch in size of means")
+ ANN%output_means(:) = means(:)
+ endif
+
+ if (present(norms)) then
+ if ( size(norms) /= size(ANN%output_norms) ) &
+ call MOM_error(FATAL, "MOM_ANN, set_output_normalization: mismatch in size of norms")
+ ANN%output_norms(:) = norms(:)
+ endif
+
+end subroutine set_output_normalization
+
+!> Create a random ANN
+subroutine ANN_random(ANN, nlayers, widths)
+ type(ANN_CS), intent(inout) :: ANN !< ANN control structure
+ integer, intent(in) :: nlayers !< Number of layers
+ integer, intent(in) :: widths(nlayers) !< Width of each layer
+ ! Local variables
+ integer :: l
+
+ call ANN_allocate(ANN, nlayers, widths)
+
+ do l = 1, nlayers-1
+ call randomize_layer(ANN, nlayers, l, widths)
+ enddo
+
+end subroutine ANN_random
+
+!> Fill a layer with random numbers
+subroutine randomize_layer(ANN, nlayers, layer, widths)
+ type(ANN_CS), intent(inout) :: ANN !< ANN control structure
+ integer, intent(in) :: nlayers !< Number of layers
+ integer, intent(in) :: layer !< Layer number to randomize
+ integer, intent(in) :: widths(nlayers) !< Width of each layer
+ ! Local variables
+ real :: weights(widths(layer+1),widths(layer)) ! Weights
+ real :: biases(widths(layer+1)) ! Biases
+
+ call random_number(weights)
+ weights(:,:) = 2. * weights(:,:) - 1.
+
+ call random_number(biases)
+ biases(:) = 2. * biases(:) - 1.
+
+ call set_layer(ANN, layer, weights, biases, layer Runs unit tests on ANN functions.
+!!
+!! Should only be called from a single/root thread.
+!! Returns True if a test fails, otherwise False.
+logical function ANN_unit_tests(verbose)
+ logical, intent(in) :: verbose !< If true, write results to stdout
+ ! Local variables
+ type(ANN_CS) :: ANN ! An ANN
+ type(testing) :: test ! Manage tests
+ real, allocatable :: x(:), y(:), y_good(:), x2(:,:), y2(:,:) ! Inputs, outputs [arbitrary]
+ integer, parameter :: max_rand_nlay = 10 ! Deepest random ANN to generate
+ integer :: widths(max_rand_nlay) ! Number of layers for random ANN
+ integer :: nlay ! Number of layers for random ANN
+ integer :: i, iter ! Loop counters
+ logical :: rand_res ! Status of random tests
+
+ ANN_unit_tests = .false. ! Start by assuming all is well
+ call test%set(verbose=verbose) ! Pass verbose mode to test
+
+ ! Identity ANN for one input
+ allocate( y(1) )
+ call ANN_allocate(ANN, 2, [1,1])
+ call set_layer(ANN, 1, reshape([1.],[1,1]), [0.], .false.)
+ call ANN_apply([1.], y, ANN)
+ call test%real_scalar(y(1), 1., 'Scalar identity')
+ deallocate( y )
+ call ANN_end(ANN)
+
+ ! Summation ANN
+ allocate( y(1) )
+ call ANN_allocate(ANN, 2, [4,1])
+ call set_layer(ANN, 1, reshape([1.,1.,1.,1.], [1,4]), [0.], .false.)
+ call ANN_apply([-1.,0.,1.,2.], y, ANN)
+ call test%real_scalar(y(1), 2., 'Summation')
+ deallocate( y )
+ call ANN_end(ANN)
+
+ ! Identity ANN for vector input/output
+ call ANN_allocate(ANN, 2, [3,3])
+ allocate( y(3) )
+ call set_layer(ANN, 1, reshape([1.,0.,0., &
+ 0.,1.,0., &
+ 0.,0.,1.], [3,3]), [0.,0.,0.], .false.)
+ call ANN_apply([-1.,0.,1.], y, ANN)
+ call test%real_arr(3, y, [-1.,0.,1.], 'Vector identity')
+ deallocate( y )
+ call ANN_end(ANN)
+
+ ! Rectifying ANN for vector input/output
+ allocate( y(3) )
+ call ANN_allocate(ANN, 2, [3,3])
+ call set_layer(ANN, 1, reshape([1.,0.,0., &
+ 0.,1.,0., &
+ 0.,0.,1.], [3,3]), [0.,0.,0.], .true.)
+ call ANN_apply([-1.,0.,1.], y, ANN)
+ call test%real_arr(3, y, [0.,0.,1.], 'Rectifier')
+ deallocate( y )
+ call ANN_end(ANN)
+
+ ! The next 3 tests re-use the same network with 4 inputs, a 4-wide hidden layer, and one output
+ allocate( y(1) )
+ call ANN_allocate(ANN, 3, [4,4,1])
+
+ ! 1 hidden layer: rectifier followed by summation
+ ! Inputs: [-1,0,1,2]
+ ! Rectified: [0,0,1,2]
+ ! Sum: 3
+ ! Outputs: 3
+ call set_layer(ANN, 1, reshape([1.,0.,0.,0., &
+ 0.,1.,0.,0., &
+ 0.,0.,1.,0., &
+ 0.,0.,0.,1.], [4,4]), [0.,0.,0.,0.], .true.)
+ call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [0.], .false.)
+ call ANN_apply_vector_orig([-1.,0.,1.,2.], y, ANN)
+ call test%real_scalar(y(1), 3., 'Rectifier+summation')
+
+ ! as above but with biases
+ ! Inputs: [-2,-1,0,1]
+ ! After bias: [-1,0,1,2] with b=1
+ ! Rectified: [0,0,1,2]
+ ! Sum: 3
+ ! After bias: 6 with b=3
+ ! Outputs: 6
+ call set_layer(ANN, 1, reshape([1.,0.,0.,0., &
+ 0.,1.,0.,0., &
+ 0.,0.,1.,0., &
+ 0.,0.,0.,1.], [4,4]), [1.,1.,1.,1.], .true.)
+ call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [3.], .false.)
+ call ANN_apply_vector_orig([-2.,-1.,0.,1.], y, ANN)
+ call test%real_scalar(y(1), 6., 'Rectifier+summation+bias')
+
+ ! as above but with normalization of inputs and outputs
+ ! Inputs: [0,2,4,6]
+ ! Normalized inputs: [-2,-1,0,1] (using mean=-4, norm=2)
+ ! Normalized outputs: 6
+ ! De-normalized output: 2 (using mean=-10, norm=2)
+ call set_input_normalization(ANN, means=[4.,4.,4.,4.], norms=[0.5,0.5,0.5,0.5])
+ call set_output_normalization(ANN, norms=[2.], means=[-10.])
+ call ANN_apply_vector_orig([0.,2.,4.,6.], y, ANN)
+ call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms')
+
+ deallocate( y )
+ call ANN_end(ANN)
+
+ ! as above with a 1x1 4th identity layer (to check loop combinations)
+ allocate( y(1) )
+ call ANN_allocate(ANN, 4, [4,4,1,1])
+ call set_layer(ANN, 1, reshape([1.,0.,0.,0., &
+ 0.,1.,0.,0., &
+ 0.,0.,1.,0., &
+ 0.,0.,0.,1.], [4,4]), [1.,1.,1.,1.], .true.)
+ call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [3.], .false.)
+ call set_layer(ANN, 3, reshape([1.],[1,1]), [0.], .false.)
+ call set_input_normalization(ANN, means=[4.,4.,4.,4.], norms=[0.5,0.5,0.5,0.5])
+ call set_output_normalization(ANN, norms=[2.], means=[-10.])
+ call ANN_apply_vector_orig([0.,2.,4.,6.], y, ANN)
+ call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms 4-layer')
+
+ ! as above with v2 of ANN_apply
+ call ANN_apply_vector_oi([0.,2.,4.,6.], y, ANN)
+ call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms 4-layer v2')
+ deallocate( y )
+
+ allocate( y2(1,2) )
+ ! as above with v5 of ANN_apply applied to 2d inputs, x(space,feature)
+ call ANN_apply_array_sio(2, reshape([0.,1.,2.,3.,4.,5.,6.,7.],[2,4]), y2, ANN)
+ call test%real_arr(2, y2, [2.,5.], 'Rectifier+summation+bias+norms 4-layer array v2')
+ deallocate( y2 )
+
+ call ANN_end(ANN)
+
+ ! The following block checks that for random ANN (weights and layers widths)
+ ! each of the various implementations of inference give identical results.
+ ! This helped catch loop and allocation errors.
+ rand_res = .false.
+ do iter = 1, 1000
+ allocate( y(max_rand_nlay+1) )
+ call random_number(y) ! Vector of random numbers 0..1
+ nlay = 2 + floor( y(max_rand_nlay+1) * ( max_rand_nlay - 1 ) ) ! 2 < nlay < max_rand_nlay
+ widths(:) = 1 + floor( y(1:nlay) * 8 ) ! 1 < layer width < 8
+ deallocate( y )
+ call ANN_random(ANN, nlay, widths)
+ allocate( x(widths(1)), y(widths(nlay)), y_good(widths(nlay)) )
+ call ANN_apply_vector_orig(x, y_good, ANN)
+ call ANN_apply_vector_oi(x, y, ANN)
+ rand_res = rand_res .or. maxval( abs( y(:) - y_good(:) ) ) > 0. ! Check results from v2 = v1
+ allocate( x2(20,widths(1)), y2(20,widths(nlay)) ) ! 2D input, output
+ do i = 1, 20
+ x2(i,:) = x(:)
+ enddo
+ call ANN_apply_array_sio(20, x2, y2, ANN)
+ rand_res = rand_res .or. maxval( abs( maxval(y2(:,:),1) - y_good(:) ) ) > 0. ! Check results from array v2 = v1
+ rand_res = rand_res .or. maxval( abs( minval(y2(:,:),1) - y_good(:) ) ) > 0. ! Check results from array v2 = v1
+ deallocate( x, y, y_good, x2, y2 )
+ call ANN_end(ANN)
+ enddo
+ call test%test(rand_res, 'Equivalence between inference variants with random results')
+
+ ANN_unit_tests = test%summarize('ANN_unit_tests')
+
+end function ANN_unit_tests
+
+!> \namespace mom_ann
+!!
+!! The mom_ann module is a pure fortran implementation of fully-connected feed-forward
+!! networks to facilitate easy evaluation of data-driven functions in MOM6. For performant
+!! implementations or for novel architectires, using machine-learning libraries (e.g. via
+!! mom_database_comms) are necessary, or at least likely to be more efficient.
+!!
+!! The artificial neural network (ANN) understood by this MOM6 module has \f$ N \f$ layers,
+!! including the input-layer and output-layer, thus requireing \f$ N \geq 2\f$.
+!!
+!! The output values (neurons or nodes) of any layer other than the input layer (i.e. \f$ l>1 \f$) are
+!! \f[
+!! y_{l,j} = f_l( b_{l,j} + A_{l,j,i} x_{l-1,i} )
+!! \f]
+!! where \f$ f(x) = max(0, x) \f$ is the ReLU activation function, \f$b_{l,j}\f$ is a bias for each neuron,
+!! \f$A_{l,j,i}\f$ are a rectangular matrix of weights for each layer, and \f$x_{l-1,i}\f$ are the outputs
+!! of the previous layer, \f$l-1\f$. The subscript on \f$ f_l() \f$ indicates the activation function is
+!! optional for each layer.
+!!
+!! Currently, the performance of various implementations is dependent on the shape/size of the network and
+!! the size of input data. For this reason we provide several versions that all yield the same result but
+!! for differently shaped inputs.
+!!
+!! \image html https://upload.wikimedia.org/wikipedia/commons/4/46/Colored_neural_network.svg
+!! Fig: A three layer network with 3 inputs, 2 outputs, and 1 hidden layer. There are two rectanglar
+!! matrices of weights (black arrows). The bias for each neuron is implied."
+
+end module MOM_ANN
diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90
index 66c9925f11..5b59220ba1 100644
--- a/src/framework/MOM_array_transform.F90
+++ b/src/framework/MOM_array_transform.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Module for supporting the rotation of a field's index map.
!! The implementation of each angle is described below.
!!
@@ -10,15 +14,22 @@
!!
!! 90 degree rotations change the shape of the field, and are handled
!! separately from 180 degree rotations.
+!!
+!! It also provides the symmetric_sum functions to do a rotationally invariant
+!! sum of the contents of a 1d or 2d array.
module MOM_array_transform
+use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit
+
implicit none ; private
public rotate_array
public rotate_array_pair
public rotate_vector
public allocate_rotated_array
+public symmetric_sum
+public symmetric_sum_unit_tests
!> Rotate the elements of an array to the rotated set of indices.
@@ -58,8 +69,7 @@ module MOM_array_transform
end interface rotate_vector
-!> Allocate an array based on the rotated index map of an unrotated reference
-!! array.
+!> Allocate an array based on the rotated index map of an unrotated reference array.
interface allocate_rotated_array
module procedure allocate_rotated_array_real_2d
module procedure allocate_rotated_array_real_3d
@@ -67,6 +77,13 @@ module MOM_array_transform
module procedure allocate_rotated_array_integer
end interface allocate_rotated_array
+
+!> Return a rotationally symmetric sum of the elements of an array.
+interface symmetric_sum
+ module procedure symmetric_sum_1d, symmetric_sum_2d
+end interface symmetric_sum
+
+
contains
!> Rotate the elements of a 2d real array along first and second axes.
@@ -354,4 +371,206 @@ subroutine allocate_rotated_array_integer(A_in, lb, turns, A)
endif
end subroutine allocate_rotated_array_integer
+
+!> Do a rotationally symmetric sum of a 1-d array
+function symmetric_sum_1d(field) result(sum)
+ real, dimension(1:), intent(in) :: field !< The field to sum in arbitrary units [A ~> a]
+ real :: sum !< The rotationally symmetric sum of the entries in field [A ~> a]
+
+ ! Local variables
+ integer :: i, szi, szi_2
+
+ szi = size(field, 1)
+ szi_2 = szi / 2 ! Note that for an odd number szi_2 is rounded down.
+ sum = 0.0
+ if (2*szi_2 < szi) sum = field(szi_2+1)
+ ! Add pairs of values, working from the inside out.
+ do i=szi_2,1,-1
+ sum = sum + (field(i) + field(szi+1-i))
+ enddo
+end function symmetric_sum_1d
+
+
+!> Do a rotationally symmetric sum of a 2-d array using a recursive "Union-Jack" pattern of addition.
+recursive function symmetric_sum_2d(field) result(sum)
+ real, dimension(1:,1:), intent(in) :: field !< The field to sum in arbitrary units [A ~> a]
+ real :: sum !< The rotationally symmetric sum of the entries in field [A ~> a]
+
+ ! Local variables
+ real :: quad_sum(2,2) ! The sums in each of the quadrants [A ~> a]
+ logical :: odd_i, odd_j
+ integer :: ij, szi, szj, szi_2, szj_2, ic, jc
+
+ szi = size(field, 1) ; szj = size(field, 2)
+ ! These 5 special cases are equivalent to the general case, but they reduce the use
+ ! of complicated logic for common simple cases.
+ if ((szi == 1) .and. (szj == 1)) then
+ sum = field(1,1)
+ elseif ((szi == 2) .and. (szj == 2)) then
+ sum = (field(1,1) + field(2,2)) + (field(2,1) + field(1,2))
+ elseif ((szi == 3) .and. (szj == 3)) then
+ sum = (field(2,2) + ((field(1,2) + field(3,2)) + (field(2,1) + field(2,3)))) + &
+ ((field(1,1) + field(3,3)) + (field(3,1) + field(1,3)))
+ elseif (szi == 1) then
+ sum = symmetric_sum_1d(field(1,:))
+ elseif (szj == 1) then
+ sum = symmetric_sum_1d(field(:,1))
+ else
+ ! This is the general case.
+ ! Note that for odd numbers szi_2 and szj_2 are rounded down.
+ szi_2 = szi / 2
+ szj_2 = szj / 2
+
+ odd_i = (2*szi_2 < szi) ! This could be (modulo(szi,2) == 1)
+ odd_j = (2*szj_2 < szj)
+ ! Start by finding the sums along the central axes if there are an odd number of points.
+ if (odd_i .and. odd_j) then
+ ic = szi_2+1 ; jc = szj_2+1 ! The index of the central point
+ sum = field(ic,jc)
+ ! Add pairs of pairs of values, working from the inside out.
+ do ij=1,min(szi_2,szj_2)
+ sum = sum + ((field(ic-ij,jc) + field(ic+ij,jc)) + (field(ic,jc-ij) + field(ic,jc+ij)))
+ enddo
+ ! Add extra pairs of values, working from the inside out.
+ if (szi_2 > szj_2) then
+ do ij=szj_2+1,szi_2
+ sum = sum + (field(ic-ij,jc) + field(ic+ij,jc))
+ enddo
+ elseif (szj_2 > szi_2) then
+ do ij=szi_2+1,szj_2
+ sum = sum + (field(ic,jc-ij) + field(ic,jc+ij))
+ enddo
+ endif
+ elseif (odd_i) then
+ sum = symmetric_sum_1d(field(szi_2+1,1:szj))
+ elseif (odd_j) then
+ sum = symmetric_sum_1d(field(1:szi,szj_2+1))
+ else
+ sum = 0.0
+ endif
+
+ ! Find the sums in the four quadrants of the array.
+ if ((szi_2 > 1) .and. (szj_2 > 1)) then
+ ! Use a recursive call to symmetric_sum_2d to determine the sums in the corner quadrants.
+ quad_sum(1,1) = symmetric_sum_2d(field(1:szi_2,1:szj_2))
+ quad_sum(2,1) = symmetric_sum_2d(field(szi+1-szi_2:szi,1:szj_2))
+ quad_sum(1,2) = symmetric_sum_2d(field(1:szi_2,szj+1-szj_2:szj))
+ quad_sum(2,2) = symmetric_sum_2d(field(szi+1-szi_2:szi,szj+1-szj_2:szj))
+ elseif (szi_2 > 1) then
+ quad_sum(1,1) = symmetric_sum_1d(field(1:szi_2,1))
+ quad_sum(2,1) = symmetric_sum_1d(field(szi+1-szi_2:szi,1))
+ quad_sum(1,2) = symmetric_sum_1d(field(1:szi_2,szj))
+ quad_sum(2,2) = symmetric_sum_1d(field(szi+1-szi_2:szi,szj))
+ elseif (szj_2 > 1) then
+ quad_sum(1,1) = symmetric_sum_1d(field(1,1:szj_2))
+ quad_sum(2,1) = symmetric_sum_1d(field(szi,1:szj_2))
+ quad_sum(1,2) = symmetric_sum_1d(field(1,szj+1-szj_2:szj))
+ quad_sum(2,2) = symmetric_sum_1d(field(szi,szj+1-szj_2:szj))
+ else
+ quad_sum(1,1) = field(1,1)
+ quad_sum(2,1) = field(szi,1)
+ quad_sum(1,2) = field(1,szj)
+ quad_sum(2,2) = field(szi,szj)
+ endif
+
+ sum = sum + ((quad_sum(1,1) + quad_sum(2,2)) + (quad_sum(2,1) + quad_sum(1,2)))
+ endif
+end function symmetric_sum_2d
+
+
+!> Do a naive non-rotationally symmetric sum of a 2-d array. This function is only here for testing.
+function naive_sum_2d(field, abs_val) result(sum)
+ real, dimension(1:,1:), intent(in) :: field !< The field to sum in arbitrary units [A ~> a]
+ logical, optional, intent(in) :: abs_val !< If present and true, sum the absolute values
+ real :: sum !< The rotation dependent sum of the entries in field [A ~> a]
+
+ ! Local variables
+ logical :: sum_abs_val
+ integer :: i, j, szi, szj
+
+ szi = size(field, 1) ; szj = size(field, 2)
+ sum_abs_val = .false. ; if (present(abs_val)) sum_abs_val = abs_val
+ sum = 0.0
+ if (sum_abs_val) then
+ do j=1,szj ; do i=1,szi
+ sum = sum + abs(field(i,j))
+ enddo ; enddo
+ else
+ do j=1,szj ; do i=1,szi
+ sum = sum + field(i,j)
+ enddo ; enddo
+ endif
+end function naive_sum_2d
+
+
+!> Returns true if a unit test of the symmetric sums fails.
+logical function symmetric_sum_unit_tests(verbose)
+ ! Arguments
+ logical, intent(in) :: verbose !< If true, write results to stdout
+ ! Local variables
+ character(len=120) :: fail_message !< Blank or a description of the first failed test.
+ integer, parameter :: sz=13 ! The maximum size of the test arrays
+ real :: array(sz,sz) ! An array of inexact real values for testing in arbitrary units [A]
+ real :: ar_90(sz,sz) ! Array rotated by 90 degrees in arbitrary units [A]
+ real :: ar_180(sz,sz) ! Array rotated by 180 degrees in arbitrary units [A]
+ real :: ar_270(sz,sz) ! Array rotated by 270 degrees in arbitrary units [A]
+ real :: sum(5) ! Different versions of sums over a sub-array [A]
+ real :: abs_sum ! The sum of the absolute values of the array [A]
+ real :: tol ! The tolerance for an inexact test [A]
+
+ character(len=120) :: mesg
+ integer :: i, j, n, m, r
+ logical :: fail
+
+ fail = .false.
+ fail_message = ""
+
+ if (verbose) write(stdout,*) '==== MOM_array_transform: symmetric_sum_unit_tests ===='
+
+ ! Fill the array with real numbers that can not be represented exactly.
+ do j=1,sz ; do i=1,sz
+ array(i,j) = 1.0 / (2.0*(j*sz + i) + 1.0)
+ ! Combining positive and negative numbers amplifies differences from the order of arithmetic.
+ if (modulo(i+j, 2) == 0) array(i,j) = -array(i,j)
+ enddo ; enddo
+ call rotate_array_real_2d(array, 1, ar_90)
+ call rotate_array_real_2d(array, 2, ar_180)
+ call rotate_array_real_2d(array, 3, ar_270)
+
+ do n = 1, sz ; do m = 1, sz
+ sum(1) = symmetric_sum(array(1:n,1:m))
+ sum(2) = symmetric_sum(ar_90(sz+1-m:sz,1:n))
+ sum(3) = symmetric_sum(ar_180(sz+1-n:sz,sz+1-m:sz))
+ sum(4) = symmetric_sum(ar_270(1:m,sz+1-n:sz))
+ sum(5) = naive_sum_2d(array(1:n,1:m))
+ abs_sum = naive_sum_2d(array(1:n,1:m), abs_val=.true.)
+ tol = 2.0 * abs_sum * epsilon(abs_sum)
+ if (abs(sum(1) - sum(5)) > tol) then
+ write(mesg,'(i0," x ",i0," symmetric vs naive sum, sum=",ES13.5," diff=",ES13.5)') &
+ n, m, sum(1), sum(5) - sum(1)
+ write(stdout,*) "Symmetric_sum_failure: "//trim(mesg)
+ write(stderr,*) "Symmetric_sum_failure: "//trim(mesg)
+ if (.not.fail) fail_message = mesg ! This is the first failed test.
+ fail = .true.
+ endif
+ do r = 2, 4 ; if (abs(sum(1) - sum(r)) > 0.0) then
+ write(mesg,'(i0," x ",i0," with ",i0," degree rotation, sum=",ES13.5," diff=",ES13.5)') &
+ n, m, 90*(r-1), sum(1), sum(r) - sum(1)
+ write(stdout,*) "Symmetric_sum_failure: "//trim(mesg)
+ write(stderr,*) "Symmetric_sum_failure: "//trim(mesg)
+ if (.not.fail) fail_message = mesg ! This is the first failed test.
+ fail = .true.
+ endif ; enddo
+ enddo ; enddo
+
+ if (fail) then
+ write(stdout,*) "MOM_array_transform: One or more symmetric sum tests has failed."
+ write(stderr,*) "MOM_array_transform: One or more symmetric sum tests has failed."
+ else
+ if (verbose) write(stdout,*) ("MOM_array_transform: All symmetric sum tests have passed.")
+ endif
+ symmetric_sum_unit_tests = fail
+
+end function symmetric_sum_unit_tests
+
end module MOM_array_transform
diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90
index 8a172ce0c8..123eeeb675 100644
--- a/src/framework/MOM_checksums.F90
+++ b/src/framework/MOM_checksums.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Routines to calculate checksums of various array and vector types
module MOM_checksums
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : rotate_array, rotate_array_pair, rotate_vector
use MOM_array_transform, only : allocate_rotated_array
use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs
@@ -2191,17 +2193,18 @@ end subroutine chksum_v_3d
! into account.
!> chksum1d does a checksum of a 1-dimensional array.
-subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs)
- real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1) [abitrary].
+subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs, logunit)
+ real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1) in arbitrary units [A].
character(len=*), intent(in) :: mesg !< An identifying message.
integer, optional, intent(in) :: start_i !< The starting index for the sum (default 1)
integer, optional, intent(in) :: end_i !< The ending index for the sum (default all)
logical, optional, intent(in) :: compare_PEs !< If true, compare across PEs instead of summing
!! and list the root_PE value (default true)
+ integer, optional, intent(in) :: logunit !< IO unit for checksum logging
- integer :: is, ie, i, bc, sum1, sum_bc
- real :: sum ! The global sum of the array [arbitrary]
- real, allocatable :: sum_here(:) ! The sum on each PE [arbitrary]
+ integer :: is, ie, i, bc, sum1, sum_bc, ioUnit
+ real :: sum ! The global sum of the array [A]
+ real, allocatable :: sum_here(:) ! The sum on each PE [A]
logical :: compare
integer :: pe_num ! pe number of the data
integer :: nPEs ! Total number of processsors
@@ -2210,6 +2213,7 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs)
if (present(start_i)) is = start_i
if (present(end_i)) ie = end_i
compare = .true. ; if (present(compare_PEs)) compare = compare_PEs
+ iounit = error_unit ; if (present(logunit)) iounit = logunit
sum = 0.0 ; sum_bc = 0
do i=is,ie
@@ -2231,17 +2235,17 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs)
sum_bc = sum1
elseif (is_root_pe()) then
if (sum1 /= nPEs*sum_bc) &
- write(0, '(A40," bitcounts do not match across PEs: ",I12,1X,I12)') &
+ write(iounit, '(A40," bitcounts do not match across PEs: ",I12,1X,I12)') &
mesg, sum1, nPEs*sum_bc
do i=1,nPEs ; if (sum /= sum_here(i)) then
- write(0, '(A40," PE ",i4," sum mismatches root_PE: ",3(ES22.13,1X))') &
+ write(iounit, '(A40," PE ",I0," sum mismatches root_PE: ",3(ES22.13,1X))') &
mesg, i, sum_here(i), sum, sum_here(i)-sum
endif ; enddo
endif
deallocate(sum_here)
if (is_root_pe()) &
- write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum_bc
+ write(iounit,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum_bc
end subroutine chksum1d
@@ -2249,13 +2253,16 @@ end subroutine chksum1d
! into account.
!> chksum2d does a checksum of all data in a 2-d array.
-subroutine chksum2d(array, mesg)
+subroutine chksum2d(array, mesg, logunit)
- real, dimension(:,:), intent(in) :: array !< The array to be checksummed [arbitrary]
+ real, dimension(:,:), intent(in) :: array !< The array to be checksummed in arbitrary units [A]
character(len=*), intent(in) :: mesg !< An identifying message
+ integer, optional, intent(in) :: logunit !< IO unit for checksum logging
- integer :: xs,xe,ys,ye,i,j,sum1,bc
- real :: sum ! The global sum of the array [arbitrary]
+ integer :: xs, xe, ys, ye, i, j, sum1, bc, iounit
+ real :: sum ! The global sum of the array [A]
+
+ iounit = error_unit ; if (present(logunit)) iounit = logunit
xs = LBOUND(array,1) ; xe = UBOUND(array,1)
ys = LBOUND(array,2) ; ye = UBOUND(array,2)
@@ -2270,20 +2277,23 @@ subroutine chksum2d(array, mesg)
sum = reproducing_sum(array(:,:))
if (is_root_pe()) &
- write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1
-! write(0,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') &
+ write(iounit,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1
+! write(iounit,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') &
! mesg, sum, sum1, sum, sum1
end subroutine chksum2d
!> chksum3d does a checksum of all data in a 2-d array.
-subroutine chksum3d(array, mesg)
+subroutine chksum3d(array, mesg, logunit)
- real, dimension(:,:,:), intent(in) :: array !< The array to be checksummed [arbitrary]
+ real, dimension(:,:,:), intent(in) :: array !< The array to be checksummed in arbitrary units [A]
character(len=*), intent(in) :: mesg !< An identifying message
+ integer, optional, intent(in) :: logunit !< IO unit for checksum logging
+
+ integer :: xs, xe, ys, ye, zs, ze, i, j, k, bc, sum1, iounit
+ real :: sum ! The global sum of the array [A]
- integer :: xs,xe,ys,ye,zs,ze,i,j,k, bc,sum1
- 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)
@@ -2299,15 +2309,15 @@ subroutine chksum3d(array, mesg)
sum = reproducing_sum(array(:,:,:))
if (is_root_pe()) &
- write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1
-! write(0,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') &
+ write(iounit, '(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1
+! write(iounit, '(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') &
! mesg, sum, sum1, sum, sum1
end subroutine chksum3d
!> This function returns .true. if x is a NaN, and .false. otherwise.
function is_NaN_0d(x)
- real, intent(in) :: x !< The value to be checked for NaNs [arbitrary]
+ real, intent(in) :: x !< The value to be checked for NaNs in arbitrary units [A]
logical :: is_NaN_0d
!is_NaN_0d = (((x < 0.0) .and. (x >= 0.0)) .or. &
@@ -2323,7 +2333,7 @@ end function is_NaN_0d
!> Returns .true. if any element of x is a NaN, and .false. otherwise.
function is_NaN_1d(x, skip_mpp)
- real, dimension(:), intent(in) :: x !< The array to be checked for NaNs [arbitrary]
+ real, dimension(:), intent(in) :: x !< The array to be checked for NaNs in arbitrary units [A]
logical, optional, intent(in) :: skip_mpp !< If true, only check this array only
!! on the local PE (default false).
logical :: is_NaN_1d
@@ -2346,7 +2356,7 @@ end function is_NaN_1d
!> Returns .true. if any element of x is a NaN, and .false. otherwise.
function is_NaN_2d(x)
- real, dimension(:,:), intent(in) :: x !< The array to be checked for NaNs [arbitrary]
+ real, dimension(:,:), intent(in) :: x !< The array to be checked for NaNs in arbitrary units [A]
logical :: is_NaN_2d
integer :: i, j, n
@@ -2363,7 +2373,7 @@ end function is_NaN_2d
!> Returns .true. if any element of x is a NaN, and .false. otherwise.
function is_NaN_3d(x)
- real, dimension(:,:,:), intent(in) :: x !< The array to be checked for NaNs [arbitrary]
+ real, dimension(:,:,:), intent(in) :: x !< The array to be checked for NaNs in arbitrary units [A]
logical :: is_NaN_3d
integer :: i, j, k, n
@@ -2446,7 +2456,7 @@ function field_checksum_real_2d(field, pelist, mask_val, turns, unscale) &
integer(kind=int64) :: chksum !< checksum of array
! Local variables
- real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [arbitrary]
+ real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [A ~> a]
integer :: qturns ! The number of quarter turns through which to rotate field
logical :: do_unscale ! If true, unscale the variable before it is checksummed
@@ -2486,7 +2496,7 @@ function field_checksum_real_3d(field, pelist, mask_val, turns, unscale) &
integer(kind=int64) :: chksum !< checksum of array
! Local variables
- real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [arbitrary]
+ real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [A ~> a]
integer :: qturns ! The number of quarter turns through which to rotate field
logical :: do_unscale ! If true, unscale the variable before it is checksummed
@@ -2526,7 +2536,7 @@ function field_checksum_real_4d(field, pelist, mask_val, turns, unscale) &
integer(kind=int64) :: chksum !< checksum of array
! Local variables
- real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [arbitrary]
+ real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [A ~> a]
integer :: qturns ! The number of quarter turns through which to rotate field
logical :: do_unscale ! If true, unscale the variable before it is checksummed
@@ -2633,9 +2643,9 @@ end subroutine chk_sum_msg2
subroutine chk_sum_msg3(fmsg, aMean, aMin, aMax, mesg, iounit)
character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble
character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller
- real, intent(in) :: aMean !< The mean value of the array [arbitrary]
- real, intent(in) :: aMin !< The minimum value of the array [arbitrary]
- real, intent(in) :: aMax !< The maximum value of the array [arbitrary]
+ real, intent(in) :: aMean !< The mean value of the array in arbitrary units [A]
+ real, intent(in) :: aMin !< The minimum value of the array [A]
+ real, intent(in) :: aMax !< The maximum value of the array [A]
integer, intent(in) :: iounit !< Checksum logger IO unit
! NOTE: We add zero to aMin and aMax to remove any negative zeros.
@@ -2668,7 +2678,7 @@ end subroutine chksum_error
!> Does a bitcount of a number by first casting to an integer and then using BTEST
!! to check bit by bit
integer function bitcount(x)
- real, intent(in) :: x !< Number to be bitcount [arbitrary]
+ real, intent(in) :: x !< Number to be bitcount in arbitrary units [A]
integer, parameter :: xk = kind(x) !< Kind type of x
diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90
index ea5e632039..e577d68b82 100644
--- a/src/framework/MOM_coms.F90
+++ b/src/framework/MOM_coms.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interfaces to non-domain-oriented communication subroutines, including the
!! MOM6 reproducing sums facility
module MOM_coms
-! This file is part of MOM6. See LICENSE.md for the license.
-
use, intrinsic :: iso_fortran_env, only : int64
use MOM_coms_infra, only : PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist
use MOM_coms_infra, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end
@@ -23,6 +25,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.
@@ -358,7 +361,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su
integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting
!! that the array indices starts at 1
real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer in the same
- !! abitrary units as array [a] or [A ~> a]
+ !! arbitrary units as array [a] or [A ~> a]
type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format
type(EFP_type), dimension(:), &
optional, intent(out) :: EFP_lay_sums !< The sums by vertical layer in EFP format
@@ -408,7 +411,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su
if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_sum(_3d).")
je = jer
endif
- jsz = je+1-js; isz = ie+1-is
+ jsz = je+1-js ; isz = ie+1-is
do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE
do_unscale = .false. ; if (present(unscale)) do_unscale = (unscale /= 1.0)
@@ -795,7 +798,7 @@ end subroutine EFP_assign
!> Return the real number that an extended-fixed-point number corresponds with
function EFP_to_real(EFP1)
type(EFP_type), intent(inout) :: EFP1 !< The extended fixed point number being converted
- real :: EFP_to_real !< The real version of the number in abitrary units [a]
+ real :: EFP_to_real !< The real version of the number in arbitrary units [a]
call regularize_ints(EFP1%v)
EFP_to_real = ints_to_real(EFP1%v)
@@ -877,7 +880,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors)
do n=1,ni ; EFPs(i)%v(n) = ints(n,i) ; enddo
if (present(errors)) errors(i) = overflow_error
if (overflow_error) then
- write (mesg,'("EFP_list_sum_across_PEs error at ",i6," val was ",ES12.6, ", prec_error = ",ES12.6)') &
+ write (mesg,'("EFP_list_sum_across_PEs error at ",i0," val was ",ES12.6, ", prec_error = ",ES12.6)') &
i, EFP_to_real(EFPs(i)), real(prec_error)
call MOM_error(WARNING, mesg)
endif
diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90
index 25a2937aaa..cc8b2427da 100644
--- a/src/framework/MOM_coupler_types.F90
+++ b/src/framework/MOM_coupler_types.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module provides coupler type interfaces for use by MOM6
module MOM_coupler_types
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : allocate_rotated_array, rotate_array
use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux
use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums, CT_data_override
diff --git a/src/framework/MOM_cpu_clock.F90 b/src/framework/MOM_cpu_clock.F90
index f4e605a06c..91d1c2085a 100644
--- a/src/framework/MOM_cpu_clock.F90
+++ b/src/framework/MOM_cpu_clock.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides cpu clock functions
module MOM_cpu_clock
-! This file is part of MOM6. See LICENSE.md for the license.
-
! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module
use MOM_cpu_clock_infra, only : cpu_clock_begin
use MOM_cpu_clock_infra, only : cpu_clock_end
diff --git a/src/framework/MOM_data_override.F90 b/src/framework/MOM_data_override.F90
index 39841913e1..1ff145c0d7 100644
--- a/src/framework/MOM_data_override.F90
+++ b/src/framework/MOM_data_override.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> These interfaces allow for ocean or sea-ice variables to be replaced with data.
module MOM_data_override
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_data_override_infra, only : data_override_init => impose_data_init
use MOM_data_override_infra, only : data_override => impose_data
use MOM_data_override_infra, only : data_override_unset_domains => impose_data_unset_domains
diff --git a/src/framework/MOM_diag_buffers.F90 b/src/framework/MOM_diag_buffers.F90
new file mode 100644
index 0000000000..bc3695155a
--- /dev/null
+++ b/src/framework/MOM_diag_buffers.F90
@@ -0,0 +1,551 @@
+!> Provides buffers that can dynamically grow as needed. These are primarily intended for the
+!! diagnostics which need to store intermediate or partial states of state variables
+module MOM_diag_buffers
+
+use MOM_io, only : stdout, stderr
+
+! This file is part of MOM6. See LICENSE.md for the license.
+
+implicit none ; private
+
+public :: diag_buffer_unit_tests_2d, diag_buffer_unit_tests_3d
+
+type, abstract :: buffer_base
+end type buffer_base
+
+!> Holds a 2d field
+type, extends(buffer_base) :: buffer_2d
+ real, dimension(:,:), allocatable :: field !< The actual 2d field to be stored [arbitrary]
+end type buffer_2d
+
+!> Holds a 3d field
+type, extends(buffer_base) :: buffer_3d
+ real, dimension(:,:,:), allocatable :: field !< The actual 3d field to be stored [arbitrary]
+end type buffer_3d
+
+!> The base class for the diagnostic buffers in this module
+type, abstract :: diag_buffer_base ; private
+ integer :: is !< The start slot of the array i-direction
+ integer :: js !< The start slot of the array j-direction
+ integer :: ie !< The end slot of the array i-direction
+ integer :: je !< The end slot of the array j-direction
+ real :: fill_value = 0. !< Set the fill value to use when growing the buffer [arbitrary]
+
+ integer, allocatable, dimension(:) :: ids !< List of diagnostic ids whose slot corresponds to the row in the buffer
+ integer :: length = 0 !< The number of slots in the buffer
+
+ contains
+
+ procedure(a_grow), deferred :: grow !< Increase the size of the buffer
+ procedure, public :: set_fill_value !< Set the fill value to use when growing the buffer
+ procedure, public :: check_capacity_by_id !< Check the size size of the buffer and increase if necessary
+ procedure, public :: set_horizontal_extents !< Define the horizontal extents of the arrays
+ procedure, public :: mark_available !< Mark that a slot in the buffer can be reused
+ procedure, public :: grow_ids !< Increase the size of the vector storing diagnostic ids
+ procedure, public :: find_buffer_slot !< Find the slot corresponding to a specific diagnostic id
+end type diag_buffer_base
+
+!> Dynamically growing buffer for 2D arrays.
+type, extends(diag_buffer_base), public :: diag_buffer_2d ; private
+ type(buffer_2d), public, dimension(:), allocatable :: buffer !< The actual 2D buffer which will dynamically grow
+
+ contains
+
+ procedure, public :: grow => grow_2d !< Increase the size of the buffer
+ procedure, public :: store => store_2d !< Store a field in the buffer, increasing as necessary
+ procedure, public :: set_extents_from_array => set_extents_from_array_2d !< Set extents from array bounds
+end type diag_buffer_2d
+
+!> Dynamically growing buffer for 3D arrays.
+type, extends(diag_buffer_base), public :: diag_buffer_3d ; private
+ type(buffer_3d), public, dimension(:), allocatable :: buffer !< The actual 2D buffer which will dynamically grow
+ integer :: ks !< The start slot in the k-dimension
+ integer :: ke !< The last slot in the k-dimension
+
+ contains
+
+ procedure, public :: set_vertical_extent !< Set the vertical extents of the buffer
+ procedure, public :: grow => grow_3d !< Increase the size of the buffer
+ procedure, public :: store => store_3d !< Store a field in the buffer, increasing as necessary
+ procedure, public :: set_extents_from_array => set_extents_from_array_3d !< Set extents from array bounds
+end type diag_buffer_3d
+
+contains
+
+!> Signature for the grow methods on n-dimension diagnostic buffer types
+subroutine a_grow(this)
+ class(diag_buffer_base), intent(inout) :: this !< The diagnostic buffer
+end subroutine
+
+!> Set the fill value to use when growing the buffer
+subroutine set_fill_value(this, fill_value)
+ class(diag_buffer_base), intent(inout) :: this !< The diagnostic buffer
+ real, intent(in) :: fill_value !< The fill value to use when growing the buffer [arbitrary]
+
+ this%fill_value = fill_value
+end subroutine set_fill_value
+
+!> Mark a slot in the buffer as unused based on a diagnostic id. For example,
+!! the data in that slot has already been consumed and can thus be overwritten
+subroutine mark_available(this, id)
+ class(diag_buffer_base), intent(inout) :: this !< The diagnostic buffer
+ integer, intent(in) :: id !< The diagnostic id
+ integer :: slot
+
+ slot = this%find_buffer_slot(id)
+ this%ids(slot) = 0
+end subroutine mark_available
+
+!> Return the slot of the buffer corresponding to the diagnostic id
+pure function find_buffer_slot(this, id) result(slot)
+ class(diag_buffer_base), intent(in) :: this !< The diagnostic buffer
+ integer, intent(in) :: id !< The diagnostic id
+
+ integer, dimension(1) :: temp
+ integer :: slot !< The slot in the buffer corresponding to the diagnostic id
+
+ if (allocated(this%ids)) then
+ !NOTE: Alternatively could do slot = SUM(findloc(...))
+ temp = findloc(this%ids(:), id)
+ slot = temp(1)
+ else
+ slot = 0
+ endif
+
+end function find_buffer_slot
+
+!> Grow the ids array by one
+subroutine grow_ids(this)
+ class(diag_buffer_base), intent(inout) :: this !< This buffer
+
+ integer, allocatable, dimension(:) :: temp
+ integer :: n
+
+ n = this%length
+
+ allocate(temp(n+1))
+ if (n>0) temp(1:n) = this%ids(:)
+ call move_alloc(temp, this%ids)
+end subroutine grow_ids
+
+!> Check whether the id already has a slot reserved. If not, find a new empty slot and if
+!! need be, grow the buffer.
+impure function check_capacity_by_id(this, id) result(slot)
+ class(diag_buffer_base), intent(inout) :: this !< This 2d buffer
+ integer, intent(in) :: id !< The diagnostic id
+ integer :: slot
+
+ slot = this%find_buffer_slot(id)
+ if (slot==0) then
+ ! Check to see if there is an open slot
+ if (allocated(this%ids)) slot = this%find_buffer_slot(0)
+ ! If slot is still 0, then the buffer must grow
+ if (slot==0) then
+ call this%grow()
+ slot = this%length
+ endif
+ this%ids(slot) = id
+ endif
+end function check_capacity_by_id
+
+!> Set the horizontal extents of the buffer
+subroutine set_horizontal_extents(this, is, ie, js, je)
+ class(diag_buffer_base), intent(inout) :: this !< The diagnostic buffer
+ integer, intent(in) :: is !< The start slot of the array i-direction
+ integer, intent(in) :: ie !< The end slot of the array i-direction
+ integer, intent(in) :: js !< The start slot of the array j-direction
+ integer, intent(in) :: je !< The end slot of the array j-direction
+
+ this%is = is ; this%ie = ie ; this%js = js ; this%je = je
+end subroutine set_horizontal_extents
+
+!> Set the vertical extent of the buffer
+subroutine set_vertical_extent(this, ks, ke)
+ class(diag_buffer_3d), intent(inout) :: this !< The diagnostic buffer
+ integer, intent(in) :: ks !< The start slot of the array i-direction
+ integer, intent(in) :: ke !< The end slot of the array i-direction
+
+ this%ks = ks ; this%ke = ke
+end subroutine set_vertical_extent
+
+!> Set the extents of a 2D buffer from the bounds of a 2D array
+subroutine set_extents_from_array_2d(this, array, fill_value_in)
+ class(diag_buffer_2d), intent(inout) :: this !< The diagnostic buffer
+ real, dimension(:,:), intent(in) :: array !< The array whose bounds define the buffer extents
+ real, optional, intent(in) :: fill_value_in !< Optional fill value
+
+ call this%set_horizontal_extents(lbound(array,1), ubound(array,1), &
+ lbound(array,2), ubound(array,2))
+ if (present(fill_value_in)) call this%set_fill_value(fill_value_in)
+end subroutine set_extents_from_array_2d
+
+!> Set the extents of a 3D buffer from the bounds of a 3D array
+subroutine set_extents_from_array_3d(this, array, fill_value_in)
+ class(diag_buffer_3d), intent(inout) :: this !< The diagnostic buffer
+ real, dimension(:,:,:), intent(in) :: array !< The array whose bounds define the buffer extents
+ real, optional, intent(in) :: fill_value_in !< Optional fill value
+
+ call this%set_horizontal_extents(lbound(array,1), ubound(array,1), &
+ lbound(array,2), ubound(array,2))
+ call this%set_vertical_extent(lbound(array,3), ubound(array,3))
+ if (present(fill_value_in)) call this%set_fill_value(fill_value_in)
+end subroutine set_extents_from_array_3d
+
+!> Grow a 2d diagnostic buffer
+subroutine grow_2d(this)
+ class(diag_buffer_2d), intent(inout) :: this
+
+ integer :: i, n
+ integer :: is, ie, js, je
+ type(buffer_2d), dimension(:), allocatable :: new_buffer
+
+ ! Grow the ID array
+ call this%grow_ids()
+
+ is = this%is ; ie = this%ie ; js = this%js ; je = this%je
+ n = this%length
+
+ allocate(new_buffer(n+1))
+ do i=1,n
+ allocate(new_buffer(i)%field(is:ie,js:je))
+ new_buffer(i)%field(:,:) = this%buffer(i)%field(:,:)
+ enddo
+ allocate(new_buffer(n+1)%field(is:ie,js:je), source=this%fill_value)
+ call move_alloc(new_buffer, this%buffer)
+ this%length = n+1
+
+end subroutine grow_2d
+
+!> Store a 2D array into this buffer
+subroutine store_2d(this, data, id)
+ class(diag_buffer_2d), intent(inout) :: this !< This 2d buffer
+ real, dimension(:,:), intent(in) :: data !< The data to be stored in the buffer [arbitrary]
+ integer, intent(in) :: id !< The diagnostic id
+
+ integer :: slot
+
+ slot = this%check_capacity_by_id(id)
+ this%buffer(slot)%field(:,:) = data(:,:)
+end subroutine store_2d
+
+!> Grow a 2d diagnostic buffer
+subroutine grow_3d(this)
+ class(diag_buffer_3d), intent(inout) :: this
+
+ integer :: i, n
+ integer :: is, ie, js, je, ks, ke
+ type(buffer_3d), dimension(:), allocatable :: new_buffer
+
+ ! Grow the ID array
+ call this%grow_ids()
+
+ is = this%is ; ie = this%ie ; js = this%js ; je = this%je ; ks = this%ks ; ke = this%ke
+ n = this%length
+
+ allocate(new_buffer(n+1))
+ do i=1,n
+ allocate(new_buffer(i)%field(is:ie,js:je,ks:ke))
+ new_buffer(i)%field(:,:,:) = this%buffer(i)%field(:,:,:)
+ enddo
+ allocate(new_buffer(n+1)%field(is:ie,js:je,ks:ke), source=this%fill_value)
+ call move_alloc(new_buffer, this%buffer)
+ this%length = n+1
+
+end subroutine grow_3d
+
+!> Store a 3d array into this buffer
+subroutine store_3d(this, data, id)
+ class(diag_buffer_3d), intent(inout) :: this !< This 3d buffer
+ real, dimension(:,:,:), intent(in) :: data !< The data to be stored in the buffer [arbitrary]
+ integer, intent(in) :: id !< The diagnostic id
+
+ integer :: slot
+
+ ! Find the first slot in the ids array that is 0, i.e. this is a portion of the buffer that can be reused
+ slot = this%check_capacity_by_id(id)
+ this%buffer(slot)%field(:,:,:) = data(:,:,:)
+end subroutine store_3d
+
+!> Unit tests for the 2d version of the diag buffer
+function diag_buffer_unit_tests_2d(verbose) result(fail)
+ logical, intent(in) :: verbose !< If true, write results to stdout
+ logical :: fail !< True if any of the unit tests fail
+
+ fail = .false.
+ write(stdout,*) '==== MOM_diag_buffers: diag_buffers_unit_tests_2d ==='
+ fail = fail .or. new_buffer_2d()
+ fail = fail .or. grow_buffer_2d()
+ fail = fail .or. fill_value_2d()
+ fail = fail .or. store_buffer_2d()
+ fail = fail .or. reuse_buffer_2d()
+
+ contains
+
+ !> Ensure properties of a newly initialized buffer
+ function new_buffer_2d() result(local_fail)
+ type(diag_buffer_2d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+ local_fail = .false.
+ local_fail = local_fail .or. allocated(buffer%buffer)
+ if (verbose) write(stdout,*) "new_buffer_2d: ", local_fail
+ local_fail = local_fail .or. allocated(buffer%ids)
+ if (verbose) write(stdout,*) "new_buffer_2d: ", local_fail
+ local_fail = local_fail .or. buffer%length /= 0
+ if (verbose) write(stdout,*) "new_buffer_2d: ", local_fail
+ end function new_buffer_2d
+
+ !> Test the growing of a buffer
+ function grow_buffer_2d() result(local_fail)
+ type(diag_buffer_2d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+ integer, parameter :: is=1, ie=2, js=3, je=6
+ integer :: i
+
+ local_fail = .false.
+
+ call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je)
+ ! Grow the buffer 3 times
+ do i=1,3
+ call buffer%grow()
+ local_fail = local_fail .or. (buffer%length /= i)
+ local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 1) /= is)
+ local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 1) /= ie)
+ local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 2) /= js)
+ local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 2) /= je)
+ enddo
+ if (verbose) write(stdout,*) "grow_buffer_2d: ", local_fail
+ end function grow_buffer_2d
+
+ !> Test that growing new buffer fills the array with a set fill value
+ function fill_value_2d() result(local_fail)
+ type(diag_buffer_2d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+ integer, parameter :: is=1, ie=2, js=3, je=6
+ real, parameter :: fill_value = -123.456
+ integer :: i
+
+
+ local_fail = .false.
+
+ call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je)
+ call buffer%set_fill_value(fill_value)
+ ! Grow the buffer 3 times
+ call buffer%grow()
+ if (any(buffer%buffer(1)%field(:,:) /= fill_value)) local_fail = .true.
+ if (verbose) write(stdout,*) "fill_value_2d: ", local_fail
+ end function fill_value_2d
+
+ !> Test storing a buffer based on a unique id
+ function store_buffer_2d() result(local_fail)
+ type(diag_buffer_2d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+
+ integer, parameter :: is=1, ie=2, js=3, je=6, nlen=3
+ integer :: i, slot
+ real, allocatable, dimension(:,:,:) :: test_2d
+
+ local_fail = .false.
+
+ allocate(test_2d(nlen, is:ie, js:je))
+ call random_number(test_2d)
+ buffer%is = is
+ buffer%ie = ie
+ buffer%js = js
+ buffer%je = je
+
+ do i=1,nlen
+ call buffer%store(test_2d(i,:,:), i*3)
+ slot = buffer%find_buffer_slot(i*3)
+ local_fail = local_fail .or. ANY(buffer%buffer(slot)%field(:,:) /= test_2d(i,:,:))
+ enddo
+
+ if (verbose) write(stdout,*) "store_buffer_2d: ", local_fail
+ end function store_buffer_2d
+
+ !> Test the reuse of a buffer. Fill it first like store_buffer_2d. Then,
+ !! loop through again, but use the slots of the buffer in the following
+ !! order: 2, 1, 3
+ function reuse_buffer_2d() result(local_fail)
+ type(diag_buffer_2d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+
+ integer, parameter :: is=1, ie=2, js=3, je=6, nlen=3
+ integer :: i, new_i, id, new_id
+ real, dimension(nlen, is:ie, js:je) :: test_2d_first, test_2d_second
+ integer, dimension(nlen) :: reorder = [2,1,3]
+
+ local_fail = .false.
+ call random_number(test_2d_first)
+ call random_number(test_2d_second)
+
+ call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je)
+
+ do i=1,nlen
+ call buffer%store(test_2d_first(i,:,:), id=i*3)
+ enddo
+
+ do i=1,nlen
+ new_i = reorder(i)
+ ! id and new_id are multiplied by primes to make sure they are unique
+ id = reorder(i)*3
+ new_id = i*7
+ call buffer%mark_available(id=reorder(i)*3)
+ call buffer%store(test_2d_second(i,:,:), id=new_id)
+ local_fail = local_fail .or. buffer%find_buffer_slot(new_id) /= new_i
+ test_2d_first(new_i,:,:) = test_2d_second(i,:,:)
+ enddo
+ local_fail = local_fail .or. any(buffer%ids /= [14, 7, 21])
+ do i=1,nlen
+ local_fail = local_fail .or. any(buffer%buffer(i)%field(:,:) /= test_2d_first(i,:,:))
+ enddo
+ if (verbose) write(stdout,*) "reuse_buffer_2d: ", local_fail
+ end function reuse_buffer_2d
+
+end function diag_buffer_unit_tests_2d
+
+!> Test the 3d version of the buffer
+function diag_buffer_unit_tests_3d(verbose) result(fail)
+ logical, intent(in) :: verbose !< If true, write results to stdout
+ logical :: fail !< True if any of the unit tests fail
+
+ fail = .false.
+ write(stdout,*) '==== MOM_diag_buffers: diag_buffers_unit_tests_3d ==='
+ fail = fail .or. new_buffer_3d()
+ fail = fail .or. grow_buffer_3d()
+ fail = fail .or. fill_value_3d()
+ fail = fail .or. store_buffer_3d()
+ fail = fail .or. reuse_buffer_3d()
+
+ contains
+
+ !> Ensure properties of a newly initialized buffer
+ function new_buffer_3d() result(local_fail)
+ type(diag_buffer_3d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+ local_fail = .false.
+ local_fail = local_fail .or. allocated(buffer%buffer)
+ local_fail = local_fail .or. allocated(buffer%ids)
+ local_fail = local_fail .or. buffer%length /= 0
+ if (verbose) write(stdout,*) "new_buffer_3d: ", local_fail
+ end function new_buffer_3d
+
+ !> Test the growing of a buffer
+ function grow_buffer_3d() result(local_fail)
+ type(diag_buffer_3d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+ integer, parameter :: is=1, ie=2, js=3, je=6, ks=1, ke=10
+ integer :: i
+
+ local_fail = .false.
+
+ call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je)
+ call buffer%set_vertical_extent(ks=ks, ke=ke)
+ ! Grow the buffer 3 times
+ do i=1,3
+ call buffer%grow()
+ local_fail = local_fail .or. (buffer%length /= i)
+ local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 1) /= is)
+ local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 1) /= ie)
+ local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 2) /= js)
+ local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 2) /= je)
+ local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 3) /= ks)
+ local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 3) /= ke)
+ if (verbose) write(stdout,*) "grow_buffer_3d: ", local_fail
+ enddo
+ if (verbose) write(stdout,*) "grow_buffer_3d: ", local_fail
+ end function grow_buffer_3d
+
+ !> Test that growing new buffer fills the array with a set fill value
+ function fill_value_3d() result(local_fail)
+ type(diag_buffer_3d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+ integer, parameter :: is=1, ie=2, js=3, je=6
+ real, parameter :: fill_value = -123.456
+ integer :: i
+
+
+ local_fail = .false.
+
+ call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je)
+ call buffer%set_fill_value(fill_value)
+ ! Grow the buffer 3 times
+ call buffer%grow()
+ if (any(buffer%buffer(1)%field(:,:,:) /= fill_value)) local_fail = .true.
+ if (verbose) write(stdout,*) "fill_value_3d: ", local_fail
+ end function fill_value_3d
+
+ !> Test storing a buffer based on a unique id
+ function store_buffer_3d() result(local_fail)
+ type(diag_buffer_3d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+
+ integer, parameter :: is=1, ie=2, js=3, je=6, ks=1, ke=10, nlen=3
+ integer :: i, slot
+ real, dimension(nlen,is:ie,js:je,ks:ke) :: test_3d
+
+ local_fail = .false.
+ call random_number(test_3d)
+ buffer%is = is
+ buffer%ie = ie
+ buffer%js = js
+ buffer%je = je
+ buffer%ks = ks
+ buffer%ke = ke
+
+ do i=1,nlen
+ call buffer%store(test_3d(i,:,:,:), i*3)
+ slot = buffer%find_buffer_slot(i*3)
+ local_fail = local_fail .or. ANY(buffer%buffer(slot)%field(:,:,:) /= test_3d(i,:,:,:))
+ enddo
+
+ if (verbose) write(stdout,*) "store_buffer_3d: ", local_fail
+ end function store_buffer_3d
+
+ !> Test the reuse of a buffer. Fill it first like store_buffer_3d. Then,
+ !! loop through again, but use the slots of the buffer in the following
+ !! order: 2, 1, 3
+ function reuse_buffer_3d() result(local_fail)
+ type(diag_buffer_3d) :: buffer
+ logical :: local_fail !< True if any of the unit tests fail
+
+ integer, parameter :: is=1, ie=2, js=3, je=6, ks=1, ke=10, nlen=3
+ integer :: i, new_i, id, new_id
+ real, dimension(nlen, is:ie, js:je, ks:ke) :: test_3d_first, test_3d_second
+ integer, dimension(nlen) :: reorder = [2,1,3]
+
+ local_fail = .false.
+ call random_number(test_3d_first)
+ call random_number(test_3d_second)
+
+ buffer%is = is
+ buffer%ie = ie
+ buffer%js = js
+ buffer%je = je
+ buffer%ks = ks
+ buffer%ke = ke
+
+ do i=1,nlen
+ call buffer%store(test_3d_first(i,:,:,:), id=i*3)
+ enddo
+
+ do i=1,nlen
+ new_i = reorder(i)
+ ! id and new_id are multiplied by primes to make sure they are unique
+ id = reorder(i)*3
+ new_id = i*7
+ call buffer%mark_available(id=reorder(i)*3)
+ call buffer%store(test_3d_second(i,:,:,:), id=new_id)
+ local_fail = local_fail .or. buffer%find_buffer_slot(new_id) /= new_i
+ test_3d_first(new_i,:,:,:) = test_3d_second(i,:,:,:)
+ enddo
+ local_fail = local_fail .or. any(buffer%ids /= [14, 7, 21])
+ do i=1,nlen
+ local_fail = local_fail .or. any(buffer%buffer(i)%field(:,:,:) /= test_3d_first(i,:,:,:))
+ enddo
+ if (verbose) write(stdout,*) "reuse_buffer_3d: ", local_fail
+ end function reuse_buffer_3d
+
+end function diag_buffer_unit_tests_3d
+
+end module MOM_diag_buffers
+
diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90
index 1a43739147..40074f0cc3 100644
--- a/src/framework/MOM_diag_mediator.F90
+++ b/src/framework/MOM_diag_mediator.F90
@@ -1,19 +1,22 @@
-!> The subroutines here provide convenient wrappers to the fms diag_manager
-!! interfaces with additional diagnostic capabilies.
-module MOM_diag_mediator
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
-! This file is part of MOM6. See LICENSE.md for the license.
+!> The subroutines here provide convenient wrappers to the FMS diag_manager
+!! interfaces with additional diagnostic capabilities.
+module MOM_diag_mediator
-use MOM_checksums, only : chksum0, zchksum
-use MOM_checksums, only : hchksum, uchksum, vchksum, Bchksum
+use MOM_checksums, only : chksum0, zchksum, hchksum, uchksum, vchksum, Bchksum
use MOM_coms, only : PE_here
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE
+use MOM_diag_buffers, only : diag_buffer_2d, diag_buffer_3d
use MOM_diag_manager_infra, only : MOM_diag_manager_init, MOM_diag_manager_end
use MOM_diag_manager_infra, only : diag_axis_init=>MOM_diag_axis_init, get_MOM_diag_axis_name
use MOM_diag_manager_infra, only : send_data_infra, MOM_diag_field_add_attribute, EAST, NORTH
use MOM_diag_manager_infra, only : register_diag_field_infra, register_static_field_infra
use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND
+use MOM_diag_manager_infra, only : diag_send_complete_infra
use MOM_diag_remap, only : diag_remap_ctrl, diag_remap_update, diag_remap_calc_hmask
use MOM_diag_remap, only : diag_remap_init, diag_remap_end, diag_remap_do_remap
use MOM_diag_remap, only : vertically_reintegrate_diag_field, vertically_interpolate_diag_field
@@ -26,12 +29,11 @@ module MOM_diag_mediator
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_grid, only : ocean_grid_type
use MOM_interface_heights, only : thickness_to_dz
-use MOM_io, only : slasher, vardesc, query_vardesc, MOM_read_data
+use MOM_io, only : vardesc, query_vardesc
use MOM_io, only : get_filename_appendix
use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc
-use MOM_string_functions, only : lowercase
-use MOM_time_manager, only : time_type
-use MOM_time_manager, only : get_time
+use MOM_string_functions, only : lowercase, slasher, ints_to_string, trim_trailing_commas
+use MOM_time_manager, only : time_type, get_time
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : thermo_var_ptrs
use MOM_verticalGrid, only : verticalGrid_type
@@ -43,8 +45,9 @@ module MOM_diag_mediator
#define MAX_DSAMP_LEV 2
public set_axes_info, post_data, register_diag_field, time_type
+public post_data_3d_by_column, post_data_3d_final
public post_product_u, post_product_sum_u, post_product_v, post_product_sum_v
-public set_masks_for_axes
+public set_masks_for_axes, MOM_diag_send_complete
! post_data_1d_k is a deprecated interface that can be replaced by a call to post_data, but
! it is being retained for backward compatibility to older versions of the ocean_BGC code.
public post_data_1d_k
@@ -56,6 +59,7 @@ module MOM_diag_mediator
public diag_axis_init, ocean_register_diag, register_static_field
public register_scalar_field
public define_axes_group, diag_masks_set
+public set_piecemeal_extents
public diag_register_area_ids
public register_cell_measure, diag_associate_volume_cell_measure
public diag_get_volume_cell_measure_dm_id
@@ -70,6 +74,11 @@ module MOM_diag_mediator
module procedure post_data_3d, post_data_2d, post_data_1d_k, post_data_0d
end interface post_data
+!> Registers a non-array scalar diagnostic, returning an integer handle
+interface register_scalar_field
+ module procedure register_scalar_field_CS, register_scalar_field_axes
+end interface register_scalar_field
+
!> Down sample a field
interface downsample_field
module procedure downsample_field_2d, downsample_field_3d
@@ -124,8 +133,8 @@ module MOM_diag_mediator
!! interface-located field that must be interpolated to
!! these axes. Used for rank>2.
integer :: downsample_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be downsampled
- ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only)
- type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics
+ ! For horizontally averaged diagnostics (applies to 2d and 3d fields only)
+ type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontally area-averaged diagnostics
! ID's for cell_measures
integer :: id_area = -1 !< The diag_manager id for area to be used for cell_measure of variables with this axes_grp.
integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables
@@ -134,6 +143,10 @@ module MOM_diag_mediator
real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes [nondim]
real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes [nondim]
type(diag_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample container
+
+ ! For diagnostics posted piecemeal
+ type(diag_buffer_2d) :: piecemeal_2d !< A dynamically reallocated buffer for 2d piecemeal diagnostics
+ type(diag_buffer_3d) :: piecemeal_3d !< A dynamically reallocated buffer for 3d piecemeal diagnostics
end type axes_grp
!> Contains an array to store a diagnostic target grid
@@ -160,7 +173,7 @@ module MOM_diag_mediator
integer :: PMM=133 !< x:point,y:mean,z:mean
integer :: SPP=211 !< x:sum,y:point,z:point
integer :: SPS=212 !< x:sum,y:point,z:sum
-integer :: SSP=221 !< x:sum;y:sum,z:point
+integer :: SSP=221 !< x:sum,y:sum,z:point
integer :: MPP=311 !< x:mean,y:point,z:point
integer :: MPM=313 !< x:mean,y:point,z:mean
integer :: MMP=331 !< x:mean,y:mean,z:point
@@ -171,7 +184,7 @@ module MOM_diag_mediator
!> This type is used to represent a diagnostic at the diag_mediator level.
!!
-!! There can be both 'primary' and 'seconday' diagnostics. The primaries
+!! There can be both 'primary' and 'secondary' diagnostics. The primaries
!! reside in the diag_cs%diags array. They have an id which is an index
!! into this array. The secondaries are 'variations' on the primary diagnostic.
!! For example the CMOR diagnostics are secondary. The secondary diagnostics
@@ -181,7 +194,7 @@ module MOM_diag_mediator
integer :: fms_diag_id !< Underlying FMS diag_manager id.
integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic.
integer :: downsample_diag_id = -1 !< For a horizontally area-downsampled diagnostic.
- character(64) :: debug_str = '' !< For FATAL errors and debugging.
+ character(len=64) :: debug_str = '' !< The diagnostic name and module for FATAL errors and debugging.
type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic
type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic
real :: conversion_factor = 0. !< If non-zero, a factor to multiply data by before posting to FMS,
@@ -245,20 +258,22 @@ module MOM_diag_mediator
logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics
logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level.
logical :: index_space_axes !< If true, diagnostic horizontal coordinates axes are in index space.
-! The following fields are used for the output of the data.
+
+ ! The following fields are used for the output of the data.
+ ! These give the computational-domain sizes, and are relative to a start value
+ ! of 1 in memory for the tracer-point arrays.
integer :: is !< The start i-index of cell centers within the computational domain
integer :: ie !< The end i-index of cell centers within the computational domain
integer :: js !< The start j-index of cell centers within the computational domain
integer :: je !< The end j-index of cell centers within the computational domain
-
+ ! These give the memory-domain sizes, and can start at any value on each PE.
integer :: isd !< The start i-index of cell centers within the data domain
integer :: ied !< The end i-index of cell centers within the data domain
integer :: jsd !< The start j-index of cell centers within the data domain
integer :: jed !< The end j-index of cell centers within the data domain
real :: time_int !< The time interval for any fields
!! that are offered for averaging [s].
- type(time_type) :: time_end !< The end time of the valid
- !! interval for any offered field.
+ type(time_type) :: time_end !< The end time of the valid interval for any offered field.
logical :: ave_enabled = .false. !< True if averaging is enabled.
!>@{ The following are 3D and 2D axis groups defined for output. The names
@@ -271,6 +286,7 @@ module MOM_diag_mediator
type(axes_grp) :: axesZL !< A 1-D z-space axis at layer centers
type(axes_grp) :: axesNull !< An axis group for scalars
+ ! Mask arrays for 2D diagnostics
real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points [nondim]
real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points [nondim]
real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points [nondim]
@@ -296,7 +312,7 @@ module MOM_diag_mediator
integer :: next_free_diag_id !< The next unused diagnostic ID
!> default missing value to be sent to ALL diagnostics registrations [various]
- real :: missing_value = -1.0e+34
+ real :: missing_value = -1.0e34
!> Number of diagnostic vertical coordinates (remapped)
integer :: num_diag_coords
@@ -318,8 +334,8 @@ module MOM_diag_mediator
real, dimension(:,:,:), pointer :: T => null() !< The temperatures needed for remapping [C ~> degC]
real, dimension(:,:,:), pointer :: S => null() !< The salinities needed for remapping [S ~> ppt]
type(EOS_type), pointer :: eqn_of_state => null() !< The equation of state type
- type(thermo_var_ptrs), pointer :: tv => null() !< A sturcture with thermodynamic variables that are
- !! are used to convert thicknesses to vertical extents
+ type(thermo_var_ptrs), pointer :: tv => null() !< A structure with thermodynamic variables that are
+ !! used to convert thicknesses to vertical extents
type(ocean_grid_type), pointer :: G => null() !< The ocean grid type
type(verticalGrid_type), pointer :: GV => null() !< The model's vertical ocean grid
type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type
@@ -338,6 +354,8 @@ module MOM_diag_mediator
real, dimension(:,:,:), allocatable :: h_begin !< Layer thicknesses at the beginning of the timestep used
!! for remapping of extensive variables [H ~> m or kg m-2]
+ real, dimension(:,:,:), allocatable :: dz_begin !< Layer vertical extents at the beginning of the timestep used
+ !! for remapping of extensive variables [Z ~> m]
end type diag_ctrl
@@ -486,11 +504,14 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical)
call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, &
x_cell_method='mean', y_cell_method='point', is_v_point=.true.)
- ! Axis group for special null axis from diag manager.
+ ! Define array extents for all piecemeal buffers
+ call set_piecemeal_extents(diag_cs)
+
+ ! Axis group for special null axis for scalars from diag manager.
id_null = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none', null_axis=.true.)
call define_axes_group(diag_cs, (/ id_null /), diag_cs%axesNull)
- !Non-native Non-downsampled
+ ! Set axis groups for non-native, non-downsampled grids
if (diag_cs%num_diag_coords>0) then
allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords))
allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords))
@@ -506,7 +527,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical)
do i=1, diag_cs%num_diag_coords
! For each possible diagnostic coordinate
- call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, US, param_file)
+ call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), G, GV, US, param_file)
! Allocate these arrays since the size of the diagnostic array is now known
allocate(diag_cs%diag_remap_cs(i)%h(G%isd:G%ied,G%jsd:G%jed, diag_cs%diag_remap_cs(i)%nz))
@@ -583,7 +604,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical)
if (diag_cs%index_space_axes) then
deallocate(IaxB, iax, JaxB, jax)
endif
- !Define the downsampled axes
+ ! Define the downsampled axes
call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native)
call diag_grid_storage_init(diag_CS%diag_grid_temp, G, GV, diag_CS)
@@ -616,41 +637,41 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n
id_zl = id_zl_native ; id_zi = id_zi_native
- !Axes group for native downsampled diagnostics
+ ! Axes group for native downsampled diagnostics
do dl=2,MAX_DSAMP_LEV
if (dl /= 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!")
if (G%symmetric) then
allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB))
allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB))
- do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo
- do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo
+ do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB ; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i) ; enddo
+ do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB ; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j) ; enddo
id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', &
'q point nominal longitude', G%Domain, coarsen=2)
id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', &
'q point nominal latitude', G%Domain, coarsen=2)
- deallocate(gridLonB_dsamp,gridLatB_dsamp)
+ deallocate(gridLonB_dsamp, gridLatB_dsamp)
else
allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg))
allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg))
- do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo
- do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo
+ do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg ; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2) ; enddo
+ do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg ; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2) ; enddo
id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', &
'q point nominal longitude', G%Domain, coarsen=2)
id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', &
'q point nominal latitude', G%Domain, coarsen=2)
- deallocate(gridLonB_dsamp,gridLatB_dsamp)
+ deallocate(gridLonB_dsamp, gridLatB_dsamp)
endif
allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg))
allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg))
- do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo
- do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo
+ do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg ; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2) ; enddo
+ do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg ; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2) ; enddo
id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', &
'h point nominal longitude', G%Domain, coarsen=2)
id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', &
'h point nominal latitude', G%Domain, coarsen=2)
- deallocate(gridLonT_dsamp,gridLatT_dsamp)
+ deallocate(gridLonT_dsamp, gridLatT_dsamp)
! Axis groupings for the model layers
call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, &
@@ -690,7 +711,7 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n
call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, &
x_cell_method='mean', y_cell_method='point', is_v_point=.true.)
- !Non-native axes
+ ! Axis groupings with a non-native vertical coordinate
if (diag_cs%num_diag_coords>0) then
allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords))
allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords))
@@ -704,7 +725,7 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n
do i=1, diag_cs%num_diag_coords
! For each possible diagnostic coordinate
- !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file)
+ ! call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), G, GV, param_file)
! This vertical coordinate has been configured so can be used.
if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then
@@ -865,7 +886,7 @@ subroutine set_masks_for_axes(G, diag_cs)
endif
enddo
- !Allocate and initialize the downsampled masks for the axes
+ ! Allocate and initialize the downsampled masks for the axes
call set_masks_for_axes_dsamp(G, diag_cs)
end subroutine set_masks_for_axes
@@ -878,9 +899,9 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs)
integer :: c, dl
type(axes_grp), pointer :: axes => NULL() ! Current axes, for convenience
- !Each downsampled axis needs both downsampled and non-downsampled mask
- !The downsampled mask is needed for sending out the diagnostics output via diag_manager
- !The non-downsampled mask is needed for downsampling the diagnostics field
+ ! Each downsampled axis needs both downsampled and non-downsampled masks.
+ ! The downsampled mask is needed for sending out the diagnostics output via diag_manager.
+ ! The non-downsampled mask is needed for downsampling the diagnostics field.
do dl=2,MAX_DSAMP_LEV
if (dl /= 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!")
do c=1, diag_cs%num_diag_coords
@@ -889,49 +910,49 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs)
call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, &
dl, G%isc, G%jsc, G%isd, G%jsd, &
G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed)
- diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask
+ diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask
! Level/layer u-points in diagnostic coordinate
axes => diag_cs%remap_axesCuL(c)
call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, &
dl, G%IscB, G%jsc, G%IsdB, G%jsd, &
G%HId2%IscB, G%HId2%IecB, G%HId2%jsc, G%HId2%jec, G%HId2%IsdB, G%HId2%IedB, G%HId2%jsd, G%HId2%jed)
- diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask
+ diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask
! Level/layer v-points in diagnostic coordinate
axes => diag_cs%remap_axesCvL(c)
call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, &
dl, G%isc, G%JscB, G%isd, G%JsdB, &
G%HId2%isc, G%HId2%iec, G%HId2%JscB, G%HId2%JecB, G%HId2%isd, G%HId2%ied, G%HId2%JsdB, G%HId2%JedB)
- diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask
+ diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask
! Level/layer q-points in diagnostic coordinate
axes => diag_cs%remap_axesBL(c)
call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, &
dl, G%IscB, G%JscB, G%IsdB, G%JsdB, &
G%HId2%IscB, G%HId2%IecB, G%HId2%JscB, G%HId2%JecB, G%HId2%IsdB, G%HId2%IedB, G%HId2%JsdB, G%HId2%JedB)
- diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask
+ diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask
! Interface h-points in diagnostic coordinate (w-point)
axes => diag_cs%remap_axesTi(c)
call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, &
dl, G%isc, G%jsc, G%isd, G%jsd, &
G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed)
- diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask
+ diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask
! Interface u-points in diagnostic coordinate
axes => diag_cs%remap_axesCui(c)
call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, &
dl, G%IscB, G%jsc, G%IsdB, G%jsd, &
G%HId2%IscB, G%HId2%IecB, G%HId2%jsc, G%HId2%jec, G%HId2%IsdB, G%HId2%IedB, G%HId2%jsd, G%HId2%jed)
- diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask
+ diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask
! Interface v-points in diagnostic coordinate
axes => diag_cs%remap_axesCvi(c)
call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, &
dl, G%isc, G%JscB, G%isd, G%JsdB, &
G%HId2%isc, G%HId2%iec, G%HId2%JscB, G%HId2%JecB, G%HId2%isd, G%HId2%ied, G%HId2%JsdB, G%HId2%JedB)
- diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask
+ diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask
! Interface q-points in diagnostic coordinate
axes => diag_cs%remap_axesBi(c)
call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, &
dl, G%IscB, G%JscB, G%IsdB, G%JsdB, &
G%HId2%IscB, G%HId2%IecB, G%HId2%JscB, G%HId2%JecB, G%HId2%IsdB, G%HId2%IedB, G%HId2%JsdB, G%HId2%JedB)
- diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask
+ diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask
enddo
enddo
end subroutine set_masks_for_axes_dsamp
@@ -1010,7 +1031,7 @@ integer function diag_get_volume_cell_measure_dm_id(diag_cs)
end function diag_get_volume_cell_measure_dm_id
-!> Defines a group of "axes" from list of handles
+!> Define a group of "axes" from a list of handles and associate a mask with it
subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_number, &
x_cell_method, y_cell_method, v_cell_method, &
is_h_point, is_q_point, is_u_point, is_v_point, &
@@ -1056,10 +1077,10 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num
n = size(handles)
if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!")
allocate( axes%handles(n) )
- axes%id = i2s(handles, n) ! Identifying string
+ axes%id = ints_to_string(handles, max(n,3)) ! Identifying string
axes%rank = n
axes%handles(:) = handles(:)
- axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure
+ axes%diag_cs => diag_cs ! A (circular) link back to the diag_cs structure
if (present(x_cell_method)) then
if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // &
'Can not set x_cell_method for rank<2.')
@@ -1120,6 +1141,7 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num
endif
endif
+
end subroutine define_axes_group
!> Defines a group of downsampled "axes" from list of handles
@@ -1169,10 +1191,10 @@ subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coor
n = size(handles)
if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!")
allocate( axes%handles(n) )
- axes%id = i2s(handles, n) ! Identifying string
+ axes%id = ints_to_string(handles, max(n,3)) ! Identifying string
axes%rank = n
axes%handles(:) = handles(:)
- axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure
+ axes%diag_cs => diag_cs ! A (circular) link back to the diag_cs structure
if (present(x_cell_method)) then
if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // &
'Can not set x_cell_method for rank<2.')
@@ -1356,11 +1378,7 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static)
allocate( locfield( ks:ke ) )
do k=ks,ke
- if (field(k) == diag_cs%missing_value) then
- locfield(k) = diag_cs%missing_value
- else
- locfield(k) = field(k) * diag%conversion_factor
- endif
+ locfield(k) = field(k) * diag%conversion_factor
enddo
else
locfield => field
@@ -1421,28 +1439,29 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask)
!! in internally scaled arbitrary units [A ~> a]
type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
- real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim]
+ real, optional, target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim]
! Local variables
real, dimension(:,:), pointer :: locfield ! The field being offered in arbitrary unscaled units [a]
real, dimension(:,:), pointer :: locmask ! A pointer to the data mask to use [nondim]
- character(len=300) :: mesg
- logical :: used, is_stat
+ logical :: used ! The return value of send_data is not used for anything.
+ logical :: is_stat, not_static
integer :: cszi, cszj, dszi, dszj
- integer :: isv, iev, jsv, jev, i, j, isv_o,jsv_o
+ integer :: isv, iev, jsv, jev, i, j, isv_o, jsv_o
real, dimension(:,:), allocatable, target :: locfield_dsamp ! A downsampled version of locfield [a]
real, dimension(:,:), allocatable, target :: locmask_dsamp ! A downsampled version of locmask [nondim]
integer :: dl
-
integer :: time_days
integer :: time_seconds
+ character(len=300) :: mesg
character(len=300) :: debug_mesg
locfield => NULL()
locmask => NULL()
is_stat = .false. ; if (present(is_static)) is_stat = is_static
+ not_static = .not. is_stat
- ! Determine the propery array indices, noting that because of the (:,:)
+ ! Determine the proper array indices, noting that because of the (:,:)
! declaration of field, symmetric arrays are using a SW-grid indexing,
! but non-symmetric arrays are using a NE-grid indexing. Send_data
! actually only uses the difference between ie and is to determine
@@ -1482,38 +1501,39 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask)
if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then
allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) )
do j=jsv,jev ; do i=isv,iev
- if (field(i,j) == diag_cs%missing_value) then
- locfield(i,j) = diag_cs%missing_value
- else
- locfield(i,j) = field(i,j) * diag%conversion_factor
- endif
+ locfield(i,j) = field(i,j) * diag%conversion_factor
enddo ; enddo
- locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor
else
locfield => field
endif
if (present(mask)) then
locmask => mask
- elseif (.NOT. is_stat) then
+ elseif (not_static .and. associated(diag%axes)) then
+ ! If we were to decide to allow masking of static diagnostics, we could do so by changing the line above to
+ ! elseif (associated(diag%axes) .and. (diag_CS%mask_static_diags .or. not_static)) then
if (associated(diag%axes%mask2d)) locmask => diag%axes%mask2d
endif
- dl=1
- if (.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet
- !Downsample the diag field and mask (if present)
+ dl = 1
+ if (not_static .and. associated(diag%axes)) &
+ dl = diag%axes%downsample_level ! Static field downsampling is not supported yet.
+ ! Downsample the diag field and mask as appropriate.
if (dl > 1) then
isv_o = isv ; jsv_o = jsv
- call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask)
+ call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield )
locfield => locfield_dsamp
if (present(mask)) then
- call downsample_field_2d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev)
+ call downsample_field_2d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs, diag, &
+ isv_o, jsv_o, isv, iev, jsv, jev)
locmask => locmask_dsamp
elseif (associated(diag%axes%dsamp(dl)%mask2d)) then
locmask => diag%axes%dsamp(dl)%mask2d
endif
endif
+ if (associated(locmask)) call assert(size(locfield) == size(locmask), &
+ 'post_data_2d_low: mask size mismatch: '//trim(diag%debug_str))
if (diag_cs%diag_as_chksum) then
! Append timestep to mesg
@@ -1538,22 +1558,15 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask)
endif
else
if (is_stat) then
- if (present(mask)) then
- call assert(size(locfield) == size(locmask), &
- 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str)
+ if (associated(locmask)) then
used = send_data_infra(diag%fms_diag_id, locfield, &
is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask)
- !elseif (associated(diag%axes%mask2d)) then
- ! used = send_data(diag%fms_diag_id, locfield, &
- ! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%axes%mask2d)
else
used = send_data_infra(diag%fms_diag_id, locfield, &
is_in=isv, ie_in=iev, js_in=jsv, je_in=jev)
endif
elseif (diag_cs%ave_enabled) then
if (associated(locmask)) then
- call assert(size(locfield) == size(locmask), &
- 'post_data_2d_low: mask size mismatch: '//diag%debug_str)
used = send_data_infra(diag%fms_diag_id, locfield, &
is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask)
@@ -1590,8 +1603,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h)
!! remapping this diagnostic [H ~> m or kg m-2].
real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: &
- dz_diag, & ! Layer vertical extents for remapping [Z ~> m]
- dz_begin ! Layer vertical extents for remapping extensive quantities [Z ~> m]
+ dz_diag ! Layer vertical extents for remapping [Z ~> m]
if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator)
@@ -1612,12 +1624,9 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h)
! Find out whether there are any z-based diagnostics
diag => diag_cs%diags(diag_field_id)
- dz_diag_needed = .false. ; dz_begin_needed = .false.
+ dz_diag_needed = .false.
do while (associated(diag))
- if (diag%v_extensive .and. .not.diag%axes%is_native) then
- if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) &
- dz_begin_needed = .true.
- elseif (diag%axes%needs_remapping .or. diag%axes%needs_interpolating) then
+ if (diag%axes%needs_remapping .or. diag%axes%needs_interpolating) then
if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) &
dz_diag_needed = .true.
endif
@@ -1628,9 +1637,6 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h)
if (dz_diag_needed) then
call thickness_to_dz(h_diag, diag_cs%tv, dz_diag, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1)
endif
- if (dz_begin_needed) then
- call thickness_to_dz(diag_cs%h_begin, diag_cs%tv, dz_begin, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1)
- endif
diag => diag_cs%diags(diag_field_id)
do while (associated(diag))
@@ -1650,7 +1656,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h)
if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then
call vertically_reintegrate_diag_field( &
diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, &
- dz_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, &
+ diag_cs%dz_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, &
staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field)
else
call vertically_reintegrate_diag_field( &
@@ -1718,8 +1724,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h)
endif
if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap)
if (associated(diag%axes%mask3d)) then
- ! Since 3d masks do not vary in the vertical, just use as much as is
- ! needed.
+ ! Since 3d masks do not vary in the vertical, just use as much as is needed.
call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
mask=diag%axes%mask3d)
else
@@ -1756,9 +1761,9 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
character(len=300) :: mesg
logical :: used ! The return value of send_data is not used for anything.
logical :: staggered_in_x, staggered_in_y
- logical :: is_stat
+ logical :: is_stat, not_static
integer :: cszi, cszj, dszi, dszj
- integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o
+ integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o, jsv_o
real, dimension(:,:,:), allocatable, target :: locfield_dsamp ! A downsampled version of locfield [a]
real, dimension(:,:,:), allocatable, target :: locmask_dsamp ! A downsampled version of locmask [nondim]
integer :: dl
@@ -1770,6 +1775,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
locfield => NULL()
locmask => NULL()
is_stat = .false. ; if (present(is_static)) is_stat = is_static
+ not_static = .not. is_stat
! Determine the proper array indices, noting that because of the (:,:)
! declaration of field, symmetric arrays are using a SW-grid indexing,
@@ -1829,11 +1835,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
endif
do k=ks,ke ; do j=jsv,jev ; do i=isv,iev
- if (field(i,j,k) == diag_cs%missing_value) then
- locfield(i,j,k) = diag_cs%missing_value
- else
- locfield(i,j,k) = field(i,j,k) * diag%conversion_factor
- endif
+ locfield(i,j,k) = field(i,j,k) * diag%conversion_factor
enddo ; enddo ; enddo
else
locfield => field
@@ -1841,25 +1843,31 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
if (present(mask)) then
locmask => mask
- elseif (associated(diag%axes%mask3d)) then
- locmask => diag%axes%mask3d
+ elseif (associated(diag%axes) .and. (not_static)) then
+ ! If we were to decide to allow masking of static diagnostics, we could do so by changing the line above to
+ ! elseif (associated(diag%axes) .and. (diag_CS%mask_static_diags .or. not_static)) then
+ if (associated(diag%axes%mask3d)) locmask => diag%axes%mask3d
endif
- dl=1
- if (.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet
- !Downsample the diag field and mask (if present)
+ dl = 1
+ if (not_static .and. associated(diag%axes)) &
+ dl = diag%axes%downsample_level ! Static field downsampling is not supported yet.
+ ! Downsample the diag field and mask as appropriate.
if (dl > 1) then
isv_o = isv ; jsv_o = jsv
- call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask)
+ call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield )
locfield => locfield_dsamp
if (present(mask)) then
- call downsample_field_3d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev)
+ call downsample_field_3d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs, diag, &
+ isv_o, jsv_o, isv, iev, jsv, jev)
locmask => locmask_dsamp
elseif (associated(diag%axes%dsamp(dl)%mask3d)) then
locmask => diag%axes%dsamp(dl)%mask3d
endif
endif
+ if (associated(locmask)) call assert(size(locfield) == size(locmask), &
+ 'post_data_3d_low: mask size mismatch: '//trim(diag%debug_str))
if (diag%fms_diag_id>0) then
if (diag_cs%diag_as_chksum) then
@@ -1885,22 +1893,15 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
endif
else
if (is_stat) then
- if (present(mask)) then
- call assert(size(locfield) == size(locmask), &
- 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str)
+ if (associated(locmask)) then
used = send_data_infra(diag%fms_diag_id, locfield, &
is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask)
- !elseif (associated(diag%axes%mask2d)) then
- ! used = send_data(diag%fms_diag_id, locfield, &
- ! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%axes%mask2d)
else
used = send_data_infra(diag%fms_diag_id, locfield, &
is_in=isv, ie_in=iev, js_in=jsv, je_in=jev)
endif
elseif (diag_cs%ave_enabled) then
if (associated(locmask)) then
- call assert(size(locfield) == size(locmask), &
- 'post_data_3d_low: mask size mismatch: '//diag%debug_str)
used = send_data_infra(diag%fms_diag_id, locfield, &
is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask)
@@ -1922,6 +1923,61 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
end subroutine post_data_3d_low
+!> Put data into the buffer for a diagnostic one column at a time
+subroutine post_data_3d_by_column(diag_field_id, field, diag_cs, i, j)
+ integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
+ !! previous call to register_diag_field.
+ real, dimension(:), intent(in) :: field !< 3-d array being offered for output or averaging
+ !! in internally scaled arbitrary units [A ~> a]
+ type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
+ integer, intent(in) :: i !< The i-index to post the data in the buffer
+ integer, intent(in) :: j !< The j-index to post the data in the buffer
+
+ type(diag_type), pointer :: diag => null()
+ integer :: buffer_slot
+
+ diag => diag_cs%diags(diag_field_id)
+ buffer_slot = diag%axes%piecemeal_3d%check_capacity_by_id(diag_field_id)
+ diag%axes%piecemeal_3d%buffer(buffer_slot)%field(i,j,:) = field(:)
+end subroutine post_data_3d_by_column
+
+!> Put data into the buffer for a diagnostic one point at a time
+subroutine post_data_3d_by_point(diag_field_id, field, diag_cs, i, j, k)
+ integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
+ !! previous call to register_diag_field.
+ real, intent(in) :: field !< 3-d array being offered for output or averaging
+ !! in internally scaled arbitrary units [A ~> a]
+ type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
+ integer, intent(in) :: i !< The i-index to post the data in the buffer
+ integer, intent(in) :: j !< The j-index to post the data in the buffer
+ integer, intent(in) :: k !< The k-index to post the data in the buffer
+
+ type(diag_type), pointer :: diag => null()
+ integer :: buffer_slot
+
+ diag => diag_cs%diags(diag_field_id)
+ buffer_slot = diag%axes%piecemeal_3d%check_capacity_by_id(diag_field_id)
+ diag%axes%piecemeal_3d%buffer(buffer_slot)%field(i,j,k) = field
+end subroutine post_data_3d_by_point
+
+!> Post the final buffer using the standard post_data interface
+subroutine post_data_3d_final(diag_field_id, diag_cs)
+ integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
+ !! previous call to register_diag_field.
+ type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
+
+ type(diag_type), pointer :: diag => null()
+ integer :: buffer_slot
+
+ diag => diag_cs%diags(diag_field_id)
+ buffer_slot = diag%axes%piecemeal_3d%find_buffer_slot(diag_field_id)
+ ! Only perform an action if the buffer slot was actually used
+ if (buffer_slot>0) then
+ call post_data(diag_field_id, diag%axes%piecemeal_3d%buffer(buffer_slot)%field(:,:,:), diag_CS)
+ call diag%axes%piecemeal_3d%mark_available(diag_field_id)
+ endif
+end subroutine post_data_3d_final
+
!> Calculate and write out diagnostics that are the product of two 3-d arrays at u-points
subroutine post_product_u(id, u_a, u_b, G, nz, diag, mask, alt_h)
integer, intent(in) :: id !< The ID for this diagnostic
@@ -2087,9 +2143,9 @@ end subroutine post_xy_average
!> This subroutine enables the accumulation of time averages over the specified time interval.
subroutine enable_averaging(time_int_in, time_end_in, diag_cs)
real, intent(in) :: time_int_in !< The time interval [s] over which any
- !! values that are offered are valid.
+ !! values that are offered are valid.
type(time_type), intent(in) :: time_end_in !< The end time of the valid interval
- type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output
+ type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output
! This subroutine enables the accumulation of time averages over the specified time interval.
@@ -2105,8 +2161,8 @@ subroutine enable_averages(time_int, time_end, diag_CS, T_to_s)
!! that are offered are valid [T ~> s].
type(time_type), intent(in) :: time_end !< The end time of the valid interval.
type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output
- real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to [s].
-! This subroutine enables the accumulation of time averages over the specified time interval.
+ real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to seconds [s T-1 ~> 1].
+ ! This subroutine enables the accumulation of time averages over the specified time interval.
if (present(T_to_s)) then
diag_cs%time_int = time_int*T_to_s
@@ -2201,7 +2257,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time
!! integrated). Default/absent for intensive.
! Local variables
real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a]
- type(diag_ctrl), pointer :: diag_cs
+ type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used to regulate diagnostic output
type(axes_grp), pointer :: remap_axes
type(axes_grp), pointer :: axes
type(axes_grp), pointer :: axes_d2
@@ -2209,7 +2265,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time
character(len=256) :: msg, cm_string
character(len=256) :: new_module_name
character(len=480) :: module_list, var_list
- character(len=16) :: dimensions
+ character(len=24) :: dimensions
integer :: num_modnm, num_varnm
logical :: active
@@ -2233,6 +2289,14 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time
axes => diag_cs%axesCui
elseif (axes_in%id == diag_cs%axesCvi%id) then
axes => diag_cs%axesCvi
+ elseif (axes_in%id == diag_cs%axesT1%id) then
+ axes => diag_cs%axesT1
+ elseif (axes_in%id == diag_cs%axesB1%id) then
+ axes => diag_cs%axesB1
+ elseif (axes_in%id == diag_cs%axesCu1%id) then
+ axes => diag_cs%axesCu1
+ elseif (axes_in%id == diag_cs%axesCv1%id) then
+ axes => diag_cs%axesCv1
else
allocate(axes)
axes = axes_in
@@ -2323,7 +2387,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time
endif ! axes%rank == 3
enddo ! i
- !Register downsampled diagnostics
+ ! Register downsampled diagnostics
do dl=2,MAX_DSAMP_LEV
! Do not attempt to checksum the downsampled diagnostics
if (diag_cs%diag_as_chksum) cycle
@@ -2437,14 +2501,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time
if (axes_in%is_v_point) dimensions = trim(dimensions)//" xh, yq,"
if (axes_in%is_layer) dimensions = trim(dimensions)//" zl,"
if (axes_in%is_interface) dimensions = trim(dimensions)//" zi,"
-
- if (len_trim(dimensions) > 0) then
- dimensions = trim(adjustl(dimensions))
- if (dimensions(len_trim(dimensions):len_trim(dimensions)) == ",") then
- dimensions = dimensions(1:len_trim(dimensions) - 1)
- endif
- dimensions = trim(dimensions)
- endif
+ if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions)
if (is_root_pe() .and. (diag_CS%available_diag_doc_unit > 0)) then
msg = ''
@@ -2464,7 +2521,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time
end function register_diag_field
-!> Returns True if either the native or CMOr version of the diagnostic were registered. Updates 'dm_id'
+!> Returns True if either the native or CMOR version of the diagnostic were registered. Updates 'dm_id'
!! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field.
logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, &
long_name, units, missing_value, range, mask_variant, standard_name, &
@@ -2474,7 +2531,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name,
integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group
character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model"
character(len=*), intent(in) :: field_name !< Name of the diagnostic field
- type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes
+ type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates axes
!! for this field
type(time_type), intent(in) :: init_time !< Time at which a field is first available?
character(len=*), optional, intent(in) :: long_name !< Long name of a field.
@@ -2517,7 +2574,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name,
type(diag_ctrl), pointer :: diag_cs => null()
type(diag_type), pointer :: this_diag => null()
integer :: fms_id, fms_xyave_id
- character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg
+ character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string
MOM_missing_value = axes%diag_cs%missing_value
if (present(missing_value)) MOM_missing_value = missing_value
@@ -2550,9 +2607,9 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name,
endif
this_diag => null()
if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then
- call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
+ call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name)
this_diag%fms_xyave_diag_id = fms_xyave_id
- !Encode and save the cell methods for this diag
+ ! Encode and save the cell methods for this diagnostic
call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
if (present(v_extensive)) this_diag%v_extensive = v_extensive
if (present(conversion)) this_diag%conversion_factor = conversion
@@ -2567,7 +2624,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name,
posted_cmor_long_name = "not provided" !
! If attributes are present for MOM variable names, use them first for the register_diag_field
- ! call for CMOR verison of the variable
+ ! call for CMOR version of the variable
if (present(units)) posted_cmor_units = units
if (present(standard_name)) posted_cmor_standard_name = standard_name
if (present(long_name)) posted_cmor_long_name = long_name
@@ -2599,9 +2656,9 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name,
endif
this_diag => null()
if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then
- call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
+ call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name)
this_diag%fms_xyave_diag_id = fms_xyave_id
- !Encode and save the cell methods for this diag
+ ! Encode and save the cell methods for this diagnostic
call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
if (present(v_extensive)) this_diag%v_extensive = v_extensive
if (present(conversion)) this_diag%conversion_factor = conversion
@@ -2619,7 +2676,7 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes,
character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
!! or "ice_shelf_model"
character(len=*), intent(in) :: field_name !< Name of the diagnostic field
- type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates
+ type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that indicates
!! axes for this field
type(time_type), intent(in) :: init_time !< Time at which a field is first available?
character(len=*), optional, intent(in) :: long_name !< Long name of a field.
@@ -2719,23 +2776,22 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes,
end function register_diag_field_expand_axes
!> Create a diagnostic type and attached to list
-subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
+subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name)
type(diag_ctrl), pointer :: diag_cs !< Diagnostics mediator control structure
integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group
integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic
type(diag_type), pointer :: this_diag !< This diagnostic
- type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that
+ type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that
!! indicates axes for this field
character(len=*), intent(in) :: module_name !< Name of this module, usually
!! "ocean_model" or "ice_shelf_model"
character(len=*), intent(in) :: field_name !< Name of diagnostic
- character(len=*), intent(in) :: msg !< Message for errors
! If the diagnostic is needed obtain a diag_mediator ID (if needed)
if (dm_id == -1) dm_id = get_new_diag_id(diag_cs)
! Create a new diag_type to store links in
call alloc_diag_with_id(dm_id, diag_cs, this_diag)
- call assert(associated(this_diag), trim(msg)//': diag_type allocation failed')
+ call assert(associated(this_diag), 'add_diag_to_list: allocation failed for '//trim(field_name))
! Record FMS id, masks and conversion factor, in diag_type
this_diag%fms_diag_id = fms_id
this_diag%debug_str = trim(module_name)//"-"//trim(field_name)
@@ -2760,12 +2816,12 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho
integer :: xyz_method
character(len=9) :: mstr
- !This is a simple way to encode the cell method information made from 3 strings
- !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz
- !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean'
- !We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in
- !the 100s position for x, 10s position for y, 1s position for z
- !E.g., x:sum,y:point,z:mean is 213
+ ! This is a simple way to encode the cell method information made from 3 strings
+ ! (x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz
+ ! x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean'
+ ! We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in
+ ! the 100s position for x, 10s position for y, 1s position for z
+ ! E.g., x:sum,y:point,z:mean is 213
xyz_method = 111
@@ -2810,7 +2866,7 @@ end subroutine add_xyz_method
subroutine attach_cell_methods(id, axes, ostring, cell_methods, &
x_cell_method, y_cell_method, v_cell_method, v_extensive)
integer, intent(in) :: id !< Handle to diagnostic
- type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates
+ type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates
!! axes for this field
character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file
character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute.
@@ -2924,10 +2980,52 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, &
ostring = adjustl(ostring)
end subroutine attach_cell_methods
-function register_scalar_field(module_name, field_name, init_time, diag_cs, &
+
+!> Registers a non-array scalar diagnostic, returning an integer handle
+function register_scalar_field_axes(module_name, field_name, axes, init_time, &
+ long_name, units, missing_value, range, standard_name, &
+ do_not_log, err_msg, interp_method, cmor_field_name, &
+ cmor_long_name, cmor_units, cmor_standard_name, conversion) result (register_scalar_field)
+ integer :: register_scalar_field !< An integer handle for a diagnostic array.
+ character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
+ !! or "ice_shelf_model"
+ character(len=*), intent(in) :: field_name !< Name of the diagnostic field
+ type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that
+ !! indicates axes for this field
+ type(time_type), intent(in) :: init_time !< Time at which a field is first available?
+ character(len=*), optional, intent(in) :: long_name !< Long name of a field.
+ character(len=*), optional, intent(in) :: units !< Units of a field.
+ character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
+ real, optional, intent(in) :: missing_value !< A value that indicates missing values in
+ !! output files, in unscaled arbitrary units [a]
+ real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
+ !! in arbitrary units [a]
+ logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
+ character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
+ !! placed (not used in MOM?)
+ character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not
+ !! be interpolated as a scalar
+ character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
+ character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
+ character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
+ character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
+ real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files,
+ !! often including factors to undo internal scaling and
+ !! in units of [a A-1 ~> 1]
+
+ register_scalar_field = register_scalar_field_CS(module_name, field_name, init_time, axes%diag_cs, &
long_name, units, missing_value, range, standard_name, &
do_not_log, err_msg, interp_method, cmor_field_name, &
cmor_long_name, cmor_units, cmor_standard_name, conversion)
+
+end function register_scalar_field_axes
+
+
+!> Registers a scalar diagnostic, returning an integer handle
+function register_scalar_field_CS(module_name, field_name, init_time, diag_cs, &
+ long_name, units, missing_value, range, standard_name, &
+ do_not_log, err_msg, interp_method, cmor_field_name, &
+ cmor_long_name, cmor_units, cmor_standard_name, conversion) result (register_scalar_field)
integer :: register_scalar_field !< An integer handle for a diagnostic array.
character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
!! or "ice_shelf_model"
@@ -2993,13 +3091,13 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, &
posted_cmor_standard_name = "not provided"
posted_cmor_long_name = "not provided"
- ! If attributes are present for MOM variable names, use them first for the register_static_field
- ! call for CMOR verison of the variable
+ ! If attributes are present for MOM variable names, use them as defaults for the
+ ! register_diag_field_infra call for CMOR version of the variable
if (present(units)) posted_cmor_units = units
if (present(standard_name)) posted_cmor_standard_name = standard_name
if (present(long_name)) posted_cmor_long_name = long_name
- ! If specified in the call to register_static_field, override attributes with the CMOR versions
+ ! If specified in the call to register_scalar_field, override attributes with the CMOR versions
if (present(cmor_units)) posted_cmor_units = cmor_units
if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
@@ -3036,7 +3134,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, &
register_scalar_field = dm_id
-end function register_scalar_field
+end function register_scalar_field_CS
!> Registers a static diagnostic, returning an integer handle
function register_static_field(module_name, field_name, axes, &
@@ -3048,7 +3146,7 @@ function register_static_field(module_name, field_name, axes, &
character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
!! or "ice_shelf_model"
character(len=*), intent(in) :: field_name !< Name of the diagnostic field
- type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that
+ type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that
!! indicates axes for this field
character(len=*), optional, intent(in) :: long_name !< Long name of a field.
character(len=*), optional, intent(in) :: units !< Units of a field.
@@ -3077,12 +3175,12 @@ function register_static_field(module_name, field_name, axes, &
! Local variables
real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a]
- type(diag_ctrl), pointer :: diag_cs => null()
+ type(diag_ctrl), pointer :: diag_cs => null() !< A structure that is used to regulate diagnostic output
type(diag_type), pointer :: diag => null(), cmor_diag => null()
integer :: dm_id, fms_id
character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
character(len=9) :: axis_name
- character(len=16) :: dimensions
+ character(len=24) :: dimensions
MOM_missing_value = axes%diag_cs%missing_value
if (present(missing_value)) MOM_missing_value = missing_value
@@ -3138,7 +3236,7 @@ function register_static_field(module_name, field_name, axes, &
posted_cmor_long_name = "not provided"
! If attributes are present for MOM variable names, use them first for the register_static_field
- ! call for CMOR verison of the variable
+ ! call for CMOR version of the variable
if (present(units)) posted_cmor_units = units
if (present(standard_name)) posted_cmor_standard_name = standard_name
if (present(long_name)) posted_cmor_long_name = long_name
@@ -3182,14 +3280,7 @@ function register_static_field(module_name, field_name, axes, &
if (axes%is_v_point) dimensions = trim(dimensions)//" xh, yq,"
if (axes%is_layer) dimensions = trim(dimensions)//" zl,"
if (axes%is_interface) dimensions = trim(dimensions)//" zi,"
-
- if (len_trim(dimensions) > 0) then
- dimensions = trim(adjustl(dimensions))
- if (dimensions(len_trim(dimensions):len_trim(dimensions)) == ",") then
- dimensions = dimensions(1:len_trim(dimensions) - 1)
- endif
- dimensions = trim(dimensions)
- endif
+ if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions)
! Document diagnostics in list of available diagnostics
if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then
@@ -3224,13 +3315,13 @@ subroutine describe_option(opt_name, value, diag_CS)
end subroutine describe_option
!> Registers a diagnostic using the information encapsulated in the vardesc
-!! type argument and returns an integer handle to this diagostic. That
+!! type argument and returns an integer handle to this diagnostic. That
!! integer handle is negative if the diagnostic is unused.
function ocean_register_diag(var_desc, G, diag_CS, day)
integer :: ocean_register_diag !< An integer handle to this diagnostic.
type(vardesc), intent(in) :: var_desc !< The vardesc type describing the diagnostic
type(ocean_grid_type), intent(in) :: G !< The ocean's grid type
- type(diag_ctrl), intent(in), target :: diag_CS !< The diagnotic control structure
+ type(diag_ctrl), intent(in), target :: diag_CS !< The diagnostic control structure
type(time_type), intent(in) :: day !< The current model time
character(len=64) :: var_name ! A variable's name.
@@ -3336,13 +3427,14 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
! forms of the same remapping expressions.
integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags.
logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for diagnostics
+ logical :: dz_diag_needed ! Logical set True if we need to store dz_begin for reintegrating
character(len=8) :: this_pe
character(len=240) :: doc_file, doc_file_dflt, doc_path
character(len=240), allocatable :: diag_coords(:)
! This include declares and sets the variable "version".
# include "version_variable.h"
character(len=40) :: mdl = "MOM_diag_mediator" ! This module's name.
- character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs
+ character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs
id_clock_diag_mediator = cpu_clock_id('(Ocean diagnostics framework)', grain=CLOCK_MODULE)
id_clock_diag_remap = cpu_clock_id('(Ocean diagnostics remapping)', grain=CLOCK_ROUTINE)
@@ -3384,6 +3476,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
'If true, use a grid index coordinate convention for diagnostic axes. ',&
default=.false.)
+ dz_diag_needed = .false.
if (diag_cs%num_diag_coords>0) then
allocate(diag_coords(diag_cs%num_diag_coords))
if (diag_cs%num_diag_coords==1) then ! The default is to provide just one instance of Z*
@@ -3403,6 +3496,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
! Initialize each diagnostic vertical coordinate
do i=1, diag_cs%num_diag_coords
call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), om4_remap_via_sub_cells, remap_answer_date, GV)
+ if (diag_cs%diag_remap_cs(i)%Z_based_coord) dz_diag_needed = .true.
enddo
deallocate(diag_coords)
endif
@@ -3429,6 +3523,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
diag_cs%tv => null()
allocate(diag_cs%h_begin(G%isd:G%ied,G%jsd:G%jed,nz))
+ if (dz_diag_needed) allocate(diag_cs%dz_begin(G%isd:G%ied,G%jsd:G%jed,nz))
#if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
allocate(diag_cs%h_old(G%isd:G%ied,G%jsd:G%jed,nz))
diag_cs%h_old(:,:,:) = 0.0
@@ -3439,7 +3534,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
diag_cs%isd = G%isd ; diag_cs%ied = G%ied
diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed
- !Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array)
+ ! Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array)
diag_cs%dsamp(2)%isc = G%HId2%isc - (G%HId2%isd-1) ; diag_cs%dsamp(2)%iec = G%HId2%iec - (G%HId2%isd-1)
diag_cs%dsamp(2)%jsc = G%HId2%jsc - (G%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = G%HId2%jec - (G%HId2%jsd-1)
diag_cs%dsamp(2)%isd = G%HId2%isd ; diag_cs%dsamp(2)%ied = G%HId2%ied
@@ -3489,8 +3584,8 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
endif
if (is_root_pe() .and. (diag_CS%chksum_iounit < 0) .and. diag_CS%diag_as_chksum) then
- !write(this_pe,'(i6.6)') PE_here()
- !doc_file_dflt = "chksum_diag."//this_pe
+ ! write(this_pe,'(i6.6)') PE_here()
+ ! doc_file_dflt = "chksum_diag."//this_pe
doc_file_dflt = "chksum_diag"
call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, &
"A file into which to write all checksums of the "//&
@@ -3541,8 +3636,8 @@ end subroutine diag_mediator_init
!> Set pointers to the default state fields used to remap diagnostics.
subroutine diag_set_state_ptrs(h, tv, diag_cs)
real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array [H ~> m or kg m-2]
- type(thermo_var_ptrs), target, intent(in ) :: tv !< A sturcture with thermodynamic variables that are
- !! are used to convert thicknesses to vertical extents
+ type(thermo_var_ptrs), target, intent(in ) :: tv !< A structure with thermodynamic variables that are
+ !! used to convert thicknesses to vertical extents
type(diag_ctrl), intent(inout) :: diag_cs !< diag mediator control structure
! Keep pointers to h, T, S needed for the diagnostic remapping
@@ -3571,7 +3666,7 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv
!! intensive diagnostics
! Local variables
integer :: m
- real, dimension(:,:,:), pointer :: h_diag => NULL() ! The layer thickneses for diagnostics [H ~> m or kg m-2]
+ real, dimension(:,:,:), pointer :: h_diag => NULL() ! The layer thicknesses for diagnostics [H ~> m or kg m-2]
real, dimension(:,:,:), pointer :: T_diag => NULL() ! The layer temperatures for diagnostics [C ~> degC]
real, dimension(:,:,:), pointer :: S_diag => NULL() ! The layer salinities for diagnostics [S ~> ppt]
real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: &
@@ -3639,6 +3734,7 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv
endif
if (update_extensive_local) then
diag_cs%h_begin(:,:,:) = diag_cs%h(:,:,:)
+ if (dz_diag_needed) diag_cs%dz_begin(:,:,:) = dz_diag(:,:,:)
do m=1, diag_cs%num_diag_coords
if (diag_cs%diag_remap_cs(m)%Z_based_coord) then
call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, T_diag, S_diag, &
@@ -3700,11 +3796,34 @@ subroutine diag_masks_set(G, nz, diag_cs)
diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:)
enddo
- !Allocate and initialize the downsampled masks
+ ! Allocate and initialize the downsampled masks
call downsample_diag_masks_set(G, nz, diag_cs)
end subroutine diag_masks_set
+!> Set the extents and fill values for the piecemeal buffers for all axes
+subroutine set_piecemeal_extents(diag_cs)
+ type(diag_ctrl), intent(inout) :: diag_cs !< A pointer to a type with many variables
+ !! used for diagnostics
+
+ ! Piecemeal buffers for 2d axes
+ call diag_cs%axesT1%piecemeal_2d%set_extents_from_array(diag_cs%mask2dT, diag_cs%missing_value)
+ call diag_cs%axesB1%piecemeal_2d%set_extents_from_array(diag_cs%mask2dBu, diag_cs%missing_value)
+ call diag_cs%axesCu1%piecemeal_2d%set_extents_from_array(diag_cs%mask2dCu, diag_cs%missing_value)
+ call diag_cs%axesCv1%piecemeal_2d%set_extents_from_array(diag_cs%mask2dCv, diag_cs%missing_value)
+
+ ! Piecemeal buffers for 3d axes
+ call diag_cs%axesTL%piecemeal_3d%set_extents_from_array(diag_cs%mask3dTL, diag_cs%missing_value)
+ call diag_cs%axesBL%piecemeal_3d%set_extents_from_array(diag_cs%mask3dBL, diag_cs%missing_value)
+ call diag_cs%axesCuL%piecemeal_3d%set_extents_from_array(diag_cs%mask3dCuL, diag_cs%missing_value)
+ call diag_cs%axesCvL%piecemeal_3d%set_extents_from_array(diag_cs%mask3dCvL, diag_cs%missing_value)
+ call diag_cs%axesTi%piecemeal_3d%set_extents_from_array(diag_cs%mask3dTi, diag_cs%missing_value)
+ call diag_cs%axesBi%piecemeal_3d%set_extents_from_array(diag_cs%mask3dBi, diag_cs%missing_value)
+ call diag_cs%axesCui%piecemeal_3d%set_extents_from_array(diag_cs%mask3dCui, diag_cs%missing_value)
+ call diag_cs%axesCvi%piecemeal_3d%set_extents_from_array(diag_cs%mask3dCvi, diag_cs%missing_value)
+
+end subroutine set_piecemeal_extents
+
subroutine diag_mediator_close_registration(diag_CS)
type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output
@@ -3861,28 +3980,6 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager)
end subroutine diag_mediator_end
-!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string.
-function i2s(a,n_in)
- ! "Convert the first n elements of an integer array to a string."
- ! Perhaps this belongs elsewhere in the MOM6 code?
- integer, dimension(:), intent(in) :: a !< The array of integers to translate
- integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all
- character(len=15) :: i2s !< The returned string
-
- character(len=15) :: i2s_temp
- integer :: i,n
-
- n=size(a)
- if (present(n_in)) n = n_in
-
- i2s = ''
- do i=1,min(n,3)
- write (i2s_temp, '(I4.4)') a(i)
- i2s = trim(i2s) //'_'// trim(i2s_temp)
- enddo
- i2s = adjustl(i2s)
-end function i2s
-
!> Returns a new diagnostic id, it may be necessary to expand the diagnostics array.
integer function get_new_diag_id(diag_cs)
type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
@@ -3927,7 +4024,7 @@ subroutine initialize_diag_type(diag)
end subroutine initialize_diag_type
!> Make a new diagnostic. Either use memory which is in the array of 'primary'
-!! diagnostics, or if that is in use, insert it to the list of secondary diags.
+!! diagnostics, or if that is in use, insert it to the list of secondary diagnostics.
subroutine alloc_diag_with_id(diag_id, diag_cs, diag)
integer, intent(in ) :: diag_id !< id for the diagnostic
type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output
@@ -3955,7 +4052,7 @@ subroutine log_available_diag(used, module_name, field_name, cell_methods_string
character(len=*), intent(in) :: field_name !< Name of this diagnostic field
character(len=*), intent(in) :: cell_methods_string !< The spatial component of the CF cell_methods attribute
character(len=*), intent(in) :: comment !< A comment to append after [Used|Unused]
- type(diag_ctrl), intent(in) :: diag_CS !< The diagnotics control structure
+ type(diag_ctrl), intent(in) :: diag_CS !< The diagnostics control structure
character(len=*), optional, intent(in) :: dimensions !< Descriptor of the horizontal and vertical dimensions
character(len=*), optional, intent(in) :: long_name !< CF long name of diagnostic
character(len=*), optional, intent(in) :: units !< Units for diagnostic
@@ -4008,7 +4105,7 @@ subroutine diag_grid_storage_init(grid_storage, G, GV, diag)
type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids
type(ocean_grid_type), intent(in) :: G !< Horizontal grid
type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure
- type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor
+ type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the constructor
!! template for this routine
integer :: m, nz
@@ -4033,7 +4130,7 @@ end subroutine diag_grid_storage_init
subroutine diag_copy_diag_to_storage(grid_storage, h_state, diag)
type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids
real, dimension(:,:,:), intent(in) :: h_state !< Current model thicknesses [H ~> m or kg m-2]
- type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor
+ type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the constructor
integer :: m
@@ -4050,7 +4147,7 @@ end subroutine diag_copy_diag_to_storage
!> Copy from the stored diagnostic arrays to the main diagnostic grids
subroutine diag_copy_storage_to_diag(diag, grid_storage)
- type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor
+ type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the constructor
type(diag_grid_storage), intent(in) :: grid_storage !< Structure containing a snapshot of the target grids
integer :: m
@@ -4068,7 +4165,7 @@ end subroutine diag_copy_storage_to_diag
!> Save the current diagnostic grids in the temporary structure within diag
subroutine diag_save_grids(diag)
- type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor
+ type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the constructor
integer :: m
@@ -4084,7 +4181,7 @@ end subroutine diag_save_grids
!> Restore the diagnostic grids from the temporary structure within diag
subroutine diag_restore_grids(diag)
- type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor
+ type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the constructor
integer :: m
@@ -4118,7 +4215,7 @@ subroutine diag_grid_storage_end(grid_storage)
deallocate(grid_storage%diag_grids)
end subroutine diag_grid_storage_end
-!< Allocate and initialize the masks for downsampled diagostics in diag_cs
+!< Allocate and initialize the masks for downsampled diagnostics in diag_cs
!! The downsampled masks in the axes would later "point" to these.
subroutine downsample_diag_masks_set(G, nz, diag_cs)
type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type.
@@ -4178,7 +4275,7 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs)
end subroutine downsample_diag_masks_set
!> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of
-!! the diag field (the same way they are deduced for non-downsampled fields)
+!! the diagnostic field (the same way they are deduced for non-downsampled fields)
subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev)
integer, intent(in) :: fo1 !< The size of the diag field in x
integer, intent(in) :: fo2 !< The size of the diag field in y
@@ -4189,16 +4286,15 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev
integer, intent(out) :: jsv !< j-start index for diagnostics
integer, intent(out) :: jev !< j-end index for diagnostics
! Local variables
- integer :: dszi,cszi,dszj,cszj,f1,f2
+ integer :: dszi, cszi, dszj, cszj, f1, f2
character(len=500) :: mesg
logical, save :: first_check = .true.
- !Check ONCE that the downsampled diag-compute domain is commensurate with the original
- !non-downsampled diag-compute domain.
- !This is a major limitation of the current implementation of the downsampled diagnostics.
- !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates.
- !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is
- !why the check is here and not in the init routines. This check need to be done only once, hence the outer if.
+ ! The current implementation of the downsampled diagnostics assumes that the tracer-point
+ ! computational domain on each processor can be evenly divided by dL in each direction, which
+ ! avoids the need for halo updates or checks that the halo regions are up-to-date. The following
+ ! check that this assumption is true is only relevant if there are in fact downsampled diagnostics,
+ ! which is why it occurs during the first call to this routine instead of during initialization.
if (first_check) then
if (mod(diag_cs%ie-diag_cs%is+1, dl) /= 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) /= 0) then
write (mesg,*) "Non-commensurate downsampled domain is not supported. "//&
@@ -4215,14 +4311,15 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev
jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec
f1 = fo1/dl
f2 = fo2/dl
- !Correction for the symmetric case
+ ! Correction for the symmetric case
if (diag_cs%G%symmetric) then
f1 = f1 + mod(fo1,dl)
f2 = f2 + mod(fo2,dl)
endif
+
+ ! Find the range of indices in the downscaled computational domain.
if ( f1 == dszi ) then
- isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies
- !The rest is not taken with the full MOM6 diag_table
+ isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! Field on Data domain, take compute domain indices
elseif ( f1 == dszi + 1 ) then
isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain
elseif ( f1 == cszi) then
@@ -4249,8 +4346,8 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev
endif
end subroutine downsample_diag_indices_get
-!> This subroutine allocates and computes a downsampled array from an input array
-!! It also determines the diagnostics-compurte indices for the downsampled array
+!> This subroutine allocates and computes a downsampled array from an input array.
+!! It also determines the diagnostic computational grid indices for the downsampled array.
!! 3d interface
subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
real, dimension(:,:,:), pointer :: locfield !< Input array pointer in arbitrary units [A ~> a]
@@ -4263,20 +4360,19 @@ subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag,
integer, intent(inout) :: jsv !< j-start index for diagnostics
integer, intent(inout) :: jev !< j-end index for diagnostics
real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim]
- ! Locals
+ ! Local variables
real, dimension(:,:,:), pointer :: locmask ! A pointer to the mask [nondim]
- integer :: f1,f2,isv_o,jsv_o
+ integer :: f1, f2, isv_o, jsv_o
locmask => NULL()
- !Get the correct indices corresponding to input field
- !Shape of the input diag field
+ ! Get the correct indices corresponding to input field based on its shape.
f1 = size(locfield, 1)
f2 = size(locfield, 2)
- !Save the extents of the original (fine) domain
+ ! Save the extents of the original (fine) domain
isv_o = isv ; jsv_o = jsv
- !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them
+ ! Get the shape of the downsampled field and overwrite isv, iev, jsv and jev with them
call downsample_diag_indices_get(f1, f2, dl, diag_cs, isv, iev, jsv, jev)
- !Set the non-downsampled mask, it must be associated and initialized
+ ! Set the pointer to the non-downsampled mask, which must be associated and initialized
if (present(mask)) then
locmask => mask
elseif (associated(diag%axes%mask3d)) then
@@ -4290,8 +4386,8 @@ subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag,
end subroutine downsample_diag_field_3d
-!> This subroutine allocates and computes a downsampled array from an input array
-!! It also determines the diagnostics-compurte indices for the downsampled array
+!> This subroutine allocates and computes a downsampled array from an input array.
+!! It also determines the diagnostic computational grid indices for the downsampled array.
!! 2d interface
subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
real, dimension(:,:), pointer :: locfield !< Input array pointer in arbitrary units [A ~> a]
@@ -4304,20 +4400,19 @@ subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag,
integer, intent(inout) :: jsv !< j-start index for diagnostics
integer, intent(inout) :: jev !< j-end index for diagnostics
real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim].
- ! Locals
+ ! Local variables
real, dimension(:,:), pointer :: locmask ! A pointer to the mask [nondim]
- integer :: f1,f2,isv_o,jsv_o
+ integer :: f1, f2, isv_o, jsv_o
locmask => NULL()
- !Get the correct indices corresponding to input field
- !Shape of the input diag field
+ ! Get the correct indices corresponding to input field based on its shape.
f1 = size(locfield,1)
f2 = size(locfield,2)
- !Save the extents of the original (fine) domain
+ ! Save the extents of the original (fine) domain
isv_o = isv ; jsv_o = jsv
- !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them
- call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev)
- !Set the non-downsampled mask, it must be associated and initialized
+ ! Get the shape of the downsampled field and overwrite isv, iev, jsv and jev with them
+ call downsample_diag_indices_get(f1, f2, dl, diag_cs, isv, iev, jsv, jev)
+ ! Set the non-downsampled mask, it must be associated and initialized
if (present(mask)) then
locmask => mask
elseif (associated(diag%axes%mask2d)) then
@@ -4327,7 +4422,7 @@ subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag,
endif
call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, &
- isv_o,jsv_o,isv,iev,jsv,jev)
+ isv_o, jsv_o, isv, iev, jsv, jev)
end subroutine downsample_diag_field_2d
@@ -4336,7 +4431,7 @@ end subroutine downsample_diag_field_2d
!! The down sample method could be deduced (before send_data call)
!! from the diag%x_cell_method, diag%y_cell_method and diag%v_cell_method
!!
-!! This is the summary of the down sample algoritm for a diagnostic field f:
+!! This is the summary of the down sample algorithm for a diagnostic field f:
!! \f[
!! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)]
!! \f]
@@ -4368,9 +4463,10 @@ end subroutine downsample_diag_field_2d
!> This subroutine allocates and computes a down sampled 3d array given an input array
!! The down sample method is based on the "cell_methods" for the diagnostics as explained
!! in the above table
-subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d)
+subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag, &
+ isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d)
real, dimension(:,:,:), pointer :: field_in !< Original field to be downsampled in arbitrary units [A ~> a]
- real, dimension(:,:,:), allocatable :: field_out !< Downsampled field in the same arbtrary units [A ~> a]
+ real, dimension(:,:,:), allocatable :: field_out !< Downsampled field in the same arbitrary units [A ~> a]
integer, intent(in) :: dl !< Level of down sampling
integer, intent(in) :: method !< Sampling method
real, dimension(:,:,:), pointer :: mask !< Mask for field [nondim]
@@ -4382,13 +4478,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d
integer, intent(in) :: iev_d !< i-end index of down sampled data
integer, intent(in) :: jsv_d !< j-start index of down sampled data
integer, intent(in) :: jev_d !< j-end index of down sampled data
- ! Locals
+ ! Local variables
character(len=240) :: mesg
- integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2
- integer :: k,ks,ke
+ integer :: i, j, ii, jj, i0, j0, f1, f2, f_in1, f_in2
+ integer :: k, ks, ke
real :: ave ! The running sum of the average, in [A ~> a], [A L2 ~> a m2],
! [A H L ~> a m2 or a kg m-1] or [A H L2 ~> a m3 or a kg]
- real :: weight ! The nondimensional, area-, volume- or mass--based weight for an input
+ real :: weight ! The nondimensional, area-, volume- or mass-based weight for an input
! value [nondim], [L2 ~> m2], [H L ~> m2 or kg m-1] or [H L2 ~> m3 or kg]
real :: total_weight ! The sum of weights contributing to a point [nondim], [L2 ~> m2],
! [H L ~> m2 or kg m-1] or [H L2 ~> m3 or kg]
@@ -4408,15 +4504,16 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d
f_in2 = size(field_in,2)
f1 = f_in1/dl
f2 = f_in2/dl
- !Correction for the symmetric case
+ ! Correction for the symmetric case
if (diag_cs%G%symmetric) then
f1 = f1 + mod(f_in1,dl)
f2 = f2 + mod(f_in2,dl)
endif
allocate(field_out(1:f1,1:f2,ks:ke))
- ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain
+ ! Fill the down sampled field on the down sampled diagnostics (almost always compute) domain
!### The averaging used here is not rotationally invariant.
+ ! Also, it would be better to use a max with eps_vol instead of adding it in the denominator.
if (method == MMM) then
do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
i0 = isv_o+dl*(i-isv_d)
@@ -4424,14 +4521,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d
ave = 0.0
total_weight = 0.0
do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
-! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!!
weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k)
total_weight = total_weight + weight
ave = ave+field_in(ii,jj,k) * weight
enddo ; enddo
- field_out(i,j,k) = ave/(total_weight + eps_vol) !Avoid zero mask at all aggregating cells where ave=0.0
+ field_out(i,j,k) = ave / (total_weight + eps_vol) ! Eps_vol avoids division by 0.
enddo ; enddo ; enddo
- elseif (method == SSS) then !e.g., volcello
+ elseif (method == SSS) then ! e.g., volcello
do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
i0 = isv_o+dl*(i-isv_d)
j0 = jsv_o+dl*(j-jsv_d)
@@ -4440,21 +4536,20 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d
weight = mask(ii,jj,k)
ave = ave+field_in(ii,jj,k)*weight
enddo ; enddo
- field_out(i,j,k) = ave !Masked Sum (total_weight=1)
+ field_out(i,j,k) = ave ! This is a masked sum, and total_weight = 1.
enddo ; enddo ; enddo
- elseif (method == MMP .or. method == MMS) then !e.g., T_advection_xy
+ elseif (method == MMP .or. method == MMS) then ! e.g., T_advection_xy
do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
i0 = isv_o+dl*(i-isv_d)
j0 = jsv_o+dl*(j-jsv_d)
ave = 0.0
total_weight = 0.0
do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
-! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1
weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj)
total_weight = total_weight + weight
- ave = ave+field_in(ii,jj,k)*weight
+ ave = ave+field_in(ii,jj,k) * weight
enddo ; enddo
- field_out(i,j,k) = ave / (total_weight+eps_area) !Avoid zero mask at all aggregating cells where ave=0.0
+ field_out(i,j,k) = ave / (total_weight + eps_area) ! Eps_area avoids division by 0.
enddo ; enddo ; enddo
elseif (method == PMM) then
do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
@@ -4465,12 +4560,12 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d
ii=i0
do jj=j0,j0+dl-1
weight = mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k)
- total_weight = total_weight +weight
- ave = ave+field_in(ii,jj,k)*weight
+ total_weight = total_weight + weight
+ ave = ave+field_in(ii,jj,k) * weight
enddo
- field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0
+ field_out(i,j,k) = ave / (total_weight + eps_face) ! Eps_face avoids division by 0.
enddo ; enddo ; enddo
- elseif (method == PSS) then !e.g. umo
+ elseif (method == PSS) then ! e.g. umo
do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
i0 = isv_o+dl*(i-isv_d)
j0 = jsv_o+dl*(j-jsv_d)
@@ -4480,9 +4575,9 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d
weight = mask(ii,jj,k)
ave = ave+field_in(ii,jj,k)*weight
enddo
- field_out(i,j,k) = ave !Masked Sum (total_weight=1)
+ field_out(i,j,k) = ave ! This is a masked sum, and total_weight = 1.
enddo ; enddo ; enddo
- elseif (method == SPS) then !e.g. vmo
+ elseif (method == SPS) then ! e.g. vmo
do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
i0 = isv_o+dl*(i-isv_d)
j0 = jsv_o+dl*(j-jsv_d)
@@ -4492,7 +4587,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d
weight = mask(ii,jj,k)
ave = ave+field_in(ii,jj,k)*weight
enddo
- field_out(i,j,k) = ave !Masked Sum (total_weight=1)
+ field_out(i,j,k) = ave ! This is a masked sum, and total_weight = 1.
enddo ; enddo ; enddo
elseif (method == MPM) then
do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
@@ -4504,11 +4599,11 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d
do ii=i0,i0+dl-1
weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k)
total_weight = total_weight + weight
- ave = ave+field_in(ii,jj,k)*weight
+ ave = ave+field_in(ii,jj,k) * weight
enddo
- field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0
+ field_out(i,j,k) = ave / (total_weight + eps_face) ! Eps_face avoids division by 0.
enddo ; enddo ; enddo
- elseif (method == MSK) then !The input field is a mask, subsample
+ elseif (method == MSK) then ! The input field is a mask, so subsample it instead of averaging.
field_out(:,:,:) = 0.0
do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
i0 = isv_o+dl*(i-isv_d)
@@ -4532,7 +4627,7 @@ end subroutine downsample_field_3d
subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, diag, &
isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d)
real, dimension(:,:), pointer :: field_in !< Original field to be downsampled in arbitrary units [A ~> a]
- real, dimension(:,:), allocatable :: field_out !< Downsampled field in the same arbtrary units [A ~> a]
+ real, dimension(:,:), allocatable :: field_out !< Downsampled field in the same arbitrary units [A ~> a]
integer, intent(in) :: dl !< Level of down sampling
integer, intent(in) :: method !< Sampling method
real, dimension(:,:), pointer :: mask !< Mask for field [nondim]
@@ -4544,9 +4639,9 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d
integer, intent(in) :: iev_d !< i-end index of down sampled data
integer, intent(in) :: jsv_d !< j-start index of down sampled data
integer, intent(in) :: jev_d !< j-end index of down sampled data
- ! Locals
+ ! Local variables
character(len=240) :: mesg
- integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2
+ integer :: i, j, ii, jj, i0, j0, f1, f2, f_in1, f_in2
real :: ave ! The running sum of the average, in [A ~> a] or [A L2 ~> a m2]
real :: weight ! The nondimensional or area-weighted weight for an input value [nondim] or [L2 ~> m2]
real :: total_weight ! The sum of weights contributing to a point [nondim] or [L2 ~> m2]
@@ -4559,7 +4654,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d
! Allocate the down sampled field on the down sampled data domain
! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed))
! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl))
- ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain
+ ! Fill the down sampled field on the down sampled diagnostics (almost always compute) domain
f_in1 = size(field_in,1)
f_in2 = size(field_in,2)
f1 = f_in1/dl
@@ -4578,12 +4673,11 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d
ave = 0.0
total_weight = 0.0
do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
-! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1
weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)
total_weight = total_weight + weight
- ave = ave+field_in(ii,jj)*weight
+ ave = ave+field_in(ii,jj) * weight
enddo ; enddo
- field_out(i,j) = ave/(total_weight + eps_area) !Avoid zero mask at all aggregating cells where ave=0.0
+ field_out(i,j) = ave / (total_weight + eps_area) ! Eps_area avoids division by 0.
enddo ; enddo
elseif (method == SSP) then ! e.g., T_dfxy_cont_tendency_2d
do j=jsv_d,jev_d ; do i=isv_d,iev_d
@@ -4591,11 +4685,10 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d
j0 = jsv_o+dl*(j-jsv_d)
ave = 0.0
do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
-! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1
weight = mask(ii,jj)
ave = ave+field_in(ii,jj)*weight
enddo ; enddo
- field_out(i,j) = ave !Masked Sum (total_weight=1)
+ field_out(i,j) = ave ! This is a masked sum, and total_weight = 1.
enddo ; enddo
elseif (method == PSP) then ! e.g., umo_2d
do j=jsv_d,jev_d ; do i=isv_d,iev_d
@@ -4607,7 +4700,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d
weight = mask(ii,jj)
ave = ave+field_in(ii,jj)*weight
enddo
- field_out(i,j) = ave !Masked Sum (total_weight=1)
+ field_out(i,j) = ave ! This is a masked sum, and total_weight = 1.
enddo ; enddo
elseif (method == SPP) then ! e.g., vmo_2d
do j=jsv_d,jev_d ; do i=isv_d,iev_d
@@ -4619,7 +4712,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d
weight = mask(ii,jj)
ave = ave+field_in(ii,jj)*weight
enddo
- field_out(i,j) = ave !Masked Sum (total_weight=1)
+ field_out(i,j) = ave ! This is a masked sum, and total_weight = 1.
enddo ; enddo
elseif (method == PMP) then
do j=jsv_d,jev_d ; do i=isv_d,iev_d
@@ -4630,10 +4723,10 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d
ii=i0
do jj=j0,j0+dl-1
weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki?
- total_weight = total_weight +weight
- ave = ave+field_in(ii,jj)*weight
+ total_weight = total_weight + weight
+ ave = ave+field_in(ii,jj) * weight
enddo
- field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0
+ field_out(i,j) = ave / (total_weight + eps_len) ! Eps_len avoids division by 0.
enddo ; enddo
elseif (method == MPP) then
do j=jsv_d,jev_d ; do i=isv_d,iev_d
@@ -4647,9 +4740,9 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d
total_weight = total_weight +weight
ave = ave+field_in(ii,jj)*weight
enddo
- field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0
+ field_out(i,j) = ave / (total_weight + eps_len) ! Eps_len avoids division by 0.
enddo ; enddo
- elseif (method == MSK) then !The input field is a mask, subsample
+ elseif (method == MSK) then ! The input field is a mask, so subsample it instead of averaging.
field_out(:,:) = 0.0
do j=jsv_d,jev_d ; do i=isv_d,iev_d
i0 = isv_o+dl*(i-isv_d)
@@ -4687,9 +4780,10 @@ subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_
integer, intent(in) :: ied_d !< Data domain i-end index of down sampled data
integer, intent(in) :: jsd_d !< Data domain j-start index of down sampled data
integer, intent(in) :: jed_d !< Data domain j-end index of down sampled data
- ! Locals
- integer :: i,j,ii,jj,i0,j0
+ ! Local variables
+ integer :: i, j, ii, jj, i0, j0
real :: tot_non_zero ! The sum of values in the down-scaled cell [A]
+
! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1
allocate(field_out(isd_d:ied_d,jsd_d:jed_d))
field_out(:,:) = 0.0
@@ -4724,9 +4818,11 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_
integer, intent(in) :: ied_d !< Computational i-end index of down sampled data
integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data
integer, intent(in) :: jed_d !< Computational j-end index of down sampled data
- ! Locals
- integer :: i,j,ii,jj,i0,j0,k,ks,ke
+
+ ! Local variables
+ integer :: i, j, ii, jj, i0, j0, k, ks, ke
real :: tot_non_zero ! The sum of values in the down-scaled cell [A]
+
! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1
ks = lbound(field_in,3) ; ke = ubound(field_in,3)
allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke))
@@ -4758,4 +4854,9 @@ logical function found_in_diagtable(diag, varName)
end function found_in_diagtable
+!> Finishes the diag manager reduction methods as needed for the time_step
+subroutine MOM_diag_send_complete()
+ call diag_send_complete_infra()
+end subroutine MOM_diag_send_complete
+
end module MOM_diag_mediator
diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90
index 38553a4351..c63e50ef9b 100644
--- a/src/framework/MOM_diag_remap.F90
+++ b/src/framework/MOM_diag_remap.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> provides runtime remapping of diagnostics to z star, sigma and
!! rho vertical coordinates.
!!
@@ -27,8 +31,6 @@
module MOM_diag_remap
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : reproducing_sum_EFP, EFP_to_real
use MOM_coms, only : EFP_type, assignment(=), EFP_sum_across_PEs
use MOM_error_handler, only : MOM_error, FATAL, assert, WARNING
@@ -176,8 +178,9 @@ end subroutine diag_remap_set_active
!> Configure the vertical axes for a diagnostic remapping control structure.
!! Reads a configuration parameters to determine coordinate generation.
-subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file)
+subroutine diag_remap_configure_axes(remap_cs, G, GV, US, param_file)
type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remap control structure
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid type
type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(param_file_type), intent(in) :: param_file !< Parameter file structure
@@ -192,7 +195,7 @@ subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file)
layers ! Numerical values for layer vertical coordinates, in unscaled units
! that might be [m], [kg m-3] or [nondim], depending on the coordinate.
- call initialize_regridding(remap_cs%regrid_cs, GV, US, GV%max_depth, param_file, mod, &
+ call initialize_regridding(remap_cs%regrid_cs, G, GV, US, GV%max_depth, param_file, mod, &
trim(remap_cs%vertical_coord_name), "DIAG_COORD", trim(remap_cs%diag_coord_name))
call set_regrid_params(remap_cs%regrid_cs, min_thickness=0., integrate_downward_for_e=.false.)
diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90
index d999e1e680..ef7d22596a 100644
--- a/src/framework/MOM_document.F90
+++ b/src/framework/MOM_document.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The subroutines here provide hooks for document generation functions at
!! various levels of granularity.
module MOM_document
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_time_manager, only : time_type, operator(==), get_time, get_ticks_per_second
use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe
diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90
index 6a1d7ad469..859072c9d6 100644
--- a/src/framework/MOM_domains.F90
+++ b/src/framework/MOM_domains.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Describes the decomposed MOM domain and has routines for communications across PEs
module MOM_domains
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms_infra, only : MOM_infra_init, MOM_infra_end
use MOM_coms_infra, only : PE_here, root_PE, num_PEs, broadcast
use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs
@@ -35,6 +37,7 @@ module MOM_domains
public :: MOM_domain_type, domain2D, domain1D
public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain
public :: MOM_thread_affinity_set, set_MOM_thread_affinity
+public :: MOM_define_layout
! Domain query routines
public :: get_domain_extent, get_domain_components, get_global_shape, same_domain
public :: PE_here, root_PE, num_PEs
@@ -246,10 +249,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, &
! Check the requirement of equal sized compute domains when STATIC_MEMORY_ is used.
if ((MOD(NIGLOBAL, NIPROC) /= 0) .OR. (MOD(NJGLOBAL, NJPROC) /= 0)) then
- write( char_xsiz, '(i4)' ) NIPROC
- write( char_ysiz, '(i4)' ) NJPROC
- write( char_niglobal, '(i4)' ) NIGLOBAL
- write( char_njglobal, '(i4)' ) NJGLOBAL
+ write( char_xsiz, '(I0)' ) NIPROC
+ write( char_ysiz, '(I0)' ) NJPROC
+ write( char_niglobal, '(I0)' ) NIGLOBAL
+ write( char_njglobal, '(I0)' ) NJGLOBAL
call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = ('//&
trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//&
'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').')
@@ -403,7 +406,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, &
if (layout(1)*layout(2) /= PEs_used .and. (.not. mask_table_exists) ) then
write(mesg,'("MOM_domains_init: The product of the two components of layout, ", &
- & 2i4,", is not the number of PEs used, ",i5,".")') &
+ & I0,", ",I0,", is not the number of PEs used, ",I0,".")') &
layout(1), layout(2), PEs_used
call MOM_error(FATAL, mesg)
endif
@@ -419,8 +422,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, &
! Idiot check that fewer PEs than columns have been requested
if (layout(1)*layout(2) > n_global(1)*n_global(2)) then
- write(mesg,'(a,2(i5,1x,a))') 'You requested to use', layout(1)*layout(2), &
- 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model'
+ write(mesg,'(a,I0,a,I0,a)') 'You requested to use ', layout(1)*layout(2), &
+ ' PEs but there are only ', n_global(1)*n_global(2), ' columns in the model'
call MOM_error(FATAL, mesg)
endif
diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90
index 2e183cdbef..d72d877b98 100644
--- a/src/framework/MOM_dyn_horgrid.F90
+++ b/src/framework/MOM_dyn_horgrid.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Contains a shareable dynamic type for describing horizontal grids and metric data
!! and utilty routines that work on this type.
module MOM_dyn_horgrid
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : rotate_array, rotate_array_pair
use MOM_domains, only : MOM_domain_type, deallocate_MOM_domain
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING
@@ -92,6 +94,7 @@ module MOM_dyn_horgrid
geoLonCu, & !< The geographic longitude at u points [degrees of longitude] or [m].
dxCu, & !< dxCu is delta x at u points [L ~> m].
IdxCu, & !< 1/dxCu [L-1 ~> m-1].
+ IdxCu_OBCmask, & !< 1/dxCu or 0 at boundary or OBC points [L-1 ~> m-1].
dyCu, & !< dyCu is delta y at u points [L ~> m].
IdyCu, & !< 1/dyCu [L-1 ~> m-1].
dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell [L ~> m].
@@ -107,6 +110,7 @@ module MOM_dyn_horgrid
IdxCv, & !< 1/dxCv [L-1 ~> m-1].
dyCv, & !< dyCv is delta y at v points [L ~> m].
IdyCv, & !< 1/dyCv [L-1 ~> m-1].
+ IdyCv_OBCmask, & !< 1/dxCv or 0 at boundary or OBC points [L-1 ~> m-1].
dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell [L ~> m].
IareaCv, & !< The masked inverse areas of v-grid cells [L-2 ~> m-2].
areaCv !< The areas of the v-grid cells [L2 ~> m2].
@@ -157,7 +161,16 @@ module MOM_dyn_horgrid
y_ax_unit_short !< A short description of the y-axis units for documenting parameter units
real, allocatable, dimension(:,:) :: &
- bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m].
+ bathyT !< Ocean bottom depth, referenced to a zero reference height at tracer points.
+ !! bathyT is in depth units and positive *below* the reference height [Z ~> m].
+ real, allocatable, dimension(:,:) :: &
+ meanSL !< Spatially varying time mean sea level, referenced to a zero reference height
+ !! at tracer points. meanSL is in height units and positive *above* zero. It is used
+ !! a) as the height where p = p_atm or zero;
+ !! b) to calculate time mean thickness of the water column, where
+ !! mean thickness = max(meanSL + bathyT, 0.0).
+ !! meanSL is 2D for the consideration of a domain with spatically varying mean
+ !! height, e.g. the Great Lakes system [Z ~> m].
logical :: bathymetry_at_vel !< If true, there are separate values for the
!! basin depths at velocity points. Otherwise the effects of
@@ -242,6 +255,7 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel)
allocate(G%dxBu(IsdB:IedB,JsdB:JedB), source=0.0)
allocate(G%IdxT(isd:ied,jsd:jed), source=0.0)
allocate(G%IdxCu(IsdB:IedB,jsd:jed), source=0.0)
+ allocate(G%IdxCu_OBCmask(IsdB:IedB,jsd:jed), source=0.0)
allocate(G%IdxCv(isd:ied,JsdB:JedB), source=0.0)
allocate(G%IdxBu(IsdB:IedB,JsdB:JedB), source=0.0)
@@ -252,6 +266,7 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel)
allocate(G%IdyT(isd:ied,jsd:jed), source=0.0)
allocate(G%IdyCu(IsdB:IedB,jsd:jed), source=0.0)
allocate(G%IdyCv(isd:ied,JsdB:JedB), source=0.0)
+ allocate(G%IdyCv_OBCmask(isd:ied,JsdB:JedB), source=0.0)
allocate(G%IdyBu(IsdB:IedB,JsdB:JedB), source=0.0)
allocate(G%areaT(isd:ied,jsd:jed), source=0.0)
@@ -290,8 +305,8 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel)
allocate(G%porous_DmaxV(isd:ied,JsdB:JedB), source=0.0)
allocate(G%porous_DavgV(isd:ied,JsdB:JedB), source=0.0)
-
allocate(G%bathyT(isd:ied, jsd:jed), source=0.0)
+ allocate(G%meanSL(isd:ied, jsd:jed), source=0.0)
allocate(G%CoriolisBu(IsdB:IedB, JsdB:JedB), source=0.0)
allocate(G%Coriolis2Bu(IsdB:IedB, JsdB:JedB), source=0.0)
allocate(G%dF_dx(isd:ied, jsd:jed), source=0.0)
@@ -333,6 +348,7 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns)
call rotate_array_pair(G_in%dxT, G_in%dyT, turns, G%dxT, G%dyT)
call rotate_array(G_in%areaT, turns, G%areaT)
call rotate_array(G_in%bathyT, turns, G%bathyT)
+ call rotate_array(G_in%meanSL, turns, G%meanSL)
call rotate_array_pair(G_in%df_dx, G_in%df_dy, turns, G%df_dx, G%df_dy)
call rotate_array(G_in%sin_rot, turns, G%sin_rot)
@@ -435,6 +451,7 @@ subroutine rescale_dyn_horgrid_bathymetry(G, m_in_new_units)
rescale = 1.0 / m_in_new_units
do j=jsd,jed ; do i=isd,ied
G%bathyT(i,j) = rescale*G%bathyT(i,j)
+ G%meanSL(i,j) = rescale*G%meanSL(i,j)
enddo ; enddo
if (G%bathymetry_at_vel) then ; do j=jsd,jed ; do I=IsdB,IedB
G%Dblock_u(I,j) = rescale*G%Dblock_u(I,j) ; G%Dopen_u(I,j) = rescale*G%Dopen_u(I,j)
@@ -471,6 +488,7 @@ subroutine set_derived_dyn_horgrid(G, US)
if (G%dyCu(I,j) < 0.0) G%dyCu(I,j) = 0.0
G%IdxCu(I,j) = Adcroft_reciprocal(G%dxCu(I,j))
G%IdyCu(I,j) = Adcroft_reciprocal(G%dyCu(I,j))
+ G%IdxCu_OBCmask(I,j) = G%OBCmaskCu(I,j) * G%IdxCu(I,j) ! This may be reset when the masks are set.
enddo ; enddo
do J=JsdB,JedB ; do i=isd,ied
@@ -478,6 +496,7 @@ subroutine set_derived_dyn_horgrid(G, US)
if (G%dyCv(i,J) < 0.0) G%dyCv(i,J) = 0.0
G%IdxCv(i,J) = Adcroft_reciprocal(G%dxCv(i,J))
G%IdyCv(i,J) = Adcroft_reciprocal(G%dyCv(i,J))
+ G%IdyCv_OBCmask(i,J) = G%OBCmaskCv(i,J) * G%IdyCv(i,J) ! This may be reset when the masks are set.
enddo ; enddo
do J=JsdB,JedB ; do I=IsdB,IedB
@@ -495,7 +514,7 @@ end subroutine set_derived_dyn_horgrid
!> Adcroft_reciprocal(x) = 1/x for |x|>0 or 0 for x=0.
function Adcroft_reciprocal(val) result(I_val)
- real, intent(in) :: val !< The value being inverted in abitrary units [A ~> a]
+ real, intent(in) :: val !< The value being inverted in arbitrary units [A ~> a]
real :: I_val !< The Adcroft reciprocal of val [A-1 ~> a-1].
I_val = 0.0 ; if (val /= 0.0) I_val = 1.0/val
@@ -519,10 +538,11 @@ subroutine destroy_dyn_horgrid(G)
deallocate(G%areaT) ; deallocate(G%IareaT)
deallocate(G%areaBu) ; deallocate(G%IareaBu)
deallocate(G%areaCu) ; deallocate(G%IareaCu)
- deallocate(G%areaCv) ; deallocate(G%IareaCv)
+ deallocate(G%areaCv) ; deallocate(G%IareaCv)
deallocate(G%mask2dT) ; deallocate(G%mask2dCu) ; deallocate(G%OBCmaskCu)
deallocate(G%mask2dCv) ; deallocate(G%OBCmaskCv) ; deallocate(G%mask2dBu)
+ deallocate(G%IdxCu_OBCmask) ; deallocate(G%IdyCv_OBCmask)
deallocate(G%geoLatT) ; deallocate(G%geoLatCu)
deallocate(G%geoLatCv) ; deallocate(G%geoLatBu)
@@ -534,9 +554,10 @@ subroutine destroy_dyn_horgrid(G)
deallocate(G%porous_DminU) ; deallocate(G%porous_DmaxU) ; deallocate(G%porous_DavgU)
deallocate(G%porous_DminV) ; deallocate(G%porous_DmaxV) ; deallocate(G%porous_DavgV)
- deallocate(G%bathyT) ; deallocate(G%CoriolisBu) ; deallocate(G%Coriolis2Bu)
- deallocate(G%dF_dx) ; deallocate(G%dF_dy)
- deallocate(G%sin_rot) ; deallocate(G%cos_rot)
+ deallocate(G%bathyT) ; deallocate(G%meanSL)
+ deallocate(G%CoriolisBu) ; deallocate(G%Coriolis2Bu)
+ deallocate(G%dF_dx) ; deallocate(G%dF_dy)
+ deallocate(G%sin_rot) ; deallocate(G%cos_rot)
if (allocated(G%Dblock_u)) deallocate(G%Dblock_u)
if (allocated(G%Dopen_u)) deallocate(G%Dopen_u)
diff --git a/src/framework/MOM_ensemble_manager.F90 b/src/framework/MOM_ensemble_manager.F90
index e431212524..62fb32a9dd 100644
--- a/src/framework/MOM_ensemble_manager.F90
+++ b/src/framework/MOM_ensemble_manager.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Manages ensemble member layout information
module MOM_ensemble_manager
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_ensemble_manager_infra, only : ensemble_manager_init
use MOM_ensemble_manager_infra, only : ensemble_pelist_setup
use MOM_ensemble_manager_infra, only : get_ensemble_id
diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90
index b113050572..eb097b32f0 100644
--- a/src/framework/MOM_error_handler.F90
+++ b/src/framework/MOM_error_handler.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Routines for error handling and I/O management
module MOM_error_handler
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms_infra, only : num_PEs
use MOM_error_infra, only : MOM_err, is_root_pe, stdlog, stdout, NOTE, WARNING, FATAL
use posix, only : getpid, getppid, handler_interface
diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90
index 291d44492d..501629491a 100644
--- a/src/framework/MOM_file_parser.F90
+++ b/src/framework/MOM_file_parser.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The MOM6 facility to parse input files for runtime parameters
module MOM_file_parser
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : root_PE, broadcast
use MOM_coms, only : any_across_PEs
use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, assert
@@ -569,11 +571,11 @@ function simplifyWhiteSpace(string)
character(len=len(string)+16) :: simplifyWhiteSpace
! Local variables
- integer :: i,j
+ integer :: i, j
logical :: nonBlank = .false., insideString = .false.
character(len=1) :: quoteChar=" "
- nonBlank = .false.; insideString = .false. ! NOTE: For some reason this line is needed??
+ nonBlank = .false. ; insideString = .false. ! NOTE: For some reason this line is needed??
i=0
simplifyWhiteSpace=repeat(" ",len(string)+16)
do j=1,len_trim(string)
@@ -1059,7 +1061,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL
! return variables indicating whether this variable is defined and the string
! that contains the value of this variable.
found = .false.
- oval = 0; ival = 0
+ oval = 0 ; ival = 0
max_vals = SIZE(value_string)
do is=1,max_vals ; value_string(is) = " " ; enddo
@@ -1100,8 +1102,8 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL
origLine = trim(line) ! Keep original for error messages
! Check for '#override' at start of line
- found_override = .false.; found_define = .false.; found_undef = .false.
- iso = index(line(:last), "#override " )!; if (is > 0) found_override = .true.
+ found_override = .false. ; found_define = .false. ; found_undef = .false.
+ iso = index(line(:last), "#override " )! ; if (is > 0) found_override = .true.
if (iso>1) call MOM_error(FATAL, "MOM_file_parser : #override was found "// &
" but was not the first keyword."// &
" Line: '"//trim(line(:last))//"'"//&
@@ -1110,7 +1112,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL
found_override = .true.
if (index(line(:last), "#override define ")==1) found_define = .true.
if (index(line(:last), "#override undef ")==1) found_undef = .true.
- line = trim(adjustl(line(iso+10:last))); last = len_trim(line)
+ line = trim(adjustl(line(iso+10:last))) ; last = len_trim(line)
endif
! Newer form of parameter block, block%, %block or block%param or
@@ -1162,9 +1164,9 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL
! Detect keywords
found_equals = .false.
- isd = index(line(:last), "define" )!; if (isd > 0) found_define = .true.
- isu = index(line(:last), "undef" )!; if (isu > 0) found_undef = .true.
- ise = index(line(:last), " = " ); if (ise > 1) found_equals = .true.
+ isd = index(line(:last), "define" )! ; if (isd > 0) found_define = .true.
+ isu = index(line(:last), "undef" )! ; if (isu > 0) found_undef = .true.
+ ise = index(line(:last), " = " ) ; if (ise > 1) found_equals = .true.
if (index(line(:last), "#define ")==1) found_define = .true.
if (index(line(:last), "#undef ")==1) found_undef = .true.
@@ -1414,7 +1416,7 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, &
if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg)
endif
- myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units)
+ myunits = " " ; if (present(units)) write(myunits(1:240),'(A)') trim(units)
if (present(desc)) &
call doc_param(CS%doc, varname, desc, myunits, value, default, &
layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default)
@@ -1450,7 +1452,7 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, &
if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg)
endif
- myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units)
+ myunits = " " ; if (present(units)) write(myunits(1:240),'(A)') trim(units)
if (present(desc)) &
call doc_param(CS%doc, varname, desc, myunits, value, default, defaults, &
layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default)
@@ -1568,7 +1570,7 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, &
if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg)
endif
- myunits="Boolean"; if (present(units)) write(myunits(1:240),'(A)') trim(units)
+ myunits = "Boolean" ; if (present(units)) write(myunits(1:240),'(A)') trim(units)
if (present(desc)) &
call doc_param(CS%doc, varname, desc, myunits, value, default, &
layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default)
@@ -1603,7 +1605,7 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, &
if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg)
endif
- myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units)
+ myunits = " " ; if (present(units)) write(myunits(1:240),'(A)') trim(units)
if (present(desc)) &
call doc_param(CS%doc, varname, desc, myunits, value, default, &
layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default)
diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90
index 6ecc3ef3f9..8000558b06 100644
--- a/src/framework/MOM_get_input.F90
+++ b/src/framework/MOM_get_input.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> \brief Reads the only Fortran name list needed to boot-strap the model.
!!
!! The name list parameters indicate which directories to use for
@@ -5,8 +9,6 @@
!! the full parsable input parameter file(s).
module MOM_get_input
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : open_param_file, param_file_type
use MOM_io, only : file_exists, close_file, slasher, ensembler
diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90
index 2ce2808692..2bc832e90a 100644
--- a/src/framework/MOM_hor_index.F90
+++ b/src/framework/MOM_hor_index.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Defines the horizontal index type (hor_index_type) used for providing index ranges
module MOM_hor_index
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domains, only : MOM_domain_type, get_domain_extent, get_global_shape
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
@@ -55,7 +57,7 @@ module MOM_hor_index
end type hor_index_type
!> Copy the contents of one horizontal index type into another
-interface assignment(=); module procedure HIT_assign ; end interface
+interface assignment(=) ; module procedure HIT_assign ; end interface
contains
diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90
index e0fccd3cf2..4f3a4854f0 100644
--- a/src/framework/MOM_horizontal_regridding.F90
+++ b/src/framework/MOM_horizontal_regridding.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Horizontal interpolation
module MOM_horizontal_regridding
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum
use MOM_coms, only : max_across_PEs, min_across_PEs, sum_across_PEs, broadcast
use MOM_coms, only : reproducing_sum
@@ -87,7 +89,7 @@ subroutine myStats(array, missing, G, k, mesg, unscale, full_halo)
call min_across_PEs(minA)
call max_across_PEs(maxA)
if (is_root_pe()) then
- write(lMesg(1:120),'(2(a,es12.4),a,i3,1x,a)') &
+ write(lMesg(1:120),'(2(a,es12.4),a,I0,1x,a)') &
'init_from_Z: min=',minA*scl,' max=',maxA*scl,' Level=',k,trim(mesg)
call MOM_mesg(lMesg,2)
endif
@@ -212,8 +214,8 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug,
endif ; enddo ; enddo
elseif (nfill == nfill_prev) then
call MOM_error(WARNING, &
- 'Unable to fill missing points using either data at the same vertical level from a connected basin'//&
- 'or using a point from a previous vertical level. Make sure that the original data has some valid'//&
+ 'Unable to fill missing points using either data at the same vertical level from a connected basin '//&
+ 'or using a point from a previous vertical level. Make sure that the original data has some valid '//&
'data in all basins.', .true.)
write(mesg,*) 'nfill=',nfill
call MOM_error(WARNING, mesg, .true.)
diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90
index aa393e8990..88b8183552 100644
--- a/src/framework/MOM_interpolate.F90
+++ b/src/framework/MOM_interpolate.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module provides added functionality to the FMS temporal and spatial interpolation routines
module MOM_interpolate
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : allocate_rotated_array, rotate_array
use MOM_error_handler, only : MOM_error, FATAL
use MOM_interp_infra, only : time_interp_extern, init_external_field=>init_extern_field
diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90
index fdafa8503d..0c0e79a182 100644
--- a/src/framework/MOM_intrinsic_functions.F90
+++ b/src/framework/MOM_intrinsic_functions.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A module with intrinsic functions that are used by MOM but are not supported
!! by some compilers.
module MOM_intrinsic_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
use iso_fortran_env, only : stdout => output_unit, stderr => error_unit
use iso_fortran_env, only : int64, real64
@@ -117,7 +119,7 @@ end function cuberoot
!> Rescale `a` to the range [0.125, 1) and compute its cube-root exponent.
pure subroutine rescale_cbrt(a, x, e_r, s_a)
real, intent(in) :: a
- !< The real parameter to be rescaled for cube root in abitrary units cubed [A3]
+ !< The real parameter to be rescaled for cube root in arbitrary units cubed [A3]
real, intent(out) :: x
!< The rescaled value of a in the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3]
integer(kind=int64), intent(out) :: e_r
@@ -168,7 +170,7 @@ pure function descale(x, e_a, s_a) result(a)
integer(kind=int64), intent(in) :: s_a
!< Sign bit of the unscaled value
real :: a
- !< Restored value with the corrected exponent and sign in abitrary units [A]
+ !< Restored value with the corrected exponent and sign in arbitrary units [A]
integer(kind=int64) :: xb
! Bit-packed real number into integer form
diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90
index 9177017c30..24adafba65 100644
--- a/src/framework/MOM_io.F90
+++ b/src/framework/MOM_io.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains I/O framework code
module MOM_io
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_array_transform, only : allocate_rotated_array, rotate_array
use MOM_array_transform, only : rotate_array_pair, rotate_vector
use MOM_domains, only : MOM_domain_type, domain1D, broadcast, get_domain_components
@@ -777,7 +779,7 @@ function num_timelevels(filename, varname, min_dims) result(n_time)
if (present(min_dims)) then
if (ndims < min_dims-1) then
- write(msg, '(I3)') min_dims
+ write(msg, '(I0)') min_dims
call MOM_error(WARNING, "num_timelevels: variable "//trim(varname)//" in file "//&
trim(filename)//" has fewer than min_dims = "//trim(msg)//" dimensions.")
n_time = -1
@@ -3037,8 +3039,8 @@ subroutine safe_string_copy(str1, str2, fieldnm, caller)
if (len(trim(str1)) > len(str2)) then
if (present(fieldnm) .and. present(caller)) then
- call MOM_error(FATAL, trim(caller)//" attempted to copy the overly long"//&
- " string "//trim(str1)//" into "//trim(fieldnm))
+ call MOM_error(FATAL, trim(caller)//" attempted to copy the overly long string "//&
+ trim(str1)//" into "//trim(fieldnm))
else
call MOM_error(FATAL, "safe_string_copy: The string "//trim(str1)//&
" is longer than its intended target.")
@@ -3072,7 +3074,7 @@ function ensembler(name, ens_no_in) result(en_nm)
ens_no = get_ensemble_id()
endif
- write(ens_num_char, '(I10)') ens_no ; ens_num_char = adjustl(ens_num_char)
+ write(ens_num_char, '(I0)') ens_no
do
is = index(en_nm,"%E")
if (is == 0) exit
diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90
index 682f967099..9da83fd338 100644
--- a/src/framework/MOM_io_file.F90
+++ b/src/framework/MOM_io_file.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the MOM file handler types
module MOM_io_file
-! This file is part of MOM6. See LICENSE.md for the license.
-
use, intrinsic :: iso_fortran_env, only : int64
use MOM_domains, only : MOM_domain_type, domain1D
diff --git a/src/framework/MOM_memory_macros.h b/src/framework/MOM_memory_macros.h
index 6ac3e7566b..4919fe4123 100644
--- a/src/framework/MOM_memory_macros.h
+++ b/src/framework/MOM_memory_macros.h
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!//! \brief Memory macros
!//! \details This is a header file to define macros for static and dynamic memory allocation.
!//! Define STATIC_MEMORY_ in MOM_memory.h for static memory allocation.
diff --git a/src/framework/MOM_murmur_hash.F90 b/src/framework/MOM_murmur_hash.F90
index 16283f61e3..1016fa0ee4 100644
--- a/src/framework/MOM_murmur_hash.F90
+++ b/src/framework/MOM_murmur_hash.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> MurmurHash is a non-cryptographic hash function developed by Austin Appleby.
!!
!! This module provides an implementation of the 32-bit MurmurHash3 algorithm.
diff --git a/src/framework/MOM_netcdf.F90 b/src/framework/MOM_netcdf.F90
index 122d2797ba..a3cfcad113 100644
--- a/src/framework/MOM_netcdf.F90
+++ b/src/framework/MOM_netcdf.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> MOM6 interface to netCDF operations
module MOM_netcdf
-! This file is part of MOM6. See LICENSE.md for the license.
-
use, intrinsic :: iso_fortran_env, only : real32, real64
use netcdf, only : nf90_create, nf90_open, nf90_close
diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90
index 6fcc6903c9..9cd774cf88 100644
--- a/src/framework/MOM_random.F90
+++ b/src/framework/MOM_random.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides gridded random number capability
module MOM_random
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_hor_index, only : hor_index_type
use MOM_time_manager, only : time_type, set_date, get_date
@@ -230,7 +232,7 @@ function new_RandomNumberSequence(seed) result(twister)
twister%state(i) = 1812433253 * ieor(twister%state(i-1), &
ishft(twister%state(i-1), -30)) + i
twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines
- end do
+ enddo
twister%currentElement = blockSize
end function new_RandomNumberSequence
@@ -259,7 +261,7 @@ double precision function getRandomReal(twister)
getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0)
else
getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0)
- end if
+ endif
end function getRandomReal
!> Merge bits of u and v
@@ -290,11 +292,11 @@ subroutine nextState(twister)
do k = 0, blockSize - M - 1
twister%state(k) = ieor(twister%state(k + M), &
twist(twister%state(k), twister%state(k + 1)))
- end do
+ enddo
do k = blockSize - M, blockSize - 2
twister%state(k) = ieor(twister%state(k + M - blockSize), &
twist(twister%state(k), twister%state(k + 1)))
- end do
+ enddo
twister%state(blockSize - 1) = ieor(twister%state(M - 1), &
twist(twister%state(blockSize - 1), twister%state(0)))
twister%currentElement = 0
diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90
index ce47e3b0fa..54dd4abaf9 100644
--- a/src/framework/MOM_restart.F90
+++ b/src/framework/MOM_restart.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The MOM6 facility for reading and writing restart files, and querying what has been read.
module MOM_restart
-! This file is part of MOM6. See LICENSE.md for the license.
-
use, intrinsic :: iso_fortran_env, only : int64
use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair
use MOM_checksums, only : chksum => field_checksum
@@ -1559,8 +1561,8 @@ logical function size_mismatch_3d(var_a, var_b, turns, size_msg)
(size(var_a,2) /= size(var_b,1)) .or. &
(size(var_a,3) /= size(var_b,3)) )
endif
- write(size_msg, '(3(I8), " vs ", 3(I8))') size(var_a,1), size(var_a,2), size(var_a,3), &
- size(var_b,1), size(var_b,2), size(var_b,3)
+ write(size_msg, '(3(1x,I0), " vs ", 3(1x,I0))') size(var_a,1), size(var_a,2), size(var_a,3), &
+ size(var_b,1), size(var_b,2), size(var_b,3)
end function size_mismatch_3d
@@ -1706,11 +1708,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_
restartpath = trim(directory) // trim(restartname)
- if (num_files < 10) then
- write(suffix,'("_",I1)') num_files
- else
- write(suffix,'("_",I2)') num_files
- endif
+ write(suffix,'("_",I0)') num_files
length = len_trim(restartpath)
if (length < 3) then ! This case is very uncommon but this test avoids segmentation-faults.
@@ -1742,15 +1740,15 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_
endif
if (verbose) then
if (pos == CENTER) then
- write(mesg, '(" is in CENTER position, checksum range ",4(I8))') isL, ieL, jsL, jeL
+ write(mesg, '(" is in CENTER position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL
elseif (pos == CORNER) then
- write(mesg, '(" is in CORNER position, checksum range ",4(I8))') isL, ieL, jsL, jeL
+ write(mesg, '(" is in CORNER position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL
elseif (pos == NORTH_FACE) then
- write(mesg, '(" is in NORTH_FACE position, checksum range ",4(I8))') isL, ieL, jsL, jeL
+ write(mesg, '(" is in NORTH_FACE position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL
elseif (pos == EAST_FACE) then
- write(mesg, '(" is in EAST_FACE position, checksum range ",4(I8))') isL, ieL, jsL, jeL
+ write(mesg, '(" is in EAST_FACE position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL
else
- write(mesg, '(" is in another position, ",I4,", checksum range ",4(I8))') pos, isL, ieL, jsL, jeL
+ write(mesg, '(" is in another position, ",I0,", checksum range",4(1x,I0))') pos, isL, ieL, jsL, jeL
endif
call MOM_mesg(trim(var_name)//mesg)
endif
@@ -1877,8 +1875,7 @@ subroutine restore_state(filename, directory, day, G, CS)
exit
enddo
- if (n>num_file) call MOM_error(WARNING,"MOM_restart: " // &
- "No times found in restart files.")
+ if (n>num_file) call MOM_error(WARNING, "MOM_restart: No times found in restart files.")
! Check the remaining files for different times and issue a warning
! if they differ from the first time.
@@ -1890,9 +1887,9 @@ subroutine restore_state(filename, directory, day, G, CS)
deallocate(time_vals)
if (t1 /= t2 .and. is_root_PE()) then
- write(mesg,'("WARNING: Restart file ",I2," has time ",F10.4,"whereas &
- &simulation is restarted at ",F10.4," (differing by ",F10.4,").")')&
- m,t1,t2,t1-t2
+ write(mesg,'("WARNING: Restart file ",I0," has time ",F10.4,"whereas &
+ &simulation is restarted at ",F10.4," (differing by ",F10.4,").")') &
+ m, t1, t2, t1-t2
call MOM_error(WARNING, "MOM_restart: "//mesg)
endif
enddo
@@ -2168,11 +2165,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths,
endif
filepath = trim(directory) // trim(restartname)
- if (num_restart < 10) then
- write(suffix,'("_",I1)') num_restart
- else
- write(suffix,'("_",I2)') num_restart
- endif
+ write(suffix,'("_",I0)') num_restart
if (num_restart > 0) filepath = trim(filepath) // suffix
filepath = trim(filepath)//".nc"
@@ -2220,10 +2213,10 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths,
if (present(global_files)) global_files(nf) = .true.
if (present(file_paths)) file_paths(nf) = filepath
if (is_root_pe() .and. (present(IO_handles))) &
- call MOM_error(NOTE,"MOM_restart: MOM run restarted using : "//trim(filepath))
+ call MOM_error(NOTE, "MOM_restart: MOM run restarted using : "//trim(filepath))
else
if (present(IO_handles)) &
- call MOM_error(WARNING,"MOM_restart: Unable to find restart file : "//trim(filepath))
+ call MOM_error(WARNING, "MOM_restart: Unable to find restart file : "//trim(filepath))
endif
endif
@@ -2430,8 +2423,7 @@ subroutine restart_error(CS)
if (CS%novars > CS%max_fields) then
write(num,'(I0)') CS%novars
call MOM_error(FATAL,"MOM_restart: Too many fields registered for " // &
- "restart. Set MAX_FIELDS to be at least " // &
- trim(adjustl(num)) // " in the MOM input file.")
+ "restart. Set MAX_FIELDS to be at least "//trim(num)//" in the MOM input file.")
else
call MOM_error(FATAL,"MOM_restart: Unspecified fatal error.")
endif
diff --git a/src/framework/MOM_safe_alloc.F90 b/src/framework/MOM_safe_alloc.F90
index 8960e8e358..3b5b2b397e 100644
--- a/src/framework/MOM_safe_alloc.F90
+++ b/src/framework/MOM_safe_alloc.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Convenience functions for safely allocating memory without
!! accidentally reallocating pointer and causing memory leaks.
module MOM_safe_alloc
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public safe_alloc_ptr, safe_alloc_alloc
diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90
index cabe0f6e40..d890104c23 100644
--- a/src/framework/MOM_string_functions.F90
+++ b/src/framework/MOM_string_functions.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Handy functions for manipulating strings
module MOM_string_functions
-! This file is part of MOM6. See LICENSE.md for the license.
-
use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit
implicit none ; private
@@ -17,6 +19,8 @@ module MOM_string_functions
public extract_real
public remove_spaces
public slasher
+public trim_trailing_commas
+public ints_to_string
contains
@@ -214,7 +218,7 @@ end function extractWord
extract_word = ''
lastCharIsSeperator = .true.
ns = len_trim(string)
- i = 0; b=0; e=0; nw=0
+ i = 0 ; b=0 ; e=0 ; nw=0
do while (i Returns a left-adjusted string with trailing blanks and commas removed.
+function trim_trailing_commas(in_str) result(out_str)
+ character(len=*), intent(in) :: in_str !< A string that is to be left adjusted and have
+ !! its trailing commas and white space removed.
+ character(len=len(in_str)) :: out_str !< A left-adjusted version of in_str with
+ !! trailing commas and white space removed
+
+ out_str = trim(adjustl(in_str))
+ if (len_trim(out_str) > 0) then
+ if (out_str(len_trim(out_str):len_trim(out_str)) == ",") then
+ out_str = out_str(1:len_trim(out_str) - 1)
+ endif
+ out_str = trim(out_str)
+ endif
+
+end function trim_trailing_commas
+
+!> Convert the first n elements (3 by default) of an integer array into an underscore delimited string.
+function ints_to_string(a, n) result(i2s)
+ integer, dimension(:), intent(in) :: a !< The array of integers to translate
+ integer, optional , intent(in) :: n !< The number of elements to translate, by default the lesser
+ !! of 3 or all of the integers
+ character(len=5*size(a)+1) :: i2s !< The returned underscore delimited string of integers
+
+ character(len=8) :: i2s_temp
+ integer :: i, n_max
+
+ n_max = 3
+ if (present(n)) n_max = n
+
+ i2s = ''
+ do i=1,min(size(a), n_max)
+ if (a(i) < 0) then
+ write (i2s_temp, '(I5.4)') a(i)
+ else
+ write (i2s_temp, '(I4.4)') a(i)
+ endif
+ i2s = trim(i2s) //'_'// trim(i2s_temp)
+ enddo
+ i2s = adjustl(i2s)
+end function ints_to_string
+
+
!> \namespace mom_string_functions
!!
!! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013.
diff --git a/src/framework/MOM_unique_scales.F90 b/src/framework/MOM_unique_scales.F90
index 6572678c06..e61a339c8b 100644
--- a/src/framework/MOM_unique_scales.F90
+++ b/src/framework/MOM_unique_scales.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module provides tools that can be used to check the uniqueness of the dimensional
!! scaling factors used by the MOM6 ocean model or other models
module MOM_unique_scales
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity
implicit none ; private
@@ -59,8 +61,8 @@ subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_
enddo
if (verbosity >= 7) then
- write(mesg, '(I8)') ns
- call MOM_mesg(trim(component)//": Extracted "//trim(adjustl(mesg))//" unit combinations from the list.")
+ write(mesg, '(I0)') ns
+ call MOM_mesg(trim(component)//": Extracted "//trim(mesg)//" unit combinations from the list.")
mesg = "Dim Key: ["
do i=1,ndims ; mesg = trim(mesg)//" "//trim(key(i)) ; enddo
mesg = trim(mesg)//"]:"
@@ -117,7 +119,7 @@ subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_
endif
if (better_cost == 0) exit
if (verbosity >= 7) then
- write(mesg, '("Iteration ",I2," scaling cost reduced from ",I8," with original scales to ", I8)') &
+ write(mesg, '("Iteration ",I0," scaling cost reduced from ",I0," with original scales to ", I0)') &
itt, orig_cost, better_cost
call MOM_mesg(trim(component)//": "//trim(mesg)//" with revised scaling factors.")
endif
@@ -126,15 +128,15 @@ subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_
test_cost = non_unique_scales(prev_scales, list, descs, weights, silent=(verbosity<4))
mesg = trim(component)//": Suggested improved scales: "
do i=1,ndims ; if ((prev_scales(i) /= scales(i)) .and. (scales(i) /= 0)) then
- write(msg_frag, '(I3)') prev_scales(i)
- mesg = trim(mesg)//" "//trim(key(i))//"_RESCALE_POWER = "//trim(adjustl(msg_frag))
+ write(msg_frag, '(I0)') prev_scales(i)
+ mesg = trim(mesg)//" "//trim(key(i))//"_RESCALE_POWER = "//trim(msg_frag)
endif ; enddo
call MOM_mesg(mesg)
- write(mesg, '(I8)') orig_cost
- write(msg_frag, '(I8)') test_cost
- mesg = trim(component)//": Scaling overlaps reduced from "//trim(adjustl(mesg))//&
- " with original scales to "//trim(adjustl(msg_frag))//" with suggested scales."
+ write(mesg, '(I0)') orig_cost
+ write(msg_frag, '(I0)') test_cost
+ mesg = trim(component)//": Scaling overlaps reduced from "//trim(mesg)//&
+ " with original scales to "//trim(msg_frag)//" with suggested scales."
call MOM_mesg(mesg)
endif
@@ -194,9 +196,9 @@ subroutine encode_dim_powers(scaling, key, dim_powers)
if (verify(fragment(ipow:), numbers) == 0) then
read(fragment(ipow:),*) dp
dimnm = fragment(:ipow-1)
- ! write(mesg, '(I3)') dp
+ ! write(mesg, '(I0)') dp
! call MOM_mesg("Parsed fragment "//trim(fragment)//" from "//trim(scaling)//&
- ! " as "//trim(dimnm)//trim(adjustl(mesg)))
+ ! " as "//trim(dimnm)//trim(mesg))
else
dimnm = fragment
dp = 1
@@ -317,9 +319,9 @@ integer function non_unique_scales(scales, list, descs, weights, silent)
! the likelihood that these factors would be combined in an expression.
non_unique_scales = min(non_unique_scales + wt_merge(n) * wt_merge(m), 99999999)
if (verbose) then
- write(mesg, '(I8)') res_pow(n)
+ write(mesg, '(I0)') res_pow(n)
call MOM_mesg("The factors "//trim(descs(n))//" and "//trim(descs(m))//" both scale to "//&
- trim(adjustl(mesg))//" for the given powers.")
+ trim(mesg)//" for the given powers.")
! call MOM_mesg("Powers ["//trim(int_array_msg(list(:,n)))//"] and ["//&
! trim(int_array_msg(list(:,m)))//"] with rescaling by ["//&
@@ -343,8 +345,7 @@ function int_array_msg(array)
if (ni < 1) return
do i=1,ni
- write(msg_frag, '(I8)') array(i)
- msg_frag = adjustl(msg_frag)
+ write(msg_frag, '(I0)') array(i)
if (i == 1) then
int_array_msg = trim(msg_frag)
else
diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90
index 8b4f9266a8..96814d3220 100644
--- a/src/framework/MOM_unit_scaling.F90
+++ b/src/framework/MOM_unit_scaling.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides a transparent unit rescaling type to facilitate dimensional consistency testing
module MOM_unit_scaling
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
diff --git a/src/framework/MOM_unit_testing.F90 b/src/framework/MOM_unit_testing.F90
index 312914933c..aeef8aa882 100644
--- a/src/framework/MOM_unit_testing.F90
+++ b/src/framework/MOM_unit_testing.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
module MOM_unit_testing
use posix, only : chmod
diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90
index 025dcad2ac..52cc924574 100644
--- a/src/framework/MOM_write_cputime.F90
+++ b/src/framework/MOM_write_cputime.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A module to monitor the overall CPU time used by MOM6 and project when to stop the model
module MOM_write_cputime
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : sum_across_PEs, num_pes
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe
use MOM_io, only : open_ASCII_file, close_file, APPEND_FILE, WRITEONLY_FILE
diff --git a/src/framework/do_concurrent_compat.h b/src/framework/do_concurrent_compat.h
new file mode 100644
index 0000000000..f08575edbb
--- /dev/null
+++ b/src/framework/do_concurrent_compat.h
@@ -0,0 +1,12 @@
+#ifndef DO_CONCURRENT_COMPAT_H_
+#define DO_CONCURRENT_COMPAT_H_
+
+! This macro conditionally applies the locality specifier of a do concurrent
+! loop if supported by the compiler.
+#ifdef HAVE_FC_DO_CONCURRENT_LOCAL
+#define DO_LOCALITY(X) X
+#else
+#define DO_LOCALITY(X) ;
+#endif
+
+#endif
diff --git a/src/framework/numerical_testing_type.F90 b/src/framework/numerical_testing_type.F90
index 0947ed3141..23ed4630f0 100644
--- a/src/framework/numerical_testing_type.F90
+++ b/src/framework/numerical_testing_type.F90
@@ -1,12 +1,14 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A simple type for keeping track of numerical tests
module numerical_testing_type
-! This file is part of MOM6. See LICENSE.md for the license.
-
implicit none ; private
public testing
-public testing_type_unit_test
+public numerical_testing_type_unit_tests
!> Class to assist in unit tests, not to be used outside of Recon1d types
type :: testing
@@ -272,100 +274,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/framework/posix.F90 b/src/framework/posix.F90
index a9829c510e..4eb5969b3a 100644
--- a/src/framework/posix.F90
+++ b/src/framework/posix.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interface to the libc POSIX API
#include "posix.h"
diff --git a/src/framework/posix.h b/src/framework/posix.h
index c4b09e1285..2ccdfde126 100644
--- a/src/framework/posix.h
+++ b/src/framework/posix.h
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
#ifndef MOM6_POSIX_H_
#define MOM6_POSIX_H_
diff --git a/src/framework/testing/MOM_file_parser_tests.F90 b/src/framework/testing/MOM_file_parser_tests.F90
index c0a31c39c4..586037f5d9 100644
--- a/src/framework/testing/MOM_file_parser_tests.F90
+++ b/src/framework/testing/MOM_file_parser_tests.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
module MOM_file_parser_tests
use posix, only : chmod
diff --git a/src/framework/version_variable.h b/src/framework/version_variable.h
index 7cccf999fe..f60afdfc69 100644
--- a/src/framework/version_variable.h
+++ b/src/framework/version_variable.h
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
#ifdef _FILE_VERSION
character(len=*), parameter :: version = _FILE_VERSION
#else
diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90
index 2def8097ea..f89c2c4cd5 100644
--- a/src/ice_shelf/MOM_ice_shelf.F90
+++ b/src/ice_shelf/MOM_ice_shelf.F90
@@ -1,9 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Implements the thermodynamic aspects of ocean / ice-shelf interactions,
!! along with a crude placeholder for a later implementation of full
!! ice shelf dynamics, all using the MOM framework and coding style.
module MOM_ice_shelf
-! This file is part of MOM6. See LICENSE.md for the license.
use MOM_array_transform, only : rotate_array
use MOM_constants, only : hlf
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
@@ -28,7 +31,7 @@ module MOM_ice_shelf
use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint
use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type
use MOM_grid, only : MOM_grid_init, ocean_grid_type
-use MOM_grid_initialize, only : set_grid_metrics
+use MOM_grid_initialize, only : initialize_masks, set_grid_metrics
use MOM_hor_index, only : hor_index_type, hor_index_init
use MOM_hor_index, only : rotate_hor_index
use MOM_fixed_initialization, only : MOM_initialize_topography
@@ -39,7 +42,7 @@ module MOM_ice_shelf
use MOM_io, only : close_file, SINGLE_FILE, MULTIPLE
use MOM_restart, only : register_restart_field, save_restart
use MOM_restart, only : restart_init, restore_state, MOM_restart_CS, register_restart_pair
-use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-)
+use MOM_time_manager, only : time_type, time_to_real, real_to_time, operator(>), operator(-)
use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid
use MOM_transcribe_grid, only : rotate_dyngrid
use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling
@@ -79,6 +82,7 @@ module MOM_ice_shelf
public ice_shelf_save_restart, solo_step_ice_shelf, add_shelf_forces
public initialize_ice_shelf_fluxes, initialize_ice_shelf_forces
public ice_sheet_calving_to_ocean_sfc
+public adjust_ice_sheet_frazil
! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional
! consistency testing. These are noted in comments with units like Z, H, L, and T, along with
@@ -126,9 +130,9 @@ module MOM_ice_shelf
real :: kd_molec_salt!< The molecular diffusivity of salt [Z2 T-1 ~> m2 s-1].
real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1].
real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1].
- real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation
- real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation
- !< This number should be specified by the user.
+ real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation [nondim]
+ real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation [nondim]
+ !< This number should be specified by the user.
real :: col_mass_melt_threshold !< An ocean column mass below the iceshelf below which melting
!! does not occur [R Z ~> kg m-2]
logical :: mass_from_file !< Read the ice shelf mass from a file every dt
@@ -194,19 +198,20 @@ module MOM_ice_shelf
real :: dTFr_dp !< Partial derivative of freezing temperature with
!! pressure [C T2 R-1 L-2 ~> degC Pa-1]
real :: Zeta_N !< The stability constant xi_N = 0.052 from Holland & Jenkins '99
- !! divided by the von Karman constant VK. Was 1/8.
- real :: Vk !< Von Karman's constant - dimensionless
- real :: Rc !< critical flux Richardson number.
- logical :: buoy_flux_itt_bug !< If true, fixes buoyancy iteration bug
- logical :: salt_flux_itt_bug !< If true, fixes salt iteration bug
- real :: buoy_flux_itt_threshold !< Buoyancy iteration threshold for convergence
+ !! divided by the von Karman constant VK [nondim]. Was 1/8.
+ real :: Vk !< Von Karman's constant [nondim]
+ real :: Rc !< critical flux Richardson number [nondim]
+ logical :: ustar_from_vel_bugfix !< If true, fixes ustar from ocean velocity bug
+ logical :: buoy_flux_itt_bugfix !< If true, fixes buoyancy iteration bug
+ logical :: salt_flux_itt_bugfix !< If true, fixes salt iteration bug
+ real :: buoy_flux_tol !< Fractional buoyancy iteration tolerance for convergence [nondim]
!>@{ Diagnostic handles
integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, &
id_tfreeze = -1, id_tfl_shelf = -1, &
id_thermal_driving = -1, id_haline_driving = -1, &
id_u_ml = -1, id_v_ml = -1, id_sbdry = -1, &
- id_h_shelf = -1, id_dhdt_shelf, id_h_mask = -1, &
+ id_h_shelf = -1, id_dhdt_shelf = -1, id_h_mask = -1, id_frazil = -1, &
id_surf_elev = -1, id_bathym = -1, &
id_area_shelf_h = -1, &
id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1, &
@@ -294,12 +299,13 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
!! This is computed as part of the ISOMIP diagnostics.
real :: time_step !< Length of time over which these fluxes will be applied [T ~> s].
real :: Itime_step !< Inverse of the length of time over which these fluxes will be applied [T-1 ~> s-1]
- real :: VK !< Von Karman's constant - dimensionless
+ real :: VK !< Von Karman's constant [nondim]
real :: ZETA_N !< This is the stability constant xi_N = 0.052 from Holland & Jenkins '99
!! divided by the von Karman constant VK. Was 1/8. [nondim]
- real :: RC !< critical flux Richardson number.
- real :: I_ZETA_N !< The inverse of ZETA_N [nondim].
+ real :: Rf_crit !< critical flux Richardson number [nondim]
+ real :: I_2Zeta_N !< Half the inverse of Zeta_N [nondim].
real :: I_LF !< The inverse of the latent heat of fusion [Q-1 ~> kg J-1].
+ real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [Q-1 T-1 ~> kg J-1 s-1].
real :: I_VK !< The inverse of the Von Karman constant [nondim].
real :: PR, SC !< The Prandtl number and Schmidt number [nondim].
@@ -318,7 +324,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
real :: wB_flux !< The downward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3].
real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 S-1 ~> m s-2 ppt-1].
real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 C-1 ~> m s-2 degC-1].
- real :: I_n_star ! [nondim]
+ real :: I_n_star ! The inverse of the ratio of working boundary layer thickness
+ ! to the neutral thickness [nondim]
real :: n_star_term ! A term in the expression for nstar [T3 Z-2 ~> s3 m-2]
real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1]
real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in [T3 Z-2 ~> s3 m-2]
@@ -327,34 +334,42 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
real :: dS_ustar ! The difference between the salinity at the ice-ocean interface and the ocean
! boundary layer salinity times the friction velocity [S Z T-1 ~> ppt m s-1]
real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1]
- real :: Gam_turb ! [nondim]
+ real :: Gam_turb ! A relative turbluent diffusivity [nondim]
real :: Gam_mol_t, Gam_mol_s ! Relative coefficients of molecular diffusivities [nondim]
real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R C-1 ~> J m-3 degC-1]
- real :: ln_neut
+ real :: ln_neut ! The log of the ratio of the neutral boundary layer thickness to the molecular
+ ! boundary layer thickness if it is greater than 1 or 0 otherwise [nondim]
real :: mass_exch ! A mass exchange rate [R Z T-1 ~> kg m-2 s-1]
real :: Sb_min, Sb_max ! Minimum and maximum boundary salinities [S ~> ppt]
real :: dS_min, dS_max ! Minimum and maximum salinity changes [S ~> ppt]
! Variables used in iterating for wB_flux.
- real :: wB_flux_new, dDwB_dwB_in
- real :: I_Gam_T, I_Gam_S
- real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2]
+ real :: wB_flux_next ! The next interation's guess for wB_flux [Z2 T-3 ~> m2 s-3]
+ real :: wB_flux_new ! An updated value of wB_flux when Gam_turb is based on wB_flux [Z2 T-3 ~> m2 s-3]
+ real :: wB_flux_max ! The upper bound on wB_flux [Z2 T-3 ~> m2 s-3]
+ real :: wB_flux_min ! The lower bound on wB_flux [Z2 T-3 ~> m2 s-3]
+ real :: dDwB_dwB ! The slope of the change in wB_flux between iterations with wB_flux [nondim]
+ real :: DwB_max ! The change in wB_flux when it is wB_flux_max [Z2 T-3 ~> m2 s-3]
+ real :: DwB_min ! The change in wB_flux when it is wB_flux_min [Z2 T-3 ~> m2 s-3]
+ real :: I_Gam_T, I_Gam_S ! Terms that vary inversely with Gam_mol_T or Gam_mol_S and Gam_turb [nondim]
+ real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2]
real :: taux2, tauy2 ! The squared surface stresses [R2 L2 Z2 T-4 ~> Pa2].
real :: u2_av, v2_av ! The ice-area weighted average squared ocean velocities [L2 T-2 ~> m2 s-2]
- real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u-
- real :: asv1, asv2 ! and v-points [L2 ~> m2].
+ real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u-points [L2 ~> m2]
+ real :: asv1, asv2 ! Ocean areas covered by ice shelves at neighboring v-points [L2 ~> m2]
real :: I_au, I_av ! The Adcroft reciprocals of the ice shelf areas at adjacent points [L-2 ~> m-2]
real :: Irho0 ! The inverse of the mean density times a unit conversion factor [R-1 L Z-1 ~> m3 kg-1]
logical :: Sb_min_set, Sb_max_set
+ logical :: root_found
logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities.
logical :: coupled_GL ! If true, the grounding line position is determined based on
! coupled ice-ocean dynamics.
-
- real, parameter :: c2_3 = 2.0/3.0
- character(len=160) :: mesg ! The text of an error message
+ logical :: add_frazil ! If true, allow frazil formation to modify ice-shelf water flux
+ real, parameter :: c2_3 = 2.0/3.0 ! Two thirds [nondim]
+ character(len=320) :: mesg ! The text of an error message
integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state
integer :: i, j, is, ie, js, je, ied, jed, it1, it3
- real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation [Z L2 ~> m3]
- !for all ice sheets, Antarctica only, or Greenland only [Z L2 ~> m3]
+ real :: vaf0, vaf0_A, vaf0_G ! The previous volumes above floatation [Z L2 ~> m3]
+ ! for all ice sheets, Antarctica only, or Greenland only
if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// &
"initialize_ice_shelf must be called before shelf_calc_flux.")
@@ -365,7 +380,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
time_step = time_step_in
Itime_step = 1./time_step
- dh_adott(:,:)=0.0; dh_bdott(:,:)=0.0
+ dh_adott(:,:) = 0.0 ; dh_bdott(:,:) = 0.0
if (CS%active_shelf_dynamics) then
!calculate previous volumes above floatation
@@ -394,9 +409,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
! useful parameters
ZETA_N = CS%Zeta_N
VK = CS%Vk
- RC = CS%Rc
- I_ZETA_N = 1.0 / ZETA_N
+ Rf_crit = CS%Rc
+ I_2Zeta_N = 0.5 / CS%Zeta_N
I_LF = 1.0 / CS%Lat_fusion
+ I_dt_LHF = 1.0 / (time_step * CS%Lat_fusion)
SC = CS%kv_molec/CS%kd_molec_salt
PR = CS%kv_molec/CS%kd_molec_temp
I_VK = 1.0/VK
@@ -454,7 +470,11 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
tauy2 = (((asv1 * (sfc_state%tauy_shelf(i,J-1)**2)) + (asv2 * (sfc_state%tauy_shelf(i,J)**2)) ) * I_av)
endif
u2_av = (((asu1 * (sfc_state%u(I-1,j)**2)) + (asu2 * sfc_state%u(I,j)**2)) * I_au)
- v2_av = (((asv1 * (sfc_state%v(i,J-1)**2)) + (asu2 * sfc_state%v(i,J)**2)) * I_av)
+ if (CS%ustar_from_vel_bugfix) then
+ v2_av = (((asv1 * (sfc_state%v(i,J-1)**2)) + (asv2 * sfc_state%v(i,J)**2)) * I_av)
+ else
+ v2_av = (((asv1 * (sfc_state%v(i,J-1)**2)) + (asu2 * sfc_state%v(i,J)**2)) * I_av)
+ endif
if ((taux2 + tauy2 > 0.0) .and. .not.CS%ustar_shelf_from_vel) then
if (CS%ustar_max >= 0.0) then
@@ -486,7 +506,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
do i=is,ie
if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. &
- (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then
+ (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo &
+ .and. ISS%melt_mask(i,j)>0.0) then
if (CS%threeeq) then
! Iteratively determine a self-consistent set of fluxes, with the ocean
@@ -502,11 +523,12 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
if (absf*sfc_state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = sfc_state%Hml(i,j)
else ; hBL_neut = (VK*ustar_h) / absf ; endif
hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%kv_molec))
+ ln_neut = 0.0 ; if (hBL_neut_h_molec > 1.0) ln_neut = log(hBL_neut_h_molec)
+ n_star_term = (ZETA_N * hBL_neut * VK) / (Rf_crit * ustar_h**3)
! Determine the mixed layer buoyancy flux, wB_flux.
dB_dS = (US%L_to_Z**2*CS%g_Earth / Rhoml(i)) * dR0_dS(i)
dB_dT = (US%L_to_Z**2*CS%g_Earth / Rhoml(i)) * dR0_dT(i)
- ln_neut = 0.0 ; if (hBL_neut_h_molec > 1.0) ln_neut = log(hBL_neut_h_molec)
if (CS%find_salt_root) then
! Solve for the skin salinity using the linearized liquidus parameters and
@@ -556,68 +578,152 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
dT_ustar = (ISS%tfreeze(i,j) - sfc_state%sst(i,j)) * ustar_h
dS_ustar = (Sbdry(i,j) - sfc_state%sss(i,j)) * ustar_h
- ! First, determine the buoyancy flux assuming no effects of stability
- ! on the turbulence. Following H & J '99, this limit also applies
- ! when the buoyancy flux is destabilizing.
-
- if (CS%const_gamma) then ! if using a constant gamma_T
- ! note the different form, here I_Gam_T is NOT 1/Gam_T!
+ if (CS%const_gamma) then
+ ! If using a constant gamma_T, there are no effects of the buoyancy flux on the turbulence.
I_Gam_T = CS%Gamma_T_3EQ
I_Gam_S = CS%Gamma_S_3EQ
- else
- Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0))
+ wT_flux = dT_ustar * CS%Gamma_T_3EQ
+ wB_flux = dB_dS * (dS_ustar * CS%Gamma_S_3EQ) + dB_dT * wT_flux
+ elseif (.not.CS%buoy_flux_itt_bugfix) then
+ ! Gamma_T and gamma_S are a function of the buoyancy flux, and there should have been
+ ! iteration to find the root where wB_flux is consistent with the values of gamma with
+ ! that flux, but it was omitted.
+ Gam_turb = I_VK * (ln_neut + (I_2Zeta_N - 1.0))
I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb)
I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb)
- endif
+ wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * (dT_ustar * I_Gam_T)
- wT_flux = dT_ustar * I_Gam_T
- wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux
+ if (wB_flux < 0.0) then ! The stabilising buoyancy flux reduces the turbulent fluxes.
+ I_n_star = sqrt(1.0 - n_star_term * wB_flux)
+ if (hBL_neut_h_molec > I_n_star**2) then
+ Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + (I_2Zeta_N*I_n_star - 1.0))
+ else ! The layer dominated by molecular viscosity is smaller than the boundary layer.
+ Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0)
+ endif
+ I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb)
+ I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb)
+ endif
+ wT_flux = dT_ustar * I_Gam_T
+ else ! gamma_T and gamma_S are a function of the buoyancy flux with proper iteration.
+ ! Find the root where wB_flux is consistent with the values of gamma with that flux.
+
+ ! First, determine the buoyancy flux assuming no effects of stability
+ ! on the turbulence. Following H & J '99, this limit also applies
+ ! when the buoyancy flux is destabilizing.
+ Gam_turb = I_VK * (ln_neut + (I_2Zeta_N - 1.0))
+ I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb)
+ I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb)
+ wB_flux = (dB_dS * dS_ustar) * I_Gam_S + (dB_dT * dT_ustar) * I_Gam_T
- if (wB_flux < 0.0) then
- ! The buoyancy flux is stabilizing and will reduce the turbulent
- ! fluxes, and iteration is required.
- n_star_term = (ZETA_N * hBL_neut * VK) / (RC * ustar_h**3)
- do it3 = 1,30
- ! n_star <= 1.0 is the ratio of working boundary layer thickness
- ! to the neutral thickness.
- ! hBL = n_star*hBL_neut ; hSub = 1/8*n_star*hBL
+ if (wB_flux < 0.0) then
+ ! The buoyancy flux is stabilizing and will reduce the turbulent
+ ! fluxes, and iteration is required.
+ ! n_star <= 1.0 is the ratio of working boundary layer thickness
+ ! to the neutral thickness. I_n_star is its inverse.
I_n_star = sqrt(1.0 - n_star_term * wB_flux)
- dIns_dwB = 0.5 * n_star_term / I_n_star
if (hBL_neut_h_molec > I_n_star**2) then
- Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + &
- (0.5*I_ZETA_N*I_n_star - 1.0))
- dG_dwB = I_VK * ( -2.0 / I_n_star + (0.5 * I_ZETA_N)) * dIns_dwB
- else
- ! The layer dominated by molecular viscosity is smaller than
- ! the assumed boundary layer. This should be rare!
- Gam_turb = I_VK * (0.5 * I_ZETA_N*I_n_star - 1.0)
- dG_dwB = I_VK * (0.5 * I_ZETA_N) * dIns_dwB
+ Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + (I_2Zeta_N*I_n_star - 1.0))
+ else ! The layer dominated by molecular viscosity is smaller than the boundary layer.
+ Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0)
endif
-
- if (CS%const_gamma) then ! if using a constant gamma_T
- ! note the different form, here I_Gam_T is NOT 1/Gam_T!
- I_Gam_T = CS%Gamma_T_3EQ
- I_Gam_S = CS%Gamma_S_3EQ
- else
- I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb)
- I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb)
+ I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb)
+ I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb)
+
+ wB_flux_new = (dB_dS * dS_ustar) * I_Gam_S + (dB_dT * dT_ustar) * I_Gam_T
+ root_found = (abs(wB_flux_new - wB_flux) < CS%buoy_flux_tol*(abs(wB_flux_new) + abs(wB_flux)))
+ ! Do not update the flux if its maagnitude would be increased by the otherwise
+ ! stabilizing buoyancy fluxes. This can happen when the buoyancy flux
+ ! is stabilizing when one of the heat or salt fluxes are destabilizing due
+ ! to their different molecular properties.
+ if (wB_flux_new <= wB_flux) root_found = .true.
+
+ if (.not.root_found) then
+ wB_flux_max = 0.0 ; DwB_max = wB_flux
+ wB_flux_min = wB_flux ; DwB_min = wB_flux_new - wB_flux
+
+ if ((wB_flux_min*n_star_term < (1.0 - hBL_neut_h_molec)) .and. &
+ ((1.0 - hBL_neut_h_molec) < wB_flux_max*n_star_term)) then
+ ! The derivative of Gam_turb with wB_flux has a discontinuous change within the
+ ! bracketed range of values. Take this discontinous slope value for a first
+ ! guess, because Newton's method and the false position method may not converge
+ ! quickly when this discontinuity is between a guess and the solution.
+ wB_flux = (1.0 - hBL_neut_h_molec) / n_star_term
+ I_n_star = sqrt(hBL_neut_h_molec)
+ Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0)
+ I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb)
+ I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb)
+ wB_flux_new = (dB_dS * dS_ustar) * I_Gam_S + (dB_dT * dT_ustar) * I_Gam_T
+
+ if (abs(wB_flux_new - wB_flux) <= CS%buoy_flux_tol*(abs(wB_flux_new) + abs(wB_flux))) then
+ ! The root has been found to within the tolerance at the kink. This should be very rare.
+ root_found = .true.
+ elseif (wB_flux_new > wB_flux) then
+ ! The solution is in the limit where abs(wB_flux) is small and
+ ! Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + (I_2Zeta_N*I_n_star - 1.0))
+ wB_flux_min = wB_flux ; DwB_min = wB_flux_new - wB_flux
+ else
+ ! The solution is in the limt where abs(wB_flux) is large and
+ ! Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0)
+ wB_flux_max = wB_flux ; DwB_max = wB_flux_new - wB_flux
+ endif
+ endif
endif
- wT_flux = dT_ustar * I_Gam_T
- wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux
-
- ! Find the root where wB_flux_new = wB_flux.
- if (abs(wB_flux_new - wB_flux) < CS%buoy_flux_itt_threshold*(abs(wB_flux_new) + abs(wB_flux))) exit
+ if (.not.root_found) then
+ ! Use the false position for the next guess.
+ wB_flux = wB_flux_min + (wB_flux_max-wB_flux_min) * (DwB_min / (DwB_min - DwB_max))
+
+ do it3 = 1,30
+ ! Iterate using Newton's method with bounds or the false position method to find the root.
+
+ I_n_star = sqrt(1.0 - n_star_term * wB_flux)
+ dIns_dwB = -0.5 * n_star_term / I_n_star
+ if (hBL_neut_h_molec > I_n_star**2) then
+ Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + (I_2Zeta_N*I_n_star - 1.0))
+ dG_dwB = I_VK * (( -2.0 / I_n_star + I_2Zeta_N) * dIns_dwB)
+ else
+ ! The layer dominated by molecular viscosity is smaller than the boundary layer.
+ Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0)
+ dG_dwB = I_VK * (I_2Zeta_N * dIns_dwB)
+ endif
+ I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb)
+ I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb)
+ wB_flux_new = (dB_dS * dS_ustar) * I_Gam_S + (dB_dT * dT_ustar) * I_Gam_T
+
+ ! Test for convergence to within tolerance at the point where wB_flux_new = wB_flux.
+ if (abs(wB_flux_new - wB_flux) <= CS%buoy_flux_tol*(abs(wB_flux_new) + abs(wB_flux))) &
+ root_found = .true.
+ if (root_found) exit
+
+ dDwB_dwB = -dG_dwB * ((dB_dS * dS_ustar) * I_Gam_S**2 + &
+ (dB_dT * dT_ustar) * I_Gam_T**2) - 1.0
+ if ((dDwB_dwB >= 0.0) .or. &
+ ( wB_flux - wB_flux_new >= abs(dDwB_dwB)*(wB_flux_max - wB_flux)) .or. &
+ ( wB_flux - wB_flux_new <= abs(dDwB_dwB)*(wB_flux_min - wB_flux)) ) then
+ ! Use the False position method to determine the guess for the next iteration when
+ ! Newton's method would go out of bounds
+ wB_flux_next = wB_flux_min + (wB_flux_max-wB_flux_min) * (DwB_min / (DwB_min - DwB_max))
+ else
+ ! Use Newton's method for the next guess.
+ wB_flux_next = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB
+ endif
+
+ ! Reset one of the bounds inward.
+ if (wB_flux_new - wB_flux > 0) then
+ wB_flux_min = wB_flux ; DwB_min = wB_flux_new - wB_flux
+ else
+ wB_flux_max = wB_flux ; DwB_max = wB_flux_new - wB_flux
+ endif
+
+ ! Update wB_flux
+ wB_flux = wB_flux_next
+ enddo ! it3
+ endif
- dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + &
- dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0
- ! This is Newton's method without any bounds. Should bounds be needed?
- wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in
- ! Update wB_flux
- if (CS%buoy_flux_itt_bug) wB_flux = wB_flux_new
- enddo !it3
- endif
+ endif ! End of test for first guess of wB_flux < 0.
+ wT_flux = dT_ustar * I_Gam_T
+ endif ! End of test for CS%const_gamma
ISS%tflux_ocn(i,j) = RhoCp * wT_flux
exch_vel_t(i,j) = ustar_h * I_Gam_T
@@ -688,7 +794,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
Sbdry(i,j) = Sbdry_it
endif ! Sb_min_set
- if (.not.CS%salt_flux_itt_bug) Sbdry(i,j) = Sbdry_it
+ if (.not.CS%salt_flux_itt_bugfix) Sbdry(i,j) = Sbdry_it
endif ! CS%find_salt_root
@@ -720,10 +826,20 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
enddo ! i-loop
enddo ! j-loop
+ if (allocated(sfc_state%frazil)) then
+ add_frazil = .true.
+ else
+ add_frazil = .false.
+ endif
do j=js,je ; do i=is,ie
! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1]
- fluxes%iceshelf_melt(i,j) = ISS%water_flux(i,j) * CS%flux_factor
+ if (CS%flux_factor/=1.0) then
+ ISS%water_flux(i,j) = ISS%water_flux(i,j) * CS%flux_factor
+ ISS%tflux_ocn(i,j) = ISS%tflux_ocn(i,j) * CS%flux_factor
+ if (CS%threeeq .and. ISS%tflux_ocn(i,j) < 0.0 .and. (.not. CS%insulator)) &
+ ISS%tflux_shelf(i,j)=ISS%tflux_ocn(i,j) + CS%Lat_fusion * ISS%water_flux(i,j)
+ endif
if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. &
(ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then
@@ -732,7 +848,6 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
! This is needed for the ISOMIP test case.
if (ISS%mass_shelf(i,j) < CS%Rho_ocn*CS%cutoff_depth) then
ISS%water_flux(i,j) = 0.0
- fluxes%iceshelf_melt(i,j) = 0.0
endif
! Compute haline driving, which is one of the diags. used in ISOMIP
if (exch_vel_s(i,j)>0.) haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / (CS%Rho_ocn * exch_vel_s(i,j))
@@ -740,7 +855,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!!
!1)Check if haline_driving computed above is consistent with
! haline_driving = sfc_state%sss - Sbdry
- !if (fluxes%iceshelf_melt(i,j) /= 0.0) then
+ !if (ISS%water_flux(i,j) /= 0.0) then
! if (haline_driving(i,j) /= (sfc_state%sss(i,j) - Sbdry(i,j))) then
! write(mesg,*) 'at i,j=',i,j,' haline_driving, sss-Sbdry',US%S_to_ppt*haline_driving(i,j), &
! US%S_to_ppt*(sfc_state%sss(i,j) - Sbdry(i,j))
@@ -751,8 +866,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
! 2) check if |melt| > 0 when ustar_shelf = 0.
! this should never happen
- if ((abs(fluxes%iceshelf_melt(i,j))>0.0) .and. (fluxes%ustar_shelf(i,j) == 0.0)) then
- write(mesg,*) "|melt| = ",fluxes%iceshelf_melt(i,j)," > 0 and ustar_shelf = 0. at i,j", i, j
+ if ((abs(ISS%water_flux(i,j))>0.0) .and. (fluxes%ustar_shelf(i,j) == 0.0)) then
+ write(mesg,*) "|melt| = ",ISS%water_flux(i,j)," > 0 and ustar_shelf = 0. at i,j", i, j
call MOM_error(FATAL, "shelf_calc_flux: "//trim(mesg))
endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!!
@@ -760,11 +875,15 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
! This is grounded ice, that could be modified to melt if a geothermal heat flux were used.
haline_driving(i,j) = 0.0
ISS%water_flux(i,j) = 0.0
- fluxes%iceshelf_melt(i,j) = 0.0
endif ! area_shelf_h
! mass flux [R Z L2 T-1 ~> kg s-1], part of ISOMIP diags.
mass_flux(i,j) = ISS%water_flux(i,j) * ISS%area_shelf_h(i,j)
+
+ !Add frazil formation
+ if (add_frazil .and. (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 2)) &
+ ISS%water_flux(i,j) = ISS%water_flux(i,j) - ISS%frazil(i,j) * I_dt_LHF
+ fluxes%iceshelf_melt(i,j) = ISS%water_flux(i,j)
enddo ; enddo ! i- and j-loops
if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then
@@ -822,14 +941,14 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
do j=js,je ; do i=is,ie
ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j))*Itime_step
- enddo; enddo
+ enddo ; enddo
call IS_dynamics_post_data(time_step, Time, CS%dCS, ISS, G)
endif
if (CS%shelf_mass_is_dynamic) &
call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, ISS%area_shelf_h, Time, &
- time_step=real_to_time(US%T_to_s*time_step) )
+ time_step=real_to_time(time_step, unscale=US%T_to_s) )
if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0)
@@ -856,10 +975,14 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag)
if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag)
if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag)
+ if (CS%id_frazil > 0) call post_data(CS%id_frazil,ISS%frazil,CS%diag)
if (CS%active_shelf_dynamics) &
call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott)
call disable_averaging(CS%diag)
+ !reset used frazil
+ if (add_frazil) ISS%frazil(:,:) = 0.0
+
call cpu_clock_end(id_clock_shelf)
if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0)
@@ -875,6 +998,59 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS)
end subroutine shelf_calc_flux
+!> Copies frazil from the ocean surface state to the ice sheet state. Removes frazil that will
+!! be used by the ice sheet from the ocean surface state
+subroutine adjust_ice_sheet_frazil(sfc_state_in, fluxes_in, CS)
+ type(surface), target, intent(inout) :: sfc_state_in !< A structure containing fields that
+ !! describe the surface state of the ocean. The
+ !! intent is only inout to allow for halo updates.
+ type(forcing), target, intent(in) :: fluxes_in !< structure containing pointers to any
+ !! possible thermodynamic or mass-flux forcing fields.
+ type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned
+ !! by a previous call to initialize_ice_shelf.
+ ! Local variables
+ type(ocean_grid_type), pointer :: G => NULL() !< The grid structure used by the ice shelf.
+ type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe
+ !! the ice-shelf state
+ type(surface), pointer :: sfc_state => NULL()
+ type(forcing), pointer :: fluxes => NULL()
+ integer :: i,j,is,ie,js,je
+
+ G => CS%grid ; ISS => CS%ISS
+
+ if (CS%rotate_index) then
+ allocate(sfc_state)
+ call rotate_surface_state(sfc_state_in, sfc_state, G, CS%turns)
+ allocate(fluxes)
+ call allocate_forcing_type(fluxes_in, G, fluxes, turns=CS%turns)
+ call rotate_forcing(fluxes_in, fluxes, CS%turns)
+ else
+ sfc_state => sfc_state_in
+ fluxes => fluxes_in
+ endif
+
+ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
+
+ do j=js,je ; do i=is,ie
+ !Copy frazil to the ice sheet module where ice sheet is present.
+ !No scaling to account for partial ice-sheet cells is necessary here, as
+ !this is taken care of when applied to the ice sheet.
+ if (fluxes%frac_shelf_h(i,j)>0.0) ISS%frazil(i,j) = sfc_state%frazil(i,j)
+ !Remove the frazil that is used by the ice sheet from sfc_state%frazil
+ !The sfc_state%frazil is sent to the sea-ice module
+ sfc_state%frazil(i,j) = sfc_state%frazil(i,j) * (1.0-fluxes%frac_shelf_h(i,j))
+ enddo ; enddo
+
+ if (CS%rotate_index) then
+ call rotate_surface_state(sfc_state, sfc_state_in, G, -CS%turns)
+ ! call rotate_forcing(fluxes, fluxes_in, -CS%turns)
+ call deallocate_surface_state(sfc_state)
+ deallocate(sfc_state)
+ call deallocate_forcing_type(fluxes)
+ deallocate(fluxes)
+ endif
+end subroutine adjust_ice_sheet_frazil
+
function integrate_over_ice_sheet_area(G, ISS, var, unscale, hemisphere) result(var_out)
type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe the ice-shelf state
@@ -888,31 +1064,31 @@ function integrate_over_ice_sheet_area(G, ISS, var, unscale, hemisphere) result(
real, dimension(SZI_(G),SZJ_(G)) :: var_cell !< Variable integrated over the ice-sheet area of each cell
!! in arbitrary units [A L2 ~> a m2]
integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated
- integer :: i,j
+ integer :: i, j
if (present(hemisphere)) then
- IS_ID=hemisphere
+ IS_ID = hemisphere
else
- IS_ID=-1
+ IS_ID = -1
endif
- mask(:,:)=0
+ mask(:,:) = 0
if (IS_ID==0) then !Antarctica (S. Hemisphere) only
- do j = G%jsc,G%jec; do i = G%isc,G%iec
+ do j = G%jsc,G%jec ; do i = G%isc,G%iec
if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)<=0.0) mask(i,j)=1
- enddo; enddo
+ enddo ; enddo
elseif (IS_ID==1) then !Greenland (N. Hemisphere) only
- do j = G%jsc,G%jec; do i = G%isc,G%iec
+ do j = G%jsc,G%jec ; do i = G%isc,G%iec
if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)>0.0) mask(i,j)=1
- enddo; enddo
+ enddo ; enddo
else !All ice sheets
mask(G%isc:G%iec,G%jsc:G%jec) = ISS%hmask(G%isc:G%iec,G%jsc:G%jec)
endif
- var_cell(:,:)=0.0
- do j = G%jsc,G%jec; do i = G%isc,G%iec
+ var_cell(:,:) = 0.0
+ do j = G%jsc,G%jec ; do i = G%isc,G%iec
if (mask(i,j)>0) var_cell(i,j) = var(i,j) * ISS%area_shelf_h(i,j)
- enddo; enddo
+ enddo ; enddo
var_out = reproducing_sum(var_cell, unscale=unscale*G%US%L_to_m**2)
end function integrate_over_ice_sheet_area
@@ -1138,7 +1314,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step)
type(ice_shelf_CS), pointer :: CS !< This module's control structure.
type(surface), intent(inout) :: sfc_state !< Surface ocean state
type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated.
- real, intent(in) :: time_step !< Time step over which fluxes are applied
+ real, intent(in) :: time_step !< Time step over which fluxes are applied [T ~> s]
! local variables
real :: frac_shelf !< The fractional area covered by the ice shelf [nondim].
real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim].
@@ -1215,15 +1391,15 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step)
if (associated(fluxes%evap)) fluxes%evap(i,j) = frac_open * fluxes%evap(i,j)
if (associated(fluxes%lprec)) then
if (ISS%water_flux(i,j) > 0.0) then
- fluxes%lprec(i,j) = frac_shelf*ISS%water_flux(i,j)*CS%flux_factor + frac_open * fluxes%lprec(i,j)
+ fluxes%lprec(i,j) = frac_shelf*ISS%water_flux(i,j) + frac_open * fluxes%lprec(i,j)
else
fluxes%lprec(i,j) = frac_open * fluxes%lprec(i,j)
- fluxes%evap(i,j) = fluxes%evap(i,j) + frac_shelf*ISS%water_flux(i,j)*CS%flux_factor
+ fluxes%evap(i,j) = fluxes%evap(i,j) + frac_shelf*ISS%water_flux(i,j)
endif
endif
if (associated(fluxes%sens)) &
- fluxes%sens(i,j) = frac_shelf*ISS%tflux_ocn(i,j)*CS%flux_factor + frac_open * fluxes%sens(i,j)
+ fluxes%sens(i,j) = frac_shelf*ISS%tflux_ocn(i,j) + frac_open * fluxes%sens(i,j)
! The salt flux should be mostly from sea ice, so perhaps none should be intercepted and this should be changed.
if (associated(fluxes%salt_flux)) &
fluxes%salt_flux(i,j) = frac_shelf * ISS%salt_flux(i,j)*CS%flux_factor + frac_open * fluxes%salt_flux(i,j)
@@ -1247,7 +1423,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step)
! take into account changes in mass (or thickness) when imposing ice shelf mass
if (CS%override_shelf_movement .and. CS%mass_from_file) then
- dTime = real_to_time(US%T_to_s*CS%time_step)
+ dTime = real_to_time(CS%time_step, unscale=US%T_to_s)
! Compute changes in mass after at least one full time step
if (CS%Time > dTime) then
@@ -1377,10 +1553,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
type(directories) :: dirs
type(dyn_horgrid_type), pointer :: dG => NULL()
type(dyn_horgrid_type), pointer :: dG_in => NULL()
- real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic.
+ real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic
+ ! [T kg R-1 Z-1 m-2 s-1 ~> nondim]
real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered
! to be floating when CONST_SEA_LEVEL = True [Z ~> m].
- real :: cdrag, drag_bg_vel
+ real :: cdrag ! The drag coefficient at the ice-ocean interface [nondim]
+ real :: drag_bg_vel ! A background velocity used in the quadratic drag [Z T-1 ~> m s-1]
logical :: new_sim, save_IC
!This include declares and sets the variable "version".
# include "version_variable.h"
@@ -1396,7 +1574,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
real :: utide ! A tidal velocity [L T-1 ~> m s-1]
real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting
! does not occur [Z ~> m]
- real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data
+ real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for ice shelf input data [L T-1 ~> m s-1]
+ real, allocatable, dimension(:,:) :: maskT ! Temporary array for the tracer points masks [nondim]
type(surface), pointer :: sfc_state => NULL()
type(vardesc) :: u_desc, v_desc
@@ -1456,6 +1635,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
call set_grid_metrics(dG_in, param_file, CS%US)
! Set up the bottom depth, dG_in%bathyT, either analytically or from file
call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file, CS%US)
+
+ ! The use of maskT here sets all ice shelf points to be unmasked.
+ allocate(maskT(dG_in%isd:dG_in%ied,dG_in%jsd:dG_in%jed), source=1.0)
+ call initialize_masks(dG_in, param_file, CS%US, maskT=maskT)
+ deallocate(maskT)
+
call copy_dyngrid_to_MOM_grid(dG_in, CS%Grid_in, CS%US)
! Now set up the rotated ice-shelf grid.
@@ -1477,6 +1662,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
call set_grid_metrics(dG, param_file, CS%US)
! Set up the bottom depth, dG%bathyT, either analytically or from file
call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US)
+
+ ! The use of maskT here sets all ice shelf points to be unmasked.
+ allocate(maskT(dG%isd:dG%ied,dG%jsd:dG%jed), source=1.0)
+ call initialize_masks(dG, param_file, CS%US, maskT=maskT)
+ deallocate(maskT)
+
call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US)
call destroy_dyn_horgrid(dG)
endif
@@ -1486,7 +1677,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
call MOM_IS_diag_mediator_init(G, CS%US, param_file, CS%diag, component='MOM_IceShelf')
! This call sets up the diagnostic axes. These are needed,
! e.g. to generate the target grids below.
- call set_IS_axes_info(G, param_file, CS%diag)
+ call set_IS_axes_info(G, CS%diag)
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
@@ -1632,7 +1823,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
call get_param(param_file, mdl, "RHO_0", CS%Rho_ocn, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, &
@@ -1686,11 +1877,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
call get_param(param_file, mdl, "ICE_SHELF_RC", CS%Rc, &
"Critical flux Richardson number for ice melt ", &
units="nondim", default=0.20)
- call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_BUG", CS%buoy_flux_itt_bug, &
- "Bug fix of buoyancy iteration", default=.true.)
- call get_param(param_file, mdl, "ICE_SHELF_SALT_FLUX_ITT_BUG", CS%salt_flux_itt_bug, &
- "Bug fix of salt iteration", default=.true.)
- call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_THRESHOLD", CS%buoy_flux_itt_threshold, &
+ call get_param(param_file, mdl, "ICE_SHELF_USTAR_FROM_VEL_BUGFIX", CS%ustar_from_vel_bugfix, &
+ "Bug fix for ice-area weighting of squared ocean velocities "//&
+ "used to calculate friction velocity under ice shelves", default=.false.)
+ call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_BUGFIX", CS%buoy_flux_itt_bugfix, &
+ "Bug fix of buoyancy iteration", default=.true., old_name="ICE_SHELF_BUOYANCY_FLUX_ITT_BUG")
+ call get_param(param_file, mdl, "ICE_SHELF_SALT_FLUX_ITT_BUGFIX", CS%salt_flux_itt_bugfix, &
+ "Bug fix of salt iteration", default=.true., old_name="ICE_SHELF_SALT_FLUX_ITT_BUG")
+ call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_THRESHOLD", CS%buoy_flux_tol, &
"Convergence criterion of Newton's method for ice shelf "//&
"buoyancy iteration.", units="nondim", default=1.0e-4)
@@ -1804,8 +1998,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
if (new_sim) then
! new simulation, initialize ice thickness as in the static case
- call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file, &
- CS%rotate_index, CS%turns)
+ call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, ISS%melt_mask, CS%Grid, CS%Grid_in, &
+ US, param_file, CS%rotate_index, CS%turns)
! next make sure mass is consistent with thickness
do j=G%jsd,G%jed ; do i=G%isd,G%ied
@@ -1839,7 +2033,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
"Ice shelf area in cell", "m2", conversion=US%L_to_m**2)
call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, &
"ice sheet/shelf thickness", "m", conversion=US%Z_to_m)
-
+ call register_restart_field(ISS%melt_mask, "melt_mask", .false., CS%restart_CSp, &
+ "Mask that is >0 where ice-shelf melting is allowed", "none")
if (CS%calve_ice_shelf_bergs) then
call register_restart_field(ISS%calving, "shelf_calving", .true., CS%restart_CSp, &
"Calving flux from ice shelf into icebergs", "kg m-2", conversion=US%RZ_to_kg_m2)
@@ -1885,8 +2080,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then
! This model is initialized internally or from a file.
- call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file,&
- CS%rotate_index, CS%turns)
+ call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, ISS%melt_mask, CS%Grid, CS%Grid_in, &
+ US, param_file, CS%rotate_index, CS%turns)
! next make sure mass is consistent with thickness
do j=G%jsd,G%jed ; do i=G%isd,G%ied
if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j) == 3)) then
@@ -2001,6 +2196,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init,
'Heat conduction into ice shelf', 'W m-2', conversion=-US%QRZ_T_to_W_m2)
CS%id_ustar_shelf = register_diag_field('ice_shelf_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, &
'Fric vel under shelf', 'm/s', conversion=US%Z_to_m*US%s_to_T)
+ CS%id_frazil = register_diag_field('ice_shelf_model', 'frazil', CS%diag%axesT1, CS%Time, &
+ 'Frazil heat rejected by the ocean', 'J m-2', conversion=US%Q_to_J_kg*US%RZ_to_kg_m2)
if (CS%active_shelf_dynamics) then
CS%id_h_mask = register_diag_field('ice_shelf_model', 'h_mask', CS%diag%axesT1, CS%Time, &
'ice shelf thickness mask', 'none', conversion=1.0)
@@ -2356,6 +2553,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim)
end select
end subroutine initialize_shelf_mass
+
!> This subroutine applies net accumulation/ablation at the top surface to the dynamic ice shelf.
!! acc_rate[m-s]=surf_mass_flux/density_ice is ablation/accumulation rate
!! positive for accumulation negative for ablation
@@ -2372,14 +2570,13 @@ subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time
! locals
integer :: i, j
- real ::I_rho_ice
+ real :: I_rho_ice ! The specific volume of ice [R-1 ~> m3 kg-1]
I_rho_ice = 1.0 / CS%density_ice
!update time
! CS%Time = Time
-
! CS%time_step = time_step
! update surface mass flux rate
! if (CS%surf_mass_flux_from_file) call update_surf_mass_flux(G, US, CS, ISS, Time)
@@ -2463,7 +2660,7 @@ subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_
type(ice_shelf_CS), pointer :: CS !< ice shelf control structure
type(ocean_grid_type), intent(in) :: G !< A pointer to an ocean grid control structure.
real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: frac_shelf_h !< Ice shelf area fraction [nondim].
- real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf ! kg m-2]
+ real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf !< Ice shelf mass [R Z ~> kg m-2]
logical, optional :: data_override_shelf_fluxes !< If true, shelf fluxes can be written using
!! the data_override capability (only for MOSAIC grids)
@@ -2563,7 +2760,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in
ISS => CS%ISS
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
- remaining_time = US%s_to_T*time_type_to_real(time_interval)
+ remaining_time = time_to_real(time_interval, scale=US%s_to_T)
full_time_step = remaining_time
Ifull_time_step = 1./full_time_step
@@ -2573,7 +2770,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in
min_time_step = 1000.0*US%s_to_T ! At 1 km resolution this would imply ice is moving at ~1 meter per second
endif
- write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.)
+ write (mesg,*) "TIME in ice shelf call, yrs: ", time_to_real(Time)/(365. * 86400.)
call MOM_mesg("solo_step_ice_shelf: "//mesg, 5)
ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:)
@@ -2621,7 +2818,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in
time_step=time_interval)
do j=js,je ; do i=is,ie
ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j)) * Ifull_time_step
- enddo; enddo
+ enddo ; enddo
call enable_averages(full_time_step, Time, CS%diag)
if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h ,ISS%area_shelf_h,CS%diag)
@@ -2681,7 +2878,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
call masked_var_grounded(G,CS%dCS,dh_adott,tmp)
do j=js,je ; do i=is,ie
tmp(i,j) = dh_adott(i,j) - tmp(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m)
if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag)
if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Itime_step,CS%diag)
@@ -2695,7 +2892,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
tmp(:,:)=0.0
do j=js,je ; do i=is,ie
if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m)
if (CS%id_bdott_melt > 0) call post_scalar_data(CS%id_bdott_melt,val ,CS%diag)
if (CS%id_bdot_melt > 0) call post_scalar_data(CS%id_bdot_melt ,val*Itime_step,CS%diag)
@@ -2704,7 +2901,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
tmp(:,:)=0.0
do j=js,je ; do i=is,ie
if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m)
if (CS%id_bdott_accum > 0) call post_scalar_data(CS%id_bdott_accum,val ,CS%diag)
if (CS%id_bdot_accum > 0) call post_scalar_data(CS%id_bdot_accum ,val*Itime_step,CS%diag)
@@ -2745,7 +2942,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
call masked_var_grounded(G,CS%dCS,dh_adott,tmp)
do j=js,je ; do i=is,ie
tmp(i,j) = dh_adott(i,j) - tmp(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=0)
if (CS%id_Ant_f_adott > 0) call post_scalar_data(CS%id_Ant_f_adott,val ,CS%diag)
if (CS%id_Ant_f_adot > 0) call post_scalar_data(CS%id_Ant_f_adot ,val*Itime_step,CS%diag)
@@ -2759,7 +2956,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
tmp(:,:)=0.0
do j=js,je ; do i=is,ie
if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=0)
if (CS%id_Ant_bdott_melt > 0) call post_scalar_data(CS%id_Ant_bdott_melt,val ,CS%diag)
if (CS%id_Ant_bdot_melt > 0) call post_scalar_data(CS%id_Ant_bdot_melt ,val*Itime_step,CS%diag)
@@ -2768,13 +2965,13 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
tmp(:,:)=0.0
do j=js,je ; do i=is,ie
if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=0)
if (CS%id_Ant_bdott_accum > 0) call post_scalar_data(CS%id_Ant_bdott_accum,val ,CS%diag)
if (CS%id_Ant_bdot_accum > 0) call post_scalar_data(CS%id_Ant_bdot_accum ,val*Itime_step,CS%diag)
endif
if (CS%id_Ant_t_area > 0) then !ice sheet area
- tmp(:,:) = 1.0; val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0, hemisphere=0)
+ tmp(:,:) = 1.0 ; val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0, hemisphere=0)
call post_scalar_data(CS%id_Ant_t_area,val,CS%diag)
endif
if (CS%id_Ant_g_area > 0 .or. CS%id_Ant_f_area > 0) then
@@ -2809,7 +3006,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
call masked_var_grounded(G,CS%dCS,dh_adott,tmp)
do j=js,je ; do i=is,ie
tmp(i,j) = dh_adott(i,j) - tmp(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=1)
if (CS%id_Gr_f_adott > 0) call post_scalar_data(CS%id_Gr_f_adott,val ,CS%diag)
if (CS%id_Gr_f_adot > 0) call post_scalar_data(CS%id_Gr_f_adot ,val*Itime_step,CS%diag)
@@ -2823,7 +3020,7 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
tmp(:,:)=0.0
do j=js,je ; do i=is,ie
if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=1)
if (CS%id_Gr_bdott_melt > 0) call post_scalar_data(CS%id_Gr_bdott_melt,val ,CS%diag)
if (CS%id_Gr_bdot_melt > 0) call post_scalar_data(CS%id_Gr_bdot_melt ,val*Itime_step,CS%diag)
@@ -2832,13 +3029,13 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh
tmp(:,:)=0.0
do j=js,je ; do i=is,ie
if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j)
- enddo; enddo
+ enddo ; enddo
val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=1)
if (CS%id_Gr_bdott_accum > 0) call post_scalar_data(CS%id_Gr_bdott_accum,val ,CS%diag)
if (CS%id_Gr_bdot_accum > 0) call post_scalar_data(CS%id_Gr_bdot_accum ,val*Itime_step,CS%diag)
endif
if (CS%id_Gr_t_area > 0) then !ice sheet area
- tmp(:,:) = 1.0; val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0, hemisphere=1)
+ tmp(:,:) = 1.0 ; val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0, hemisphere=1)
call post_scalar_data(CS%id_Gr_t_area,val,CS%diag)
endif
if (CS%id_Gr_g_area > 0 .or. CS%id_Gr_f_area > 0) then
diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90
index fe54dd6533..b9df5341b0 100644
--- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90
+++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90
@@ -1,58 +1,107 @@
-!> Convenient wrappers to the FMS diag_manager interfaces with additional diagnostic capabilies.
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+!> The subroutines here provide convenient wrappers to the FMS diag_manager
+!! interfaces with additional diagnostic capabilities.
module MOM_IS_diag_mediator
-! This file is a part of SIS2. See LICENSE.md for the license.
-
-use MOM_coms, only : PE_here
-use MOM_diag_manager_infra, only : MOM_diag_manager_init, send_data_infra, MOM_diag_axis_init
-use MOM_diag_manager_infra, only : EAST, NORTH
-use MOM_diag_manager_infra, only : register_static_field_infra
-use MOM_diag_manager_infra, only : register_diag_field_infra
-use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert
-use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
-use MOM_grid, only : ocean_grid_type
-use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc
-use MOM_string_functions, only : lowercase, uppercase, slasher
-use MOM_time_manager, only : time_type
-use MOM_unit_scaling, only : unit_scale_type
+use MOM_checksums, only : chksum0, hchksum, uchksum, vchksum, Bchksum
+use MOM_coms, only : PE_here
+use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
+use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE
+use MOM_diag_manager_infra, only : MOM_diag_manager_init
+use MOM_diag_manager_infra, only : MOM_diag_axis_init, get_MOM_diag_axis_name
+use MOM_diag_manager_infra, only : send_data_infra, MOM_diag_field_add_attribute, EAST, NORTH
+use MOM_diag_manager_infra, only : register_diag_field_infra, register_static_field_infra
+use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND
+use MOM_diag_manager_infra, only : diag_send_complete_infra
+use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert, callTree_showQuery
+use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint
+use MOM_file_parser, only : get_param, log_version, param_file_type
+use MOM_grid, only : ocean_grid_type
+use MOM_io, only : get_filename_appendix
+use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc
+use MOM_string_functions, only : lowercase, uppercase, slasher, ints_to_string, trim_trailing_commas
+use MOM_time_manager, only : time_type, get_time
+use MOM_unit_scaling, only : unit_scale_type
implicit none ; private
public MOM_IS_diag_mediator_infrastructure_init
-public set_IS_axes_info, post_IS_data, register_MOM_IS_diag_field, time_type
-public register_MOM_IS_static_field
-public safe_alloc_ptr, safe_alloc_alloc
-public enable_averaging, disable_averaging, query_averaging_enabled
-public enable_averages
public MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end, set_IS_diag_mediator_grid
+public set_IS_axes_info, MOM_diag_axis_init
+public register_MOM_IS_diag_field, register_MOM_IS_static_field, register_MOM_IS_scalar_field
+public post_IS_data, post_IS_data_0d, MOM_IS_diag_send_complete
+public safe_alloc_ptr, safe_alloc_alloc, time_type
+public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled
public MOM_IS_diag_mediator_close_registration, get_diag_time_end
-public MOM_diag_axis_init, register_static_field_infra
-public register_MOM_IS_scalar_field, post_IS_data_0d
+public define_axes_group, diag_masks_set
+public diag_register_area_ids, found_in_diagtable
+
+!> Make a diagnostic available for averaging or output.
+interface post_IS_data
+ module procedure post_IS_data_2d, post_IS_data_0d
+end interface post_IS_data
+
+!> Registers a non-array scalar diagnostic, returning an integer handle
+interface register_MOM_IS_scalar_field
+ module procedure register_scalar_field_CS, register_scalar_field_axes
+end interface register_MOM_IS_scalar_field
-!> 2D/3D axes type to contain 1D axes handles and pointers to masks
-type, public :: axesType
+!> A group of 1D axes that comprise a 1D/2D/3D mesh
+type, public :: axes_grp
character(len=15) :: id !< The id string for this particular combination of handles.
integer :: rank !< Number of dimensions in the list of axes.
integer, dimension(:), allocatable :: handles !< Handles to 1D axes.
- type(diag_ctrl), pointer :: diag_cs => null() !< A structure that is used to regulate diagnostic output
-end type axesType
+ type(diag_ctrl), pointer :: diag_cs => null() !< Circular link back to the main diagnostics control structure
+ !! (Used to avoid passing said structure into every possible call).
+ ! ID's for cell_methods
+ character(len=9) :: x_cell_method = '' !< Default nature of data representation, if axes group
+ !! includes x-direction.
+ character(len=9) :: y_cell_method = '' !< Default nature of data representation, if axes group
+ !! includes y-direction.
+ ! For detecting position on the grid
+ logical :: is_h_point = .false. !< If true, indicates that this axes group is for an h-point located field.
+ logical :: is_q_point = .false. !< If true, indicates that this axes group is for a q-point located field.
+ logical :: is_u_point = .false. !< If true, indicates that this axes group is for a u-point located field.
+ logical :: is_v_point = .false. !< If true, indicates that this axes group is for a v-point located field.
+
+ ! ID's for cell_measures
+ integer :: id_area = -1 !< The diag_manager id for area to be used for cell_measure of variables with this axes_grp.
+ ! For masking
+ real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes [nondim]
+ real, pointer, dimension(:,:) :: mask2d_comp => null() !< Mask for 2-d axes on the computational
+ !! domain for this diagnostic [nondim]
+end type axes_grp
!> This type is used to represent a diagnostic at the diag_mediator level.
+!!
+!! There can be both 'primary' and 'secondary' diagnostics. The primaries
+!! reside in the diag_cs%diags array. They have an id which is an index
+!! into this array. The secondaries are 'variations' on the primary diagnostic.
+!! For example the CMOR diagnostics are secondary. The secondary diagnostics
+!! are kept in a list with the primary diagnostic as the head.
type, private :: diag_type
- logical :: in_use !< This diagnostic is in use
- integer :: fms_diag_id !< underlying FMS diag id
- character(len=24) :: name !< The diagnostic name
- real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero.
- real, pointer, dimension(:,:) :: mask2d => null() !< A 2-d mask on the data domain for this diagnostic [nondim]
- real, pointer, dimension(:,:) :: mask2d_comp => null() !< A 2-d mask on the computational domain
- !! for this diagnostic [nondim]
+ logical :: in_use !< True if this entry is being used.
+ integer :: fms_diag_id !< Underlying FMS diag_manager id.
+ character(len=64) :: debug_str = '' !< The diagnostic name and module for FATAL errors and debugging.
+ type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic
+ type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic
+ real :: conversion_factor = 0. !< If non-zero, a factor to multiply data by before posting to FMS,
+ !! often including factors to undo internal scaling in units of [a A-1 ~> 1]
end type diag_type
-!> The SIS_diag_ctrl data type contains times to regulate diagnostics along with masks and
+!> The diag_ctrl data type contains times to regulate diagnostics along with masks and
!! axes to use with diagnostics, and a list of structures with data about each diagnostic.
type, public :: diag_ctrl
- integer :: doc_unit = -1 !< The unit number of a diagnostic documentation file.
- !! This file is open if doc_unit is > 0.
+ integer :: available_diag_doc_unit = -1 !< The unit number of a diagnostic documentation file.
+ !! This file is open if available_diag_doc_unit is > 0.
+ integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file.
+ !! This file is open if available_diag_doc_unit is > 0.
+ logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics
+ logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level.
+ logical :: index_space_axes !< If true, diagnostic horizontal coordinates axes are in index space.
! The following fields are used for the output of the data.
! These give the computational-domain sizes, and are relative to a start value
@@ -66,177 +115,327 @@ module MOM_IS_diag_mediator
integer :: ied !< The end i-index of cell centers within the data domain
integer :: jsd !< The start j-index of cell centers within the data domain
integer :: jed !< The end j-index of cell centers within the data domain
- real :: time_int !< The time interval for any fields that are offered for averaging [s].
+ real :: time_int !< The time interval for any fields
+ !! that are offered for averaging [s].
type(time_type) :: time_end !< The end time of the valid interval for any offered field.
- logical :: ave_enabled = .false. !< .true. if averaging is enabled.
+ logical :: ave_enabled = .false. !< True if averaging is enabled.
!>@{ The following are 3D and 2D axis groups defined for output. The names indicate
- !! the horizontal locations (B, T, Cu, or Cv), vertical locations (L, i, or 1) and
- !! thickness categories (c, c0, or 1).
- type(axesType) :: axesBL, axesTL, axesCuL, axesCvL
- type(axesType) :: axesBi, axesTi, axesCui, axesCvi
- type(axesType) :: axesBc, axesTc, axesCuc, axesCvc
- type(axesType) :: axesBc0, axesTc0, axesCuc0, axesCvc0
- type(axesType) :: axesB1, axesT1, axesCu1, axesCv1
- !!@}
-
- ! Mask arrays for diagnostics
- real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points
- real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corners
- real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-faces
- real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-faces
- !> Computational domain mask arrays for diagnostics.
- real, dimension(:,:), pointer :: mask2dT_comp => null()
-
+ !! the horizontal locations (B, T, Cu, or Cv) and vertical locations (here just 1).
+ type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1
+ !>@}
+ type(axes_grp) :: axesNull !< An axis group for scalars
+
+ ! Mask arrays for 2D diagnostics
+ real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points [nondim]
+ real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points [nondim]
+ real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points [nondim]
+ real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points [nondim]
+ real, dimension(:,:), pointer :: mask2dT_comp => null() !< 2D cell-center mask on the computational domain [nondim]
+
+! Space for diagnostics is dynamically allocated as it is needed.
+! The chunk size is how much the array should grow on each new allocation.
#define DIAG_ALLOC_CHUNK_SIZE 15
- type(diag_type), dimension(:), allocatable :: diags !< The array of diagnostics
+ type(diag_type), dimension(:), allocatable :: diags !< The list of diagnostics
integer :: next_free_diag_id !< The next unused diagnostic ID
- !> default missing value to be sent to ALL diagnostics registerations [various]
+
+ !> default missing value to be sent to ALL diagnostics registrations [various]
real :: missing_value = -1.0e34
+ type(ocean_grid_type), pointer :: G => null() !< The ocean grid type
type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type
+ !> Number of checksum-only diagnostics
+ integer :: num_chksum_diags
+
end type diag_ctrl
+!>@{ CPU clocks
+integer :: id_clock_diag_mediator
+!>@}
+
contains
!> Set up the grid and axis information for use by the ice shelf model.
-subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name)
- type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type
- type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters
+subroutine set_IS_axes_info(G, diag_cs, axes_set_name)
+ type(ocean_grid_type), intent(in) :: G !< The horizontal grid type
type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output
character(len=*), optional, intent(in) :: axes_set_name !< A name to use for this set of axes.
!! The default is "ice".
! This subroutine sets up the grid and axis information for use by the ice shelf model.
! Local variables
- integer :: id_xq, id_yq, id_xh, id_yh
- logical :: Cartesian_grid
- character(len=80) :: grid_config, units_temp, set_name
- ! This include declares and sets the variable "version".
-# include "version_variable.h"
- character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name.
+ integer :: id_xq, id_yq, id_xh, id_yh, id_null
+ integer :: i, j
+ character(len=80) :: set_name
+ real, allocatable, dimension(:) :: IaxB, iax ! Index-based integer and half-integer i-axis labels [nondim]
+ real, allocatable, dimension(:) :: JaxB, jax ! Index-based integer and half-integer j-axis labels [nondim]
set_name = "ice_shelf" ; if (present(axes_set_name)) set_name = trim(axes_set_name)
- ! Read all relevant parameters and write them to the model log.
- call log_version(param_file, mdl, version)
- call get_param(param_file, mdl, "GRID_CONFIG", grid_config, &
- "The method for defining the horizontal grid. Valid "//&
- "entries include:\n"//&
- "\t file - read the grid from GRID_FILE \n"//&
- "\t mosaic - read the grid from a mosaic grid file \n"//&
- "\t cartesian - a Cartesian grid \n"//&
- "\t spherical - a spherical grid \n"//&
- "\t mercator - a Mercator grid", fail_if_missing=.true.)
-
- G%x_axis_units = "degrees_E" ; G%y_axis_units = "degrees_N"
- G%x_ax_unit_short = "degrees_E" ; G%y_ax_unit_short = "degrees_N"
- G%grid_unit_to_L = 0.0
-
- if (index(lowercase(trim(grid_config)),"cartesian") > 0) then
- ! This is a cartesian grid, and may have different axis units.
- Cartesian_grid = .true.
- call get_param(param_file, mdl, "AXIS_UNITS", units_temp, &
- "The units for the x- and y- axis labels. AXIS_UNITS "//&
- "should be defined as 'k' for km, 'm' for m, or 'd' "//&
- "for degrees of latitude and longitude (the default). "//&
- "Except on a Cartesian grid, only degrees are currently "//&
- "implemented.", default='degrees')
- if (units_temp(1:1) == 'k') then
- G%x_axis_units = "kilometers" ; G%y_axis_units = "kilometers"
- G%x_ax_unit_short = "km" ; G%y_ax_unit_short = "km"
- G%grid_unit_to_L = 1000.0*diag_cs%US%m_to_L
- elseif (units_temp(1:1) == 'm') then
- G%x_axis_units = "meters" ; G%y_axis_units = "meters"
- G%x_ax_unit_short = "m" ; G%y_ax_unit_short = "m"
- G%grid_unit_to_L = diag_cs%US%m_to_L
- endif
- call log_param(param_file, mdl, "explicit AXIS_UNITS", G%x_axis_units)
- else
- Cartesian_grid = .false.
+ if (diag_cs%index_space_axes) then
+ allocate(IaxB(G%IsgB:G%IegB))
+ do I=G%IsgB,G%IegB
+ Iaxb(I) = real(I)
+ enddo
+ allocate(iax(G%isg:G%ieg))
+ do i=G%isg,G%ieg
+ iax(i) = real(i)-0.5
+ enddo
+ allocate(JaxB(G%JsgB:G%JegB))
+ do J=G%JsgB,G%JegB
+ JaxB(J) = real(J)
+ enddo
+ allocate(jax(G%jsg:G%jeg))
+ do j=G%jsg,G%jeg
+ jax(j) = real(j)-0.5
+ enddo
endif
- if (G%symmetric) then
- id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', &
+ ! Horizontal axes for the native grids.
+ if (diag_cs%index_space_axes) then
+ if (G%symmetric) then
+ id_xq = MOM_diag_axis_init('Iq', IaxB(G%IsgB:G%IegB), 'none', 'x', &
+ 'Boundary (q) point grid-space longitude', G%Domain, position=EAST, set_name=set_name)
+ id_yq = MOM_diag_axis_init('Jq', JaxB(G%JsgB:G%JegB), 'none', 'y', &
+ 'Boundary (q) point grid-space latitude', G%Domain, position=NORTH, set_name=set_name)
+ else
+ id_xq = MOM_diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', &
+ 'Boundary (q) point grid-space longitude', G%Domain, position=EAST, set_name=set_name)
+ id_yq = MOM_diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', &
+ 'Boundary (q) point grid-space latitude', G%Domain, position=NORTH, set_name=set_name)
+ endif
+
+ id_xh = MOM_diag_axis_init('ih', iax, 'none', 'x', &
+ 'Tracer (h) point grid-space longitude', G%Domain, set_name=set_name)
+ id_yh = MOM_diag_axis_init('jh', jax, 'none', 'y', &
+ 'Tracer (h) point grid-space latitude', G%Domain, set_name=set_name)
+ else
+ if (G%symmetric) then
+ id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', &
'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name)
- id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', &
+ id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', &
'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name)
- else
- id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', &
+ else
+ id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', &
'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name)
- id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', &
+ id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', &
'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name)
+ endif
+ id_xh = MOM_diag_axis_init('xT', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', &
+ 'Tracer point nominal longitude', G%Domain, set_name=set_name)
+ id_yh = MOM_diag_axis_init('yT', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', &
+ 'Tracer point nominal latitude', G%Domain, set_name=set_name)
endif
- id_xh = MOM_diag_axis_init('xT', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', &
- 'T point nominal longitude', G%Domain, set_name=set_name)
- id_yh = MOM_diag_axis_init('yT', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', &
- 'T point nominal latitude', G%Domain, set_name=set_name)
- ! Axis groupings for 2-D arrays.
- call defineAxes(diag_cs, [id_xh, id_yh], diag_cs%axesT1)
- call defineAxes(diag_cs, [id_xq, id_yq], diag_cs%axesB1)
- call defineAxes(diag_cs, [id_xq, id_yh], diag_cs%axesCu1)
- call defineAxes(diag_cs, [id_xh, id_yq], diag_cs%axesCv1)
+ ! Axis groupings for 2-D arrays
+ call define_axes_group(diag_cs, (/id_xh, id_yh/), diag_cs%axesT1, &
+ x_cell_method='mean', y_cell_method='mean', is_h_point=.true.)
+ call define_axes_group(diag_cs, (/id_xq, id_yq/), diag_cs%axesB1, &
+ x_cell_method='point', y_cell_method='point', is_q_point=.true.)
+ call define_axes_group(diag_cs, (/id_xq, id_yh/), diag_cs%axesCu1, &
+ x_cell_method='point', y_cell_method='mean', is_u_point=.true.)
+ call define_axes_group(diag_cs, (/id_xh, id_yq/), diag_cs%axesCv1, &
+ x_cell_method='mean', y_cell_method='point', is_v_point=.true.)
+
+ ! Axis group for special null axis for scalars from diag manager.
+ id_null = MOM_diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none', null_axis=.true.)
+ call define_axes_group(diag_cs, (/ id_null /), diag_cs%axesNull)
+
+ if (diag_cs%index_space_axes) then
+ deallocate(IaxB, iax, JaxB, jax)
+ endif
end subroutine set_IS_axes_info
-!> Define an a group of axes from a list of handles
-subroutine defineAxes(diag_cs, handles, axes)
- ! Defines "axes" from list of handle and associates mask
- type(diag_ctrl), target, intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output
- integer, dimension(:), intent(in) :: handles !< A set of axis handles that define the axis group
- type(axesType), intent(out) :: axes !< A group of axes that is set up here
+!> Attaches the id of cell areas to axes groups for use with cell_measures
+subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q)
+ type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
+ integer, optional, intent(in) :: id_area_t !< Diag_mediator id for area of h-cells
+ integer, optional, intent(in) :: id_area_q !< Diag_mediator id for area of q-cells
+ ! Local variables
+ integer :: fms_id, i
+ if (present(id_area_t)) then
+ fms_id = diag_cs%diags(id_area_t)%fms_diag_id
+ diag_cs%axesT1%id_area = fms_id
+ endif
+ if (present(id_area_q)) then
+ fms_id = diag_cs%diags(id_area_q)%fms_diag_id
+ diag_cs%axesB1%id_area = fms_id
+ endif
+end subroutine diag_register_area_ids
+
+!> Define a group of "axes" from a list of handles and associate a mask with it
+subroutine define_axes_group(diag_cs, handles, axes, &
+ x_cell_method, y_cell_method, &
+ is_h_point, is_q_point, is_u_point, is_v_point)
+ type(diag_ctrl), target, intent(in) :: diag_cs !< Structure used to regulate diagnostic output
+ integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles that define the axis group
+ type(axes_grp), intent(out) :: axes !< The group of axes that is set up here
+ character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the
+ !! "cell_methods" attribute in CF convention
+ character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the
+ !! "cell_methods" attribute in CF convention
+ logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point
+ !! located fields
+ logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point
+ !! located fields
+ logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for
+ !! u-point located fields
+ logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for
+ !! v-point located fields
! Local variables
integer :: n
+
n = size(handles)
- if (n<1 .or. n>3) call MOM_error(FATAL,"defineAxes: wrong size for list of handles!")
+ if (n<1 .or. n>2) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!")
allocate( axes%handles(n) )
- axes%id = i2s(handles, n) ! Identifying string
+ axes%id = ints_to_string(handles, max(n,2)) ! Identifying string
axes%rank = n
axes%handles(:) = handles(:)
- axes%diag_cs => diag_cs ! A (circular) link back to the MOM_IS_diag_ctrl structure
-end subroutine defineAxes
+ axes%diag_cs => diag_cs ! A (circular) link back to the diag_ctrl structure
+
+ if ((axes%rank<2) .and. (present(x_cell_method) .or. present(x_cell_method))) &
+ call MOM_error(FATAL, 'define_axes_group: Can not set x_cell_method or y_cell_method for rank<2.')
+ axes%x_cell_method = '' ; if (present(x_cell_method)) axes%x_cell_method = trim(x_cell_method)
+ axes%y_cell_method = '' ; if (present(y_cell_method)) axes%y_cell_method = trim(y_cell_method)
+
+ if (present(is_h_point)) axes%is_h_point = is_h_point
+ if (present(is_q_point)) axes%is_q_point = is_q_point
+ if (present(is_u_point)) axes%is_u_point = is_u_point
+ if (present(is_v_point)) axes%is_v_point = is_v_point
+
+ ! Setup masks for this axes group
+ axes%mask2d => null()
+ if (axes%rank==2) then
+ if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT
+ if (axes%is_h_point) axes%mask2d_comp => diag_cs%mask2dT_comp
+ if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu
+ if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv
+ if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu
+ endif
-!> Set up the current grid for the diag mediator
+end subroutine define_axes_group
+
+!> Set up the array extents for doing diagnostics
subroutine set_IS_diag_mediator_grid(G, diag_cs)
type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type
- type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output
+ type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1)
diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1)
- diag_cs%isd = G%isd ; diag_cs%ied = G%ied ; diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed
+ diag_cs%isd = G%isd ; diag_cs%ied = G%ied
+ diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed
+
end subroutine set_IS_diag_mediator_grid
-!> Offer a 2d diagnostic field for output or averaging
-subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask)
- integer, intent(in) :: diag_field_id !< the id for an output variable returned by a
- !! previous call to register_diag_field.
- real, target, intent(in) :: field(:,:) !< The 2-d array being offered for output or averaging.
- type(diag_ctrl), target, &
- intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output
+!> Make a real ice shelf scalar diagnostic available for averaging or output
+subroutine post_IS_data_0d(diag_field_id, field, diag_cs, is_static)
+ integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
+ !! previous call to register_MOM_IS_diag_field.
+ real, intent(in) :: field !< real value being offered for output or averaging
+ !! in internally scaled arbitrary units [A ~> a]
+ type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
- logical, optional, intent(in) :: mask(:,:) !< If present, use this logical array as the data mask.
! Local variables
- real, dimension(:,:), pointer :: locfield
+ real :: locfield ! The field being offered in arbitrary unscaled units [a]
logical :: used, is_stat
- logical :: i_data, j_data
- integer :: isv, iev, jsv, jev, i, j
- integer :: fms_diag_id
- type(diag_type), pointer :: diag => NULL()
+ type(diag_type), pointer :: diag => null()
- locfield => NULL()
+ integer :: time_days
+ integer :: time_seconds
+ character(len=300) :: debug_mesg
+
+ if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator)
is_stat = .false. ; if (present(is_static)) is_stat = is_static
- ! Get a pointer to the diag type for this id, and the FMS-level diag id.
+ ! Iterate over list of diag 'variants', e.g. CMOR aliases, call send_data
+ ! for each one.
+ call assert(diag_field_id < diag_cs%next_free_diag_id, &
+ 'post_IS_data_0d: Unregistered diagnostic id')
+ diag => diag_cs%diags(diag_field_id)
+
+ do while (associated(diag))
+ locfield = field
+ if (diag%conversion_factor /= 0.) &
+ locfield = locfield * diag%conversion_factor
+
+ if (diag_cs%diag_as_chksum) then
+ ! Append timestep to mesg
+ call get_time(diag_cs%time_end, time_seconds, days=time_days)
+ write(debug_mesg, '(a, 1x, i0, 1x, i0)') &
+ trim(diag%debug_str), time_days, time_seconds
+
+ call chksum0(locfield, debug_mesg, logunit=diag_cs%chksum_iounit)
+ elseif (is_stat) then
+ used = send_data_infra(diag%fms_diag_id, locfield)
+ elseif (diag_cs%ave_enabled) then
+ used = send_data_infra(diag%fms_diag_id, locfield, diag_cs%time_end)
+ endif
+
+ diag => diag%next
+ enddo
+
+ if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator)
+end subroutine post_IS_data_0d
+
+
+!> Make a real 2-d array diagnostic available for averaging or output
+subroutine post_IS_data_2d(diag_field_id, field, diag_cs, is_static, mask)
+ integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
+ !! previous call to register_MOM_IS_diag_field.
+ real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging
+ !! in internally scaled arbitrary units [A ~> a]
+ type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
+ logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
+ real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim]
+
+ ! Local variables
+ type(diag_type), pointer :: diag => NULL()
+
+ if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator)
+
+ ! Iterate over list of diag 'variants' (e.g. CMOR aliases) and post each.
call assert(diag_field_id < diag_cs%next_free_diag_id, &
- 'post_IS_data: Unregistered diagnostic id')
+ 'post_IS_data_2d: Unregistered diagnostic id')
diag => diag_cs%diags(diag_field_id)
- fms_diag_id = diag%fms_diag_id
+ do while (associated(diag))
+ call post_data_2d_low(diag, field, diag_cs, is_static, mask)
+ diag => diag%next
+ enddo
+
+ if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator)
+end subroutine post_IS_data_2d
+
+!> Make a real 2-d array diagnostic available for averaging or output
+!! using a diag_type instead of an integer id.
+subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask)
+ type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post
+ real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging
+ !! in internally scaled arbitrary units [A ~> a]
+ type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
+ logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
+ real, optional, target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim]
+
+ ! Local variables
+ real, dimension(:,:), pointer :: locfield ! The field being offered in arbitrary unscaled units [a]
+ real, dimension(:,:), pointer :: locmask ! A pointer to the data mask to use [nondim]
+ logical :: used ! The return value of send_data is not used for anything.
+ logical :: is_stat
+ logical :: i_data, j_data ! True if the field is on the data domain in the i or j directions.
+ integer :: cszi, cszj, dszi, dszj
+ integer :: isv, iev, jsv, jev, i, j
+ integer :: time_days, time_seconds
+ character(len=300) :: mesg
+ character(len=300) :: debug_mesg
+
+ locfield => NULL()
+ locmask => NULL()
+ is_stat = .false. ; if (present(is_static)) is_stat = is_static
! Determine the proper array indices, noting that because of the (:,:)
! declaration of field, symmetric arrays are using a SW-grid indexing,
@@ -245,27 +444,35 @@ subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask)
! the output data size and assumes that halos are symmetric.
isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je
- if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then
+ cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1
+ cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1
+ if ( size(field,1) == dszi ) then
isv = diag_cs%is ; iev = diag_cs%ie ; i_data = .true. ! Data domain
- elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then
+ elseif ( size(field,1) == dszi + 1 ) then
isv = diag_cs%is ; iev = diag_cs%ie+1 ; i_data = .true. ! Symmetric data domain
- elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then
- isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ; i_data = .false. ! Computational domain
- elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then
- isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ; i_data = .false. ! Symmetric computational domain
+ elseif ( size(field,1) == cszi ) then
+ isv = 1 ; iev = cszi ; i_data = .false. ! Computational domain
+ elseif ( size(field,1) == cszi + 1 ) then
+ isv = 1 ; iev = cszi+1 ; i_data = .false. ! Symmetric computational domain
else
- call MOM_error(FATAL,"post_MOM_IS_data_2d: peculiar size in i-direction of "//trim(diag%name))
+ write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//&
+ "does not match one of ", cszi, cszi+1, dszi, dszi+1
+ call MOM_error(FATAL,"post_IS_data_2d_low: "//trim(diag%debug_str)//trim(mesg))
endif
- if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then
+
+ if ( size(field,2) == dszj ) then
jsv = diag_cs%js ; jev = diag_cs%je ; j_data = .true. ! Data domain
- elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then
+ elseif ( size(field,2) == dszj + 1 ) then
jsv = diag_cs%js ; jev = diag_cs%je+1 ; j_data = .true. ! Symmetric data domain
- elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then
- jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ; j_data = .false. ! Computational domain
- elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then
- jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ; j_data = .false. ! Symmetric computational domain
+ elseif ( size(field,2) == cszj ) then
+ jsv = 1 ; jev = cszj ; j_data = .false. ! Computational domain
+ ! This was: elseif ( size(field,1) == cszj + 1 ) then
+ elseif ( size(field,2) == cszj + 1 ) then
+ jsv = 1 ; jev = cszj+1 ; j_data = .false. ! Symmetric computational domain
else
- call MOM_error(FATAL,"post_MOM_IS_data_2d: peculiar size in j-direction "//trim(diag%name))
+ write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//&
+ "does not match one of ", cszj, cszj+1, dszj, dszj+1
+ call MOM_error(FATAL,"post_IS_data_2d_low: "//trim(diag%debug_str)//trim(mesg))
endif
if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then
@@ -285,106 +492,76 @@ subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask)
! Handle cases where the data and computational domain are the same size.
if (diag_cs%ied-diag_cs%isd == diag_cs%ie-diag_cs%is) i_data = j_data
if (diag_cs%jed-diag_cs%jsd == diag_cs%je-diag_cs%js) j_data = i_data
+ if ( i_data .NEQV. j_data ) then
+ call MOM_error(FATAL, "post_IS_data_2d: post_IS_data called for "//&
+ trim(diag%debug_str)//" with mixed computational and data domain array sizes.")
+ endif
if (present(mask)) then
- if ((size(field,1) /= size(mask,1)) .or. &
- (size(field,2) /= size(mask,2))) then
- call MOM_error(FATAL, "post_MOM_IS_data_2d: post_MOM_IS_data called with a mask "//&
- "that does not match the size of field "//trim(diag%name))
+ locmask => mask
+ elseif (.not.is_stat) then ! Static fields do not have assigned axes.
+ if (i_data .and. associated(diag%axes%mask2d)) then
+ locmask => diag%axes%mask2d
+ elseif ((.not.i_data) .and. associated(diag%axes%mask2d_comp)) then
+ locmask => diag%axes%mask2d_comp
endif
- elseif ( i_data .NEQV. j_data ) then
- call MOM_error(FATAL, "post_MOM_IS_data_2d: post_MOM_IS_data called for "//&
- trim(diag%name)//" with mixed computational and data domain array sizes.")
- endif
-
- if (is_stat) then
- if (present(mask)) then
- used = send_data_infra(fms_diag_id, locfield, &
- is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, mask=mask)
- elseif(i_data .and. associated(diag%mask2d)) then
-! used = send_data(fms_diag_id, locfield, &
-! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%mask2d)
- used = send_data_infra(fms_diag_id, locfield, &
- is_in=isv, ie_in=iev, js_in=jsv, je_in=jev)
- elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then
-! used = send_data(fms_diag_id, locfield, &
-! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%mask2d_comp)
- used = send_data_infra(fms_diag_id, locfield, &
- is_in=isv, ie_in=iev, js_in=jsv, je_in=jev)
+ endif
+ if (associated(locmask)) call assert(size(locfield) == size(locmask), &
+ 'post_data_2d_low: mask size mismatch: '//trim(diag%debug_str))
+
+ if (diag_cs%diag_as_chksum) then
+ ! Append timestep to mesg
+ call get_time(diag_cs%time_end, time_seconds, days=time_days)
+ write(debug_mesg, '(a, 1x, i0, 1x, i0)') &
+ trim(diag%debug_str), time_days, time_seconds
+
+ if (diag%axes%is_h_point) then
+ call hchksum(locfield, debug_mesg, diag_cs%G%HI, &
+ logunit=diag_cs%chksum_iounit)
+ elseif (diag%axes%is_u_point) then
+ call uchksum(locfield, debug_mesg, diag_cs%G%HI, &
+ logunit=diag_cs%chksum_iounit)
+ elseif (diag%axes%is_v_point) then
+ call vchksum(locfield, debug_mesg, diag_cs%G%HI, &
+ logunit=diag_cs%chksum_iounit)
+ elseif (diag%axes%is_q_point) then
+ call Bchksum(locfield, debug_mesg, diag_cs%G%HI, &
+ logunit=diag_cs%chksum_iounit)
else
- used = send_data_infra(fms_diag_id, locfield, &
- is_in=isv, ie_in=iev, js_in=jsv, je_in=jev)
+ call MOM_error(FATAL, "post_data_2d_low: unknown axis type.")
endif
- elseif (diag_cs%ave_enabled) then
- if (present(mask)) then
- used = send_data_infra(fms_diag_id, locfield, &
- is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
- time=diag_cs%time_end, weight=diag_cs%time_int, mask=mask)
-! used = send_data(fms_diag_id, locfield, &
-! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
-! time=diag_cs%time_end, weight=diag_cs%time_int)
- elseif(i_data .and. associated(diag%mask2d)) then
-! used = send_data(fms_diag_id, locfield, &
-! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
-! time=diag_cs%time_end, weight=diag_cs%time_int, rmask=diag%mask2d)
- used = send_data_infra(fms_diag_id, locfield, &
- is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
- time=diag_cs%time_end, weight=diag_cs%time_int)
- elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then
-! used = send_data(fms_diag_id, locfield, &
-! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
-! time=diag_cs%time_end, weight=diag_cs%time_int, rmask=diag%mask2d_comp)
- used = send_data_infra(fms_diag_id, locfield, &
- is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
- time=diag_cs%time_end, weight=diag_cs%time_int)
- else
- used = send_data_infra(fms_diag_id, locfield, &
- is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
- time=diag_cs%time_end, weight=diag_cs%time_int)
+ else
+ if (is_stat) then
+ if (associated(locmask)) then
+ used = send_data_infra(diag%fms_diag_id, locfield, &
+ is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask)
+ else
+ used = send_data_infra(diag%fms_diag_id, locfield, &
+ is_in=isv, ie_in=iev, js_in=jsv, je_in=jev)
+ endif
+ elseif (diag_cs%ave_enabled) then
+ if (associated(locmask)) then
+ used = send_data_infra(diag%fms_diag_id, locfield, &
+ is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
+ time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask)
+ else
+ used = send_data_infra(diag%fms_diag_id, locfield, &
+ is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, &
+ time=diag_cs%time_end, weight=diag_cs%time_int)
+ endif
endif
endif
- if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) ) deallocate( locfield )
-
-end subroutine post_IS_data
-
-!> Make a real ice shelf scalar diagnostic available for averaging or output
-subroutine post_IS_data_0d(diag_field_id, field, diag_cs, is_static)
- integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
- !! previous call to register_diag_field.
- real, intent(in) :: field !< real value being offered for output or averaging
- !! in internally scaled arbitrary units [A ~> a]
- type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
- logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
- ! Local variables
- real :: locfield ! The field being offered in arbitrary unscaled units [a]
- logical :: used, is_stat
- type(diag_type), pointer :: diag => null()
-
- is_stat = .false. ; if (present(is_static)) is_stat = is_static
-
- call assert(diag_field_id < diag_cs%next_free_diag_id, &
- 'post_data_0d: Unregistered diagnostic id')
- diag => diag_cs%diags(diag_field_id)
-
- locfield = field
- if (diag%conversion_factor /= 0.) &
- locfield = locfield * diag%conversion_factor
-
- if (is_stat) then
- used = send_data_infra(diag%fms_diag_id, locfield)
- elseif (diag_cs%ave_enabled) then
- used = send_data_infra(diag%fms_diag_id, locfield, diag_cs%time_end)
- endif
-end subroutine post_IS_data_0d
+ if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield )
+end subroutine post_data_2d_low
!> Enable the accumulation of time averages over the specified time interval.
subroutine enable_averaging(time_int_in, time_end_in, diag_cs)
- real, intent(in) :: time_int_in !< The time interval over which any values
- !! that are offered are valid [s].
- type(time_type), intent(in) :: time_end_in !< The end time of the valid interval.
- type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output
+ real, intent(in) :: time_int_in !< The time interval [s] over which any
+ !! values that are offered are valid.
+ type(time_type), intent(in) :: time_end_in !< The end time of the valid interval
+ type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
! This subroutine enables the accumulation of time averages over the specified time interval.
! if (num_file==0) return
@@ -393,15 +570,6 @@ subroutine enable_averaging(time_int_in, time_end_in, diag_cs)
diag_cs%ave_enabled = .true.
end subroutine enable_averaging
-! Put a block on averaging any offered fields.
-subroutine disable_averaging(diag_cs)
- type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output
-
- diag_cs%time_int = 0.0
- diag_cs%ave_enabled = .false.
-
-end subroutine disable_averaging
-
!> Enable the accumulation of time averages over the specified time interval in time units.
subroutine enable_averages(time_int, time_end, diag_CS, T_to_s)
real, intent(in) :: time_int !< The time interval over which any values
@@ -422,11 +590,19 @@ subroutine enable_averages(time_int, time_end, diag_CS, T_to_s)
diag_cs%ave_enabled = .true.
end subroutine enable_averages
+!> Call this subroutine to avoid averaging any offered fields.
+subroutine disable_averaging(diag_cs)
+ type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
+
+ diag_cs%time_int = 0.0
+ diag_cs%ave_enabled = .false.
+end subroutine disable_averaging
+
!> Indicate whether averaging diagnostics is currently enabled
logical function query_averaging_enabled(diag_cs, time_int, time_end)
- type(diag_ctrl), intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output
- real, optional, intent(out) :: time_int !< The current setting of diag_cs%time_int [s].
- type(time_type), optional, intent(out) :: time_end !< The current setting of diag_cs%time_end.
+ type(diag_ctrl), intent(in) :: diag_cs !< Structure used to regulate diagnostic output
+ real, optional, intent(out) :: time_int !< Current setting of diag_cs%time_int [s]
+ type(time_type), optional, intent(out) :: time_end !< Current setting of diag_cs%time_end
if (present(time_int)) time_int = diag_cs%time_int
if (present(time_end)) time_end = diag_cs%time_end
@@ -440,26 +616,30 @@ subroutine MOM_IS_diag_mediator_infrastructure_init(err_msg)
call MOM_diag_manager_init(err_msg=err_msg)
end subroutine MOM_IS_diag_mediator_infrastructure_init
-!> Return the currently specified valid end time for diagnostics
+!> This function returns the valid end time for use with diagnostics that are
+!! handled outside of the MOM6 diagnostics infrastructure.
function get_diag_time_end(diag_cs)
- type(diag_ctrl), intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output
+ type(diag_ctrl), intent(in) :: diag_cs !< Structure used to regulate diagnostic output
type(time_type) :: get_diag_time_end
-
-! This function returns the valid end time for diagnostics that are handled
-! outside of the MOM6 infrastructure, such as via the generic tracer code.
+ ! This function returns the valid end time for diagnostics that are handled
+ ! outside of the MOM6 infrastructure, such as via the generic tracer code.
get_diag_time_end = diag_cs%time_end
end function get_diag_time_end
-!> Returns the "MOM_IS_diag_mediator" handle for a group of diagnostics derived from one field.
-function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, &
+!> Returns the "diag_mediator" handle for a group (native, CMOR, ...) of diagnostics
+!! derived from one field.
+function register_MOM_IS_diag_field(module_name, field_name, axes_in, init_time, &
long_name, units, missing_value, range, mask_variant, standard_name, &
- verbose, do_not_log, err_msg, interp_method, tile_count, conversion) result (register_diag_field)
+ verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, &
+ cmor_long_name, cmor_units, cmor_standard_name, cell_methods, &
+ x_cell_method, y_cell_method, conversion) result (register_diag_field)
integer :: register_diag_field !< The returned diagnostic handle
- character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model"
- character(len=*), intent(in) :: field_name !< Name of the diagnostic field
- type(axesType), intent(in) :: axes !< The axis group for this field
- type(time_type), intent(in) :: init_time !< Time at which a field is first available?
+ character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model"
+ character(len=*), intent(in) :: field_name !< Name of the diagnostic field
+ type(axes_grp), target, intent(in) :: axes_in !< Container with up to 3 integer handles that
+ !! indicates axes for this field
+ type(time_type), intent(in) :: init_time !< Time at which a field is first available?
character(len=*), optional, intent(in) :: long_name !< Long name of a field.
character(len=*), optional, intent(in) :: units !< Units of a field.
character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
@@ -475,188 +655,700 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, &
!! placed (not used in MOM?)
character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not
!! be interpolated as a scalar
- integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?)
- real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file,
+ integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?)
+ character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
+ character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
+ character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
+ character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
+ character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to
+ !! have no attribute. If present, this overrides the
+ !! default constructed from the default for
+ !! each individual axis direction.
+ character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
+ !! Use '' have no method.
+ character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
+ !! Use '' have no method.
+ real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files,
!! often including factors to undo internal scaling and
!! in units of [a A-1 ~> 1]
+
! Local variables
- character(len=240) :: mesg
real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a]
- integer :: primary_id, fms_id
- type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used
- ! to regulate diagnostic output
- type(diag_type), pointer :: diag => NULL()
+ type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used to regulate diagnostic output
+ type(axes_grp), pointer :: axes
+ integer :: dm_id
+ character(len=256) :: msg
+ character(len=256) :: cm_string ! A string describing the cell methods returned from attach_cell_methods.
+ character(len=256) :: new_module_name
+ character(len=480) :: module_list, var_list
+ character(len=24) :: dimensions
+ integer :: num_modnm, num_varnm
+ logical :: active
+
+ diag_cs => axes_in%diag_cs
+
+ ! Check if the axes match a standard grid axis.
+ ! If not, allocate the new axis and copy the contents.
+ if (axes_in%id == diag_cs%axesT1%id) then
+ axes => diag_cs%axesT1
+ elseif (axes_in%id == diag_cs%axesB1%id) then
+ axes => diag_cs%axesB1
+ elseif (axes_in%id == diag_cs%axesCu1%id) then
+ axes => diag_cs%axesCu1
+ elseif (axes_in%id == diag_cs%axesCv1%id) then
+ axes => diag_cs%axesCv1
+ else
+ allocate(axes)
+ axes = axes_in
+ endif
MOM_missing_value = axes%diag_cs%missing_value
if (present(missing_value)) MOM_missing_value = missing_value
diag_cs => axes%diag_cs
- primary_id = -1
-
- fms_id = register_diag_field_infra(module_name, field_name, axes%handles, &
- init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, &
- range=range, mask_variant=mask_variant, standard_name=standard_name, &
- verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
- interp_method=interp_method, tile_count=tile_count)
- if (fms_id > 0) then
- primary_id = get_new_diag_id(diag_cs)
- diag => diag_cs%diags(primary_id)
- diag%fms_diag_id = fms_id
- if (len(field_name) > len(diag%name)) then
- diag%name = field_name(1:len(diag%name))
- else ; diag%name = field_name ; endif
+ dm_id = -1
+
+ module_list = "{"//trim(module_name)
+ num_modnm = 1
+
+ ! Register the native diagnostic
+ active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, &
+ init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, &
+ range=range, mask_variant=mask_variant, standard_name=standard_name, &
+ verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
+ interp_method=interp_method, tile_count=tile_count, &
+ cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
+ cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
+ cell_methods=cell_methods, x_cell_method=x_cell_method, y_cell_method=y_cell_method, &
+ conversion=conversion)
+ num_varnm = 1 ; var_list = "{"//trim(field_name)
+ if (present(cmor_field_name)) then
+ num_varnm = num_varnm + 1
+ var_list = trim(var_list)//","//trim(cmor_field_name)
+ endif
+ var_list = trim(var_list)//"}"
+
+ dimensions = ""
+ if (axes_in%is_h_point) dimensions = trim(dimensions)//" xh, yh,"
+ if (axes_in%is_q_point) dimensions = trim(dimensions)//" xq, yq,"
+ if (axes_in%is_u_point) dimensions = trim(dimensions)//" xq, yh,"
+ if (axes_in%is_v_point) dimensions = trim(dimensions)//" xh, yq,"
+ if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions)
+
+ if (is_root_pe() .and. (diag_CS%available_diag_doc_unit > 0)) then
+ msg = ''
+ if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"'
+ call attach_cell_methods(-1, axes, cm_string, cell_methods, x_cell_method, y_cell_method)
+ module_list = trim(module_list)//"}"
+ if (num_modnm <= 1) module_list = module_name
+ if (num_varnm <= 1) var_list = ''
+
+ call log_available_diag(dm_id>0, module_list, field_name, cm_string, msg, diag_CS, &
+ long_name, units, standard_name, variants=var_list, dimensions=dimensions)
+ endif
- if (present(conversion)) diag%conversion_factor = conversion
+ register_diag_field = dm_id
+
+end function register_MOM_IS_diag_field
+
+!> Returns True if either the native or CMOR version of the diagnostic were registered. Updates 'dm_id'
+!! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field.
+logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, &
+ long_name, units, missing_value, range, mask_variant, standard_name, &
+ verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, &
+ cmor_long_name, cmor_units, cmor_standard_name, cell_methods, &
+ x_cell_method, y_cell_method, conversion)
+ integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group
+ character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" or "ice_model_fast"
+ character(len=*), intent(in) :: field_name !< Name of the diagnostic field
+ type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates axes
+ !! for this field
+ type(time_type), intent(in) :: init_time !< Time at which a field is first available?
+ character(len=*), optional, intent(in) :: long_name !< Long name of a field.
+ character(len=*), optional, intent(in) :: units !< Units of a field.
+ character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
+ real, optional, intent(in) :: missing_value !< A value that indicates missing values in
+ !! output files, in unscaled arbitrary units [a]
+ real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
+ !! in arbitrary units [a]
+ logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided
+ !! with post_data calls (not used in MOM?)
+ logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?)
+ logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
+ character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
+ !! placed (not used in MOM?)
+ character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should
+ !! not be interpolated as a scalar
+ integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?)
+ character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
+ character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
+ character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
+ character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
+ character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute.
+ !! Use '' to have no attribute. If present, this
+ !! overrides the default constructed from the default
+ !! for each individual axis direction.
+ character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
+ !! Use '' have no method.
+ character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
+ !! Use '' have no method.
+ real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files,
+ !! often including factors to undo internal scaling and
+ !! in units of [a A-1 ~> 1]
+ ! Local variables
+ real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a]
+ type(diag_ctrl), pointer :: diag_cs => null()
+ type(diag_type), pointer :: this_diag => null()
+ integer :: fms_id
+ character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
+ character(len=256) :: cm_string ! A string describing the cell methods returned from attach_cell_methods.
+
+ MOM_missing_value = axes%diag_cs%missing_value
+ if (present(missing_value)) MOM_missing_value = missing_value
+
+ register_diag_field_expand_cmor = .false.
+ diag_cs => axes%diag_cs
+
+ ! Set up the 'primary' diagnostic, first get an underlying FMS id
+ fms_id = register_diag_field_expand_axes(module_name, field_name, axes, init_time, &
+ long_name=long_name, units=units, missing_value=MOM_missing_value, &
+ range=range, mask_variant=mask_variant, standard_name=standard_name, &
+ verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
+ interp_method=interp_method, tile_count=tile_count)
+ if (.not. diag_cs%diag_as_chksum) &
+ call attach_cell_methods(fms_id, axes, cm_string, cell_methods, x_cell_method, y_cell_method)
+
+ this_diag => null()
+ if (fms_id /= DIAG_FIELD_NOT_FOUND) then
+ call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name)
+ if (present(conversion)) this_diag%conversion_factor = conversion
+ register_diag_field_expand_cmor = .true.
+ endif
+
+ ! For the CMOR variation of the above diagnostic
+ if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then
+ ! Fallback values for strings set to "NULL"
+ posted_cmor_units = "not provided" !
+ posted_cmor_standard_name = "not provided" ! Values might be able to be replaced with a CS%missing field?
+ posted_cmor_long_name = "not provided" !
+
+ ! If attributes are present for MOM variable names, use them first for the register_MOM_IS_diag_field
+ ! call for CMOR verison of the variable
+ if (present(units)) posted_cmor_units = units
+ if (present(standard_name)) posted_cmor_standard_name = standard_name
+ if (present(long_name)) posted_cmor_long_name = long_name
+
+ ! If specified in the call to register_MOM_IS_diag_field, override attributes with the CMOR versions
+ if (present(cmor_units)) posted_cmor_units = cmor_units
+ if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
+ if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
+
+ fms_id = register_diag_field_expand_axes(module_name, cmor_field_name, axes, init_time, &
+ long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
+ missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, &
+ standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, &
+ err_msg=err_msg, interp_method=interp_method, tile_count=tile_count)
+ call attach_cell_methods(fms_id, axes, cm_string, cell_methods, x_cell_method, y_cell_method)
+
+ this_diag => null()
+ if (fms_id /= DIAG_FIELD_NOT_FOUND) then
+ call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name)
+ if (present(conversion)) this_diag%conversion_factor = conversion
+ register_diag_field_expand_cmor = .true.
+ endif
+ endif
+
+end function register_diag_field_expand_cmor
+
+!> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes
+!! (axes-group) into handles and conditionally adding an FMS area_id for cell_measures.
+integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, &
+ long_name, units, missing_value, range, mask_variant, standard_name, &
+ verbose, do_not_log, err_msg, interp_method, tile_count)
+ character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
+ !! or "ice_shelf_model"
+ character(len=*), intent(in) :: field_name !< Name of the diagnostic field
+ type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that indicates
+ !! axes for this field
+ type(time_type), intent(in) :: init_time !< Time at which a field is first available?
+ character(len=*), optional, intent(in) :: long_name !< Long name of a field.
+ character(len=*), optional, intent(in) :: units !< Units of a field.
+ character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
+ real, optional, intent(in) :: missing_value !< A value that indicates missing values in
+ !! output files, in unscaled arbitrary units [a]
+ real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
+ !! in arbitrary units [a]
+ logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided
+ !! with post_data calls (not used in MOM?)
+ logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?)
+ logical, optional, intent(in) :: do_not_log !< If true, do not log something
+ !! (not used in MOM?)
+ character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
+ !! placed (not used in MOM?)
+ character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should
+ !! not be interpolated as a scalar
+ integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?)
+ ! Local variables
+ integer :: fms_id, area_id
+
+ ! This gets the cell area associated with the grid location of this variable
+ area_id = axes%id_area
+
+ ! Get the FMS diagnostic id
+ if (axes%diag_cs%diag_as_chksum) then
+ fms_id = axes%diag_cs%num_chksum_diags + 1
+ axes%diag_cs%num_chksum_diags = fms_id
+ elseif (present(interp_method) .or. axes%is_h_point) then
+ ! If interp_method is provided we must use it
+ if (area_id>0) then
+ fms_id = register_diag_field_infra(module_name, field_name, axes%handles, &
+ init_time, long_name=long_name, units=units, missing_value=missing_value, &
+ range=range, mask_variant=mask_variant, standard_name=standard_name, &
+ verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
+ interp_method=interp_method, tile_count=tile_count, area=area_id)
+ else
+ fms_id = register_diag_field_infra(module_name, field_name, axes%handles, &
+ init_time, long_name=long_name, units=units, missing_value=missing_value, &
+ range=range, mask_variant=mask_variant, standard_name=standard_name, &
+ verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
+ interp_method=interp_method, tile_count=tile_count)
+ endif
+ else
+ ! If interp_method is not provided and the field is not at an h-point then interp_method='none'
+ if (area_id>0) then
+ fms_id = register_diag_field_infra(module_name, field_name, axes%handles, &
+ init_time, long_name=long_name, units=units, missing_value=missing_value, &
+ range=range, mask_variant=mask_variant, standard_name=standard_name, &
+ verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
+ interp_method='none', tile_count=tile_count, area=area_id)
+ else
+ fms_id = register_diag_field_infra(module_name, field_name, axes%handles, &
+ init_time, long_name=long_name, units=units, missing_value=missing_value, &
+ range=range, mask_variant=mask_variant, standard_name=standard_name, &
+ verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
+ interp_method='none', tile_count=tile_count)
+ endif
endif
- if (is_root_pe() .and. diag_CS%doc_unit > 0) then
- if (primary_id > 0) then
- mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]'
+ register_diag_field_expand_axes = fms_id
+
+end function register_diag_field_expand_axes
+
+!> Create a diagnostic type and attached to list
+subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name)
+ type(diag_ctrl), pointer :: diag_cs !< Diagnostics mediator control structure
+ integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group
+ integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic
+ type(diag_type), pointer :: this_diag !< This diagnostic
+ type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that
+ !! indicates axes for this field
+ character(len=*), intent(in) :: module_name !< Name of this module, usually
+ !! "ocean_model" or "ice_shelf_model"
+ character(len=*), intent(in) :: field_name !< Name of diagnostic
+
+ ! If the diagnostic is needed obtain a diag_mediator ID (if needed)
+ if (dm_id == -1) dm_id = get_new_diag_id(diag_cs)
+ ! Create a new diag_type to store links in
+ call alloc_diag_with_id(dm_id, diag_cs, this_diag)
+ call assert(associated(this_diag), 'add_diag_to_list: allocation failed for '//trim(field_name))
+ ! Record FMS id, masks and conversion factor, in diag_type
+ this_diag%fms_diag_id = fms_id
+ this_diag%debug_str = trim(module_name)//"-"//trim(field_name)
+ this_diag%axes => axes
+
+end subroutine add_diag_to_list
+
+
+!> Attaches "cell_methods" attribute to a variable based on defaults for axes_grp or optional arguments.
+subroutine attach_cell_methods(id, axes, ostring, cell_methods, x_cell_method, y_cell_method)
+ integer, intent(in) :: id !< Handle to diagnostic
+ type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates
+ !! axes for this field
+ character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file
+ character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute.
+ !! Use '' to have no attribute. If present, this
+ !! overrides the default constructed from the default
+ !! for each individual axis direction.
+ character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
+ !! Use '' have no method.
+ character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
+ !! Use '' have no method.
+ ! Local variables
+ character(len=9) :: axis_name
+ logical :: x_mean, y_mean, x_sum, y_sum
+
+ x_mean = .false.
+ y_mean = .false.
+ x_sum = .false.
+ y_sum = .false.
+
+ ostring = ''
+ if (present(cell_methods)) then
+ if (present(x_cell_method) .or. present(y_cell_method)) then
+ call MOM_error(FATAL, "attach_cell_methods: " // &
+ 'Individual direction cell method was specified along with a "cell_methods" string.')
+ endif
+ if (len(trim(cell_methods))>0) then
+ call MOM_diag_field_add_attribute(id, 'cell_methods', trim(cell_methods))
+ ostring = trim(cell_methods)
+ endif
+ else
+ if (present(x_cell_method)) then
+ if (len(trim(x_cell_method))>0) then
+ call get_MOM_diag_axis_name(axes%handles(1), axis_name)
+ call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method))
+ ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(x_cell_method)
+ if (trim(x_cell_method)=='mean') x_mean=.true.
+ if (trim(x_cell_method)=='sum') x_sum=.true.
+ endif
else
- mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]'
+ if (len(trim(axes%x_cell_method))>0) then
+ call get_MOM_diag_axis_name(axes%handles(1), axis_name)
+ call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%x_cell_method))
+ ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%x_cell_method)
+ if (trim(axes%x_cell_method)=='mean') x_mean=.true.
+ if (trim(axes%x_cell_method)=='sum') x_sum=.true.
+ endif
endif
- write(diag_CS%doc_unit, '(a)') trim(mesg)
- if (present(long_name)) call describe_option("long_name", long_name, diag_CS)
- if (present(units)) call describe_option("units", units, diag_CS)
- if (present(standard_name)) &
- call describe_option("standard_name", standard_name, diag_CS)
- endif
-
- !Decide what mask to use based on the axes info
- if (primary_id > 0) then
- !2d masks
- if (axes%rank == 2) then
- diag%mask2d => null() ; diag%mask2d_comp => null()
- if (axes%id == diag_cs%axesT1%id) then
- diag%mask2d => diag_cs%mask2dT
- diag%mask2d_comp => diag_cs%mask2dT_comp
- elseif (axes%id == diag_cs%axesB1%id) then
- diag%mask2d => diag_cs%mask2dBu
- elseif (axes%id == diag_cs%axesCu1%id) then
- diag%mask2d => diag_cs%mask2dCu
- elseif (axes%id == diag_cs%axesCv1%id) then
- diag%mask2d => diag_cs%mask2dCv
- ! else
- ! call SIS_error(FATAL, "SIS_diag_mediator:register_diag_field: " // &
- ! "unknown axes for diagnostic variable "//trim(field_name))
+ if (present(y_cell_method)) then
+ if (len(trim(y_cell_method))>0) then
+ call get_MOM_diag_axis_name(axes%handles(2), axis_name)
+ call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method))
+ ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(y_cell_method)
+ if (trim(y_cell_method)=='mean') y_mean=.true.
+ if (trim(y_cell_method)=='sum') y_sum=.true.
endif
else
- call MOM_error(FATAL, "MOM_IS_diag_mediator:register_diag_field: " // &
- "unknown axes for diagnostic variable "//trim(field_name))
+ if (len(trim(axes%y_cell_method))>0) then
+ call get_MOM_diag_axis_name(axes%handles(2), axis_name)
+ call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%y_cell_method))
+ ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%y_cell_method)
+ if (trim(axes%y_cell_method)=='mean') y_mean=.true.
+ if (trim(axes%y_cell_method)=='sum') y_sum=.true.
+ endif
+ endif
+ if (x_mean .and. y_mean) then
+ call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:mean')
+ ostring = trim(adjustl(ostring))//' area:mean'
+ elseif (x_sum .and. y_sum) then
+ call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:sum')
+ ostring = trim(adjustl(ostring))//' area:sum'
endif
- endif ! if (primary_id>-1)
+ endif
+ ostring = adjustl(ostring)
+end subroutine attach_cell_methods
- register_diag_field = primary_id
+!> Registers a non-array scalar diagnostic, returning an integer handle
+function register_scalar_field_axes(module_name, field_name, axes, init_time, &
+ long_name, units, missing_value, range, standard_name, &
+ do_not_log, err_msg, interp_method, cmor_field_name, &
+ cmor_long_name, cmor_units, cmor_standard_name, conversion) result (register_scalar_field)
+ integer :: register_scalar_field !< An integer handle for a diagnostic array.
+ character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
+ !! or "ice_shelf_model"
+ character(len=*), intent(in) :: field_name !< Name of the diagnostic field
+ type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that
+ !! indicates axes for this field
+ type(time_type), intent(in) :: init_time !< Time at which a field is first available?
+ character(len=*), optional, intent(in) :: long_name !< Long name of a field.
+ character(len=*), optional, intent(in) :: units !< Units of a field.
+ character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
+ real, optional, intent(in) :: missing_value !< A value that indicates missing values in
+ !! output files, in unscaled arbitrary units [a]
+ real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
+ !! in arbitrary units [a]
+ logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
+ character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
+ !! placed (not used in MOM?)
+ character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not
+ !! be interpolated as a scalar
+ character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
+ character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
+ character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
+ character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
+ real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files,
+ !! often including factors to undo internal scaling and
+ !! in units of [a A-1 ~> 1]
-end function register_MOM_IS_diag_field
+ register_scalar_field = register_scalar_field_CS(module_name, field_name, init_time, axes%diag_cs, &
+ long_name, units, missing_value, range, standard_name, &
+ do_not_log, err_msg, interp_method, cmor_field_name, &
+ cmor_long_name, cmor_units, cmor_standard_name, conversion)
+
+end function register_scalar_field_axes
-!> Returns the "MOM_IS_diag_mediator" handle for a group of diagnostics derived from one scalar.
-function register_MOM_IS_scalar_field(module_name, field_name, axes, init_time, &
+!> Registers a non-array scalar diagnostic, returning an integer handle
+function register_scalar_field_CS(module_name, field_name, init_time, diag_cs, &
long_name, units, missing_value, range, standard_name, &
- do_not_log, err_msg, conversion) result (register_scalar_field)
- integer :: register_scalar_field !< The returned diagnostic handle
- character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model"
+ do_not_log, err_msg, interp_method, cmor_field_name, &
+ cmor_long_name, cmor_units, cmor_standard_name, conversion) result (register_scalar_field)
+ integer :: register_scalar_field !< An integer handle for a diagnostic array.
+ character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
+ !! or "ice_shelf_model"
character(len=*), intent(in) :: field_name !< Name of the diagnostic field
- type(axesType), intent(in) :: axes !< The axis group for this field
type(time_type), intent(in) :: init_time !< Time at which a field is first available?
+ type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output
character(len=*), optional, intent(in) :: long_name !< Long name of a field.
character(len=*), optional, intent(in) :: units !< Units of a field.
character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
- real, optional, intent(in) :: missing_value !< A value that indicates missing values.
+ real, optional, intent(in) :: missing_value !< A value that indicates missing values in
+ !! output files, in unscaled arbitrary units [a]
real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
+ !! in arbitrary units [a]
logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
!! placed (not used in MOM?)
- real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file
+ character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not
+ !! be interpolated as a scalar
+ character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
+ character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
+ character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
+ character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
+ real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files,
+ !! often including factors to undo internal scaling and
+ !! in units of [a A-1 ~> 1]
! Local variables
- character(len=240) :: mesg
- real :: MOM_missing_value
- integer :: primary_id, fms_id
- type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used
- ! to regulate diagnostic output
- type(diag_type), pointer :: diag => NULL()
+ real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a]
+ integer :: dm_id, fms_id
+ type(diag_type), pointer :: diag => null(), cmor_diag => null()
+ character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
+ character(len=16) :: dimensions
- MOM_missing_value = axes%diag_cs%missing_value
+ MOM_missing_value = diag_cs%missing_value
if (present(missing_value)) MOM_missing_value = missing_value
- diag_cs => axes%diag_cs
- primary_id = -1
+ dm_id = -1
+ diag => null()
+ cmor_diag => null()
- fms_id = register_diag_field_infra(module_name, field_name, &
- init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, &
- range=range, standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg)
+ if (diag_cs%diag_as_chksum) then
+ fms_id = diag_cs%num_chksum_diags + 1
+ diag_cs%num_chksum_diags = fms_id
+ else
+ fms_id = register_diag_field_infra(module_name, field_name, init_time, &
+ long_name=long_name, units=units, missing_value=MOM_missing_value, &
+ range=range, standard_name=standard_name, do_not_log=do_not_log, &
+ err_msg=err_msg)
+ endif
- if (fms_id > 0) then
- primary_id = get_new_diag_id(diag_cs)
- diag => diag_cs%diags(primary_id)
+ if (fms_id /= DIAG_FIELD_NOT_FOUND) then
+ dm_id = get_new_diag_id(diag_cs)
+ call alloc_diag_with_id(dm_id, diag_cs, diag)
+ call assert(associated(diag), 'register_scalar_field: diag allocation failed')
diag%fms_diag_id = fms_id
- if (len(field_name) > len(diag%name)) then
- diag%name = field_name(1:len(diag%name))
- else ; diag%name = field_name ; endif
+ diag%debug_str = trim(module_name)//"-"//trim(field_name)
+ if (present(conversion)) diag%conversion_factor = conversion
+ endif
- if (present(conversion)) diag%conversion_factor = conversion
+ if (present(cmor_field_name)) then
+ ! Fallback values for strings set to "not provided"
+ posted_cmor_units = "not provided"
+ posted_cmor_standard_name = "not provided"
+ posted_cmor_long_name = "not provided"
+
+ ! If attributes are present for MOM variable names, use them as defaults for the
+ ! register_diag_field_infra call for CMOR verison of the variable
+ if (present(units)) posted_cmor_units = units
+ if (present(standard_name)) posted_cmor_standard_name = standard_name
+ if (present(long_name)) posted_cmor_long_name = long_name
+
+ ! If specified in the call to register_MOM_IS_scalar_field, override attributes with the CMOR versions
+ if (present(cmor_units)) posted_cmor_units = cmor_units
+ if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
+ if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
+
+ fms_id = register_diag_field_infra(module_name, cmor_field_name, init_time, &
+ long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
+ missing_value=MOM_missing_value, range=range, &
+ standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg)
+ if (fms_id /= DIAG_FIELD_NOT_FOUND) then
+ if (dm_id == -1) then
+ dm_id = get_new_diag_id(diag_cs)
+ endif
+ call alloc_diag_with_id(dm_id, diag_cs, cmor_diag)
+ cmor_diag%fms_diag_id = fms_id
+ cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name)
+ if (present(conversion)) cmor_diag%conversion_factor = conversion
endif
+ endif
- if (is_root_pe() .and. diag_CS%doc_unit > 0) then
- if (primary_id > 0) then
- mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]'
- else
- mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]'
- endif
- write(diag_CS%doc_unit, '(a)') trim(mesg)
- if (present(long_name)) call describe_option("long_name", long_name, diag_CS)
- if (present(units)) call describe_option("units", units, diag_CS)
- if (present(standard_name)) &
- call describe_option("standard_name", standard_name, diag_CS)
+ dimensions = "scalar"
+
+ ! Document diagnostics in list of available diagnostics
+ if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then
+ if (present(cmor_field_name)) then
+ call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, &
+ long_name, units, standard_name, &
+ variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}", &
+ dimensions=dimensions)
+ else
+ call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, &
+ long_name, units, standard_name, dimensions=dimensions)
endif
+ endif
- register_scalar_field = primary_id
+ register_scalar_field = dm_id
-end function register_MOM_IS_scalar_field
+end function register_scalar_field_CS
!> Registers a static diagnostic, returning an integer handle
function register_MOM_IS_static_field(module_name, field_name, axes, &
- long_name, units, missing_value, range, mask_variant, standard_name, &
- do_not_log, interp_method, tile_count) result(register_static_field)
- integer :: register_static_field !< The returned diagnostic handle
- character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model"
+ long_name, units, missing_value, range, mask_variant, standard_name, &
+ do_not_log, interp_method, tile_count, &
+ cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, &
+ x_cell_method, y_cell_method, area_cell_method, conversion) result(register_static_field)
+ integer :: register_static_field !< An integer handle for a diagnostic array.
+ character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
+ !! or "ice_shelf_model"
character(len=*), intent(in) :: field_name !< Name of the diagnostic field
- type(axesType), intent(in) :: axes !< The axis group for this field
+ type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that
+ !! indicates axes for this field
character(len=*), optional, intent(in) :: long_name !< Long name of a field.
character(len=*), optional, intent(in) :: units !< Units of a field.
character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
- real, optional, intent(in) :: missing_value !< A value that indicates missing values.
- real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
+ real, optional, intent(in) :: missing_value !< A value that indicates missing values in
+ !! output files, in unscaled arbitrary units [a]
+ real, optional, intent(in) :: range(2) !< Valid range of a variable in arbitrary units [a]
logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with
!! post_IS_data calls (not used in MOM?)
logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not
!! be interpolated as a scalar
- integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?)
+ integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?)
+ character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
+ character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
+ character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
+ character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
+ integer, optional, intent(in) :: area !< fms_id for area_t
+ character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
+ character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
+ character(len=*), optional, intent(in) :: area_cell_method !< Specifies the cell method for area
+ real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files,
+ !! often including factors to undo internal scaling and
+ !! in units of [a A-1 ~> 1]
! Local variables
- real :: MOM_missing_value
- integer :: primary_id, fms_id
- type(diag_ctrl), pointer :: diag_cs !< A structure that is used to regulate diagnostic output
+ real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a]
+ type(diag_ctrl), pointer :: diag_cs => null() !< A structure that is used to regulate diagnostic output
+ type(diag_type), pointer :: diag => null(), cmor_diag => null()
+ integer :: dm_id, fms_id
+ character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
+ character(len=9) :: axis_name
+ character(len=24) :: dimensions
MOM_missing_value = axes%diag_cs%missing_value
if (present(missing_value)) MOM_missing_value = missing_value
diag_cs => axes%diag_cs
- primary_id = -1
+ dm_id = -1
+ diag => null()
+ cmor_diag => null()
+
+ if (diag_cs%diag_as_chksum) then
+ fms_id = diag_cs%num_chksum_diags + 1
+ diag_cs%num_chksum_diags = fms_id
+ else
+ fms_id = register_static_field_infra(module_name, field_name, axes%handles, &
+ long_name=long_name, units=units, missing_value=MOM_missing_value, &
+ range=range, mask_variant=mask_variant, standard_name=standard_name, &
+ do_not_log=do_not_log, &
+ interp_method=interp_method, tile_count=tile_count, area=area)
+ endif
+
+ if (fms_id /= DIAG_FIELD_NOT_FOUND) then
+ dm_id = get_new_diag_id(diag_cs)
+ call alloc_diag_with_id(dm_id, diag_cs, diag)
+ call assert(associated(diag), 'register_static_field: diag allocation failed')
+ diag%fms_diag_id = fms_id
+ diag%debug_str = trim(module_name)//"-"//trim(field_name)
+ if (present(conversion)) diag%conversion_factor = conversion
+
+ if (diag_cs%diag_as_chksum) then
+ diag%axes => axes
+ else
+ if (present(x_cell_method)) then
+ call get_MOM_diag_axis_name(axes%handles(1), axis_name)
+ call MOM_diag_field_add_attribute(fms_id, 'cell_methods', &
+ trim(axis_name)//':'//trim(x_cell_method))
+ endif
+ if (present(y_cell_method)) then
+ call get_MOM_diag_axis_name(axes%handles(2), axis_name)
+ call MOM_diag_field_add_attribute(fms_id, 'cell_methods', &
+ trim(axis_name)//':'//trim(y_cell_method))
+ endif
+ if (present(area_cell_method)) then
+ call MOM_diag_field_add_attribute(fms_id, 'cell_methods', &
+ 'area:'//trim(area_cell_method))
+ endif
+ endif
+ endif
- fms_id = register_static_field_infra(module_name, field_name, axes%handles, &
- long_name=long_name, units=units, missing_value=MOM_missing_value, &
- range=range, mask_variant=mask_variant, standard_name=standard_name, &
- do_not_log=do_not_log, &
- interp_method=interp_method, tile_count=tile_count)
- if (fms_id > 0) then
- primary_id = get_new_diag_id(diag_cs)
- diag_cs%diags(primary_id)%fms_diag_id = fms_id
+ if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then
+ ! Fallback values for strings set to "not provided"
+ posted_cmor_units = "not provided"
+ posted_cmor_standard_name = "not provided"
+ posted_cmor_long_name = "not provided"
+
+ ! If attributes are present for MOM variable names, use them first for the register_static_field
+ ! call for CMOR verison of the variable
+ if (present(units)) posted_cmor_units = units
+ if (present(standard_name)) posted_cmor_standard_name = standard_name
+ if (present(long_name)) posted_cmor_long_name = long_name
+
+ ! If specified in the call to register_static_field, override attributes with the CMOR versions
+ if (present(cmor_units)) posted_cmor_units = cmor_units
+ if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
+ if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
+
+ fms_id = register_static_field_infra(module_name, cmor_field_name, axes%handles, &
+ long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
+ missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, &
+ standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, &
+ interp_method=interp_method, tile_count=tile_count, area=area)
+ if (fms_id /= DIAG_FIELD_NOT_FOUND) then
+ if (dm_id == -1) then
+ dm_id = get_new_diag_id(diag_cs)
+ endif
+ call alloc_diag_with_id(dm_id, diag_cs, cmor_diag)
+ cmor_diag%fms_diag_id = fms_id
+ cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name)
+ if (present(conversion)) cmor_diag%conversion_factor = conversion
+ if (present(x_cell_method)) then
+ call get_MOM_diag_axis_name(axes%handles(1), axis_name)
+ call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method))
+ endif
+ if (present(y_cell_method)) then
+ call get_MOM_diag_axis_name(axes%handles(2), axis_name)
+ call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method))
+ endif
+ if (present(area_cell_method)) then
+ call MOM_diag_field_add_attribute(fms_id, 'cell_methods', 'area:'//trim(area_cell_method))
+ endif
+ endif
+ endif
+
+ dimensions = ""
+ if (axes%is_h_point) dimensions = trim(dimensions)//" xh, yh,"
+ if (axes%is_q_point) dimensions = trim(dimensions)//" xq, yq,"
+ if (axes%is_u_point) dimensions = trim(dimensions)//" xq, yh,"
+ if (axes%is_v_point) dimensions = trim(dimensions)//" xh, yq,"
+ if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions)
+
+ ! Document diagnostics in list of available diagnostics
+ if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then
+ if (present(cmor_field_name)) then
+ call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, &
+ long_name, units, standard_name, &
+ variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}", &
+ dimensions=dimensions)
+ else
+ call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, &
+ long_name, units, standard_name, dimensions=dimensions)
+ endif
endif
- register_static_field = primary_id
+ register_static_field = dm_id
end function register_MOM_IS_static_field
@@ -664,47 +1356,26 @@ end function register_MOM_IS_static_field
subroutine describe_option(opt_name, value, diag_CS)
character(len=*), intent(in) :: opt_name !< The name of the option
character(len=*), intent(in) :: value !< The value of the option
- type(diag_ctrl), intent(in) :: diag_CS !< Diagnostic being documented
+ type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
! Local variables
- character(len=240) :: mesg
+ character(len=480) :: mesg
integer :: len_ind
len_ind = len_trim(value)
mesg = " ! "//trim(opt_name)//": "//trim(value)
- write(diag_CS%doc_unit, '(a)') trim(mesg)
+ write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg)
end subroutine describe_option
-!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string.
-function i2s(a, n_in)
- integer, dimension(:), intent(in) :: a !< The array of integers to translate
- integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all
- character(len=15) :: i2s !< The returned string
-
- ! Local variables
- character(len=15) :: i2s_temp
- integer :: i,n
-
- n = size(a)
- if (present(n_in)) n = n_in
-
- i2s = ''
- do i=1,n
- write (i2s_temp, '(I4.4)') a(i)
- i2s = trim(i2s) //'_'// trim(i2s_temp)
- enddo
- i2s = adjustl(i2s)
-end function i2s
-
-!> Initialize the MOM_IS diag_mediator and opens the available diagnostics file.
+!> Initialize the MOM_IS diag_mediator and opens the available diagnostics file, if appropriate.
subroutine MOM_IS_diag_mediator_init(G, US, param_file, diag_cs, component, err_msg, &
doc_file_dir)
- type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type
+ type(ocean_grid_type), target, intent(inout) :: G !< The horizontal grid type
type(unit_scale_type), target, intent(in) :: US !< A dimensional unit scaling type
type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters
type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output
- character(len=*), optional, intent(in) :: component !< An opitonal component name
+ character(len=*), optional, intent(in) :: component !< An optional component name
character(len=*), optional, intent(out) :: err_msg !< A string for a returned error message
character(len=*), optional, intent(in) :: doc_file_dir !< A directory in which to create the file
@@ -713,26 +1384,58 @@ subroutine MOM_IS_diag_mediator_init(G, US, param_file, diag_cs, component, err_
! is not necessary that the metrics and axis labels be set up yet.
! Local variables
- integer :: ios, new_unit
+ integer :: ios, i, new_unit
logical :: opened, new_file
character(len=8) :: this_pe
character(len=240) :: doc_file, doc_file_dflt, doc_path
character(len=40) :: doc_file_param
- character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name.
+ ! This include declares and sets the variable "version".
+# include "version_variable.h"
+ character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name.
+ character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs
call MOM_diag_manager_init(err_msg=err_msg)
- ! Allocate list of all diagnostics
+ id_clock_diag_mediator = cpu_clock_id('(Ice shelf diagnostics framework)', grain=CLOCK_MODULE)
+
+ ! Allocate and initialize list of all diagnostics (and variants)
allocate(diag_cs%diags(DIAG_ALLOC_CHUNK_SIZE))
diag_cs%next_free_diag_id = 1
- diag_cs%diags(:)%in_use = .false.
+ do i=1, DIAG_ALLOC_CHUNK_SIZE
+ call initialize_diag_type(diag_cs%diags(i))
+ enddo
+
+ diag_cs%show_call_tree = callTree_showQuery()
+
+ ! Read all relevant parameters and write them to the model log.
+ call log_version(param_file, mdl, version, "")
+
+ call get_param(param_file, mdl, 'USE_INDEX_DIAGNOSTIC_AXES', diag_cs%index_space_axes, &
+ 'If true, use a grid index coordinate convention for diagnostic axes. ',&
+ default=.false.)
+
+ call get_param(param_file, mdl, 'DIAG_MISVAL', diag_cs%missing_value, &
+ 'Set the default missing value to use for diagnostics.', &
+ units="various", default=-1.e34)
+ call get_param(param_file, mdl, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, &
+ 'Instead of writing diagnostics to the diag manager, write '//&
+ 'a text file containing the checksum (bitcount) of the array.', &
+ default=.false.)
+ if (diag_cs%diag_as_chksum) &
+ diag_cs%num_chksum_diags = 0
+
+ ! Keep pointers to the grid for diagnostic checksums
+ diag_cs%G => G
diag_cs%US => US
+
diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1)
diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1)
- diag_cs%isd = G%isd ; diag_cs%ied = G%ied ; diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed
+ diag_cs%isd = G%isd ; diag_cs%ied = G%ied
+ diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed
- if (is_root_pe() .and. (diag_CS%doc_unit < 0)) then
+ ! Initialize available diagnostic log file
+ if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then
if (present(component)) then
doc_file_dflt = trim(component)//".available_diags"
doc_file_param = trim(uppercase(component))//"_AVAILABLE_DIAGS_FILE"
@@ -744,15 +1447,14 @@ subroutine MOM_IS_diag_mediator_init(G, US, param_file, diag_cs, component, err_
call get_param(param_file, mdl, trim(doc_file_param), doc_file, &
"A file into which to write a list of all available "//&
"ice shelf diagnostics that can be included in a diag_table.", &
- default=doc_file_dflt)
+ default=doc_file_dflt, do_not_log=(diag_CS%available_diag_doc_unit/=-1))
if (len_trim(doc_file) > 0) then
- new_file = .true. ; if (diag_CS%doc_unit /= -1) new_file = .false.
+ new_file = .true. ; if (diag_CS%available_diag_doc_unit /= -1) new_file = .false.
! Find an unused unit number.
do new_unit=512,42,-1
inquire( new_unit, opened=opened)
if (.not.opened) exit
enddo
-
if (opened) call MOM_error(FATAL, &
"diag_mediator_init failed to find an unused unit number.")
@@ -761,36 +1463,84 @@ subroutine MOM_IS_diag_mediator_init(G, US, param_file, diag_cs, component, err_
doc_path = trim(slasher(doc_file_dir))//trim(doc_file)
endif ; endif
- diag_CS%doc_unit = new_unit
+ diag_CS%available_diag_doc_unit = new_unit
if (new_file) then
- open(diag_CS%doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
+ open(diag_CS%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
action='WRITE', status='REPLACE', iostat=ios)
else ! This file is being reopened, and should be appended.
- open(diag_CS%doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
+ open(diag_CS%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
action='WRITE', status='OLD', position='APPEND', iostat=ios)
endif
- inquire(diag_CS%doc_unit, opened=opened)
+ inquire(diag_CS%available_diag_doc_unit, opened=opened)
if ((.not.opened) .or. (ios /= 0)) then
call MOM_error(FATAL, "Failed to open available diags file "//trim(doc_path)//".")
endif
endif
endif
- call diag_masks_set(G, -1.0e34, diag_cs)
+ if (is_root_pe() .and. (diag_CS%chksum_iounit < 0) .and. diag_CS%diag_as_chksum) then
+ !write(this_pe,'(i6.6)') PE_here()
+ !doc_file_dflt = "chksum_diag."//this_pe
+ doc_file_dflt = "chksum_diag"
+ call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, &
+ "A file into which to write all checksums of the "//&
+ "diagnostics listed in the diag_table.", &
+ default=doc_file_dflt, do_not_log=(diag_CS%chksum_iounit/=-1))
+
+ call get_filename_appendix(filename_appendix)
+ if (len_trim(filename_appendix) > 0) then
+ doc_file = trim(doc_file) //'.'//trim(filename_appendix)
+ endif
+#ifdef STATSLABEL
+ doc_file = trim(doc_file)//"."//trim(adjustl(STATSLABEL))
+#endif
+
+ if (len_trim(doc_file) > 0) then
+ new_file = .true. ; if (diag_CS%chksum_iounit /= -1) new_file = .false.
+ ! Find an unused unit number.
+ do new_unit=512,42,-1
+ inquire( new_unit, opened=opened)
+ if (.not.opened) exit
+ enddo
+ if (opened) call MOM_error(FATAL, &
+ "diag_mediator_init failed to find an unused unit number.")
+
+ doc_path = doc_file
+ if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then
+ doc_path = trim(slasher(doc_file_dir))//trim(doc_file)
+ endif ; endif
+
+ diag_CS%chksum_iounit = new_unit
+
+ if (new_file) then
+ open(diag_CS%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
+ action='WRITE', status='REPLACE', iostat=ios)
+ else ! This file is being reopened, and should be appended.
+ open(diag_CS%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
+ action='WRITE', status='OLD', position='APPEND', iostat=ios)
+ endif
+ inquire(diag_CS%chksum_iounit, opened=opened)
+ if ((.not.opened) .or. (ios /= 0)) then
+ call MOM_error(FATAL, "Failed to open checksum diags file "//trim(doc_path)//".")
+ endif
+ endif
+ endif
+
+ call diag_masks_set(G, diag_cs%missing_value, diag_cs)
end subroutine MOM_IS_diag_mediator_init
+!> Sets up the 2d masks for native diagnostics
subroutine diag_masks_set(G, missing_value, diag_cs)
-! Setup the 2d masks for diagnostics
type(ocean_grid_type), target, intent(in) :: G !< The horizontal grid type
- real, intent(in) :: missing_value !< A fill value for missing points
- type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output
+ real, intent(in) :: missing_value !< A fill value for missing points
+ type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
! Local variables
integer :: i, j
-
+ ! 2d masks point to the model masks since they are identical
diag_cs%mask2dT => G%mask2dT
diag_cs%mask2dBu => G%mask2dBu
diag_cs%mask2dCu => G%mask2dCu
@@ -801,37 +1551,60 @@ subroutine diag_masks_set(G, missing_value, diag_cs)
diag_cs%mask2dT_comp(i,j) = diag_cs%mask2dT(i,j)
enddo ; enddo
-
diag_cs%missing_value = missing_value
end subroutine diag_masks_set
!> Prevent the registration of additional diagnostics, so that the creation of files can occur
subroutine MOM_IS_diag_mediator_close_registration(diag_CS)
- type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output
+ type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output
- if (diag_CS%doc_unit > -1) then
- close(diag_CS%doc_unit) ; diag_CS%doc_unit = -2
+ if (diag_CS%available_diag_doc_unit > -1) then
+ close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -2
endif
end subroutine MOM_IS_diag_mediator_close_registration
!> Deallocate memory associated with the MOM_IS diag mediator
subroutine MOM_IS_diag_mediator_end(diag_CS)
- type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output
+ type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output
- if (diag_CS%doc_unit > -1) then
- close(diag_CS%doc_unit) ; diag_CS%doc_unit = -3
+ ! Local variables
+ type(diag_type), pointer :: diag, next_diag
+ integer :: i
+
+ if (diag_CS%available_diag_doc_unit > -1) then
+ close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -3
+ endif
+ if (diag_CS%chksum_iounit > -1) then
+ close(diag_CS%chksum_iounit) ; diag_CS%chksum_iounit = -3
endif
-end subroutine MOM_IS_diag_mediator_end
+ do i=1, diag_cs%next_free_diag_id - 1
+ if (associated(diag_cs%diags(i)%next)) then
+ next_diag => diag_cs%diags(i)%next
+ do while (associated(next_diag))
+ diag => next_diag
+ next_diag => diag%next
+ deallocate(diag)
+ enddo
+ endif
+ enddo
+
+ deallocate(diag_cs%diags)
-!> Allocate a new diagnostic id, noting that it may be necessary to expand the diagnostics array.
-function get_new_diag_id(diag_cs)
+ ! These points to arrays in the grid type, so they can not be deallocated here.
+ if (associated(diag_cs%mask2dT)) diag_cs%mask2dT => NULL()
+ if (associated(diag_cs%mask2dBu)) diag_cs%mask2dBu => NULL()
+ if (associated(diag_cs%mask2dCu)) diag_cs%mask2dCu => NULL()
+ if (associated(diag_cs%mask2dCv)) diag_cs%mask2dCv => NULL()
+ if (associated(diag_cs%mask2dT_comp)) deallocate(diag_cs%mask2dT_comp)
- integer :: get_new_diag_id !< The returned ID for the new diagnostic
- type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output
+end subroutine MOM_IS_diag_mediator_end
+!> Returns a new diagnostic id, it may be necessary to expand the diagnostics array.
+integer function get_new_diag_id(diag_cs)
+ type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
! Local variables
type(diag_type), dimension(:), allocatable :: tmp
integer :: i
@@ -849,9 +1622,9 @@ function get_new_diag_id(diag_cs)
diag_cs%diags(1:size(tmp)) = tmp(:)
deallocate(tmp)
- ! Initialise new part of the diag array.
+ ! Initialize new part of the diag array.
do i=diag_cs%next_free_diag_id, size(diag_cs%diags)
- diag_cs%diags(i)%in_use = .false.
+ call initialize_diag_type(diag_cs%diags(i))
enddo
endif
@@ -860,4 +1633,112 @@ function get_new_diag_id(diag_cs)
end function get_new_diag_id
+!> Initializes a diag_type (used after allocating new memory)
+subroutine initialize_diag_type(diag)
+ type(diag_type), intent(inout) :: diag !< diag_type to be initialized
+
+ diag%in_use = .false.
+ diag%fms_diag_id = -1
+ diag%axes => null()
+ diag%next => null()
+ diag%conversion_factor = 0.
+
+end subroutine initialize_diag_type
+
+!> Make a new diagnostic. Either use memory which is in the array of 'primary'
+!! diagnostics, or if that is in use, insert it to the list of secondary diags.
+subroutine alloc_diag_with_id(diag_id, diag_cs, diag)
+ integer, intent(in ) :: diag_id !< id for the diagnostic
+ type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output
+ type(diag_type), pointer :: diag !< structure representing a diagnostic (inout)
+
+ type(diag_type), pointer :: tmp => NULL()
+
+ if (.not. diag_cs%diags(diag_id)%in_use) then
+ diag => diag_cs%diags(diag_id)
+ else
+ allocate(diag)
+ tmp => diag_cs%diags(diag_id)%next
+ diag_cs%diags(diag_id)%next => diag
+ diag%next => tmp
+ endif
+ diag%in_use = .true.
+
+end subroutine alloc_diag_with_id
+
+!> Log a diagnostic to the available diagnostics file.
+subroutine log_available_diag(used, module_name, field_name, cell_methods_string, comment, &
+ diag_CS, long_name, units, standard_name, variants, dimensions)
+ logical, intent(in) :: used !< Whether this diagnostic was in the diag_table or not
+ character(len=*), intent(in) :: module_name !< Name of the diagnostic module
+ character(len=*), intent(in) :: field_name !< Name of this diagnostic field
+ character(len=*), intent(in) :: cell_methods_string !< The spatial component of the CF cell_methods attribute
+ character(len=*), intent(in) :: comment !< A comment to append after [Used|Unused]
+ type(diag_ctrl), intent(in) :: diag_CS !< The diagnotics control structure
+ character(len=*), optional, intent(in) :: dimensions !< Descriptor of the horizontal and vertical dimensions
+ character(len=*), optional, intent(in) :: long_name !< CF long name of diagnostic
+ character(len=*), optional, intent(in) :: units !< Units for diagnostic
+ character(len=*), optional, intent(in) :: standard_name !< CF standardized name of diagnostic
+ character(len=*), optional, intent(in) :: variants !< Alternate modules and variable names for
+ !! this diagnostic and derived diagnostics
+ ! Local variables
+ character(len=240) :: mesg
+
+ if (used) then
+ mesg = '"'//trim(field_name)//'" [Used]'
+ else
+ mesg = '"'//trim(field_name)//'" [Unused]'
+ endif
+ if (len(trim((comment)))>0) then
+ write(diag_CS%available_diag_doc_unit, '(a,1x,"(",a,")")') trim(mesg),trim(comment)
+ else
+ write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg)
+ endif
+ call describe_option("modules", module_name, diag_CS)
+ if (present(dimensions)) then ; if (len(trim(dimensions)) > 0) then
+ call describe_option("dimensions", dimensions, diag_CS)
+ endif ; endif
+ if (present(long_name)) call describe_option("long_name", long_name, diag_CS)
+ if (present(units)) call describe_option("units", units, diag_CS)
+ if (present(standard_name)) &
+ call describe_option("standard_name", standard_name, diag_CS)
+ if (len(trim((cell_methods_string)))>0) &
+ call describe_option("cell_methods", trim(cell_methods_string), diag_CS)
+ if (present(variants)) then ; if (len(trim(variants)) > 0) then
+ call describe_option("variants", variants, diag_CS)
+ endif ; endif
+end subroutine log_available_diag
+
+!> Log the diagnostic chksum to the chksum diag file
+subroutine log_chksum_diag(docunit, description, chksum)
+ integer, intent(in) :: docunit !< Handle of the log file
+ character(len=*), intent(in) :: description !< Name of the diagnostic module
+ integer, intent(in) :: chksum !< chksum of the diagnostic
+
+ write(docunit, '(a,1x,i9.8)') description, chksum
+ flush(docunit)
+
+end subroutine log_chksum_diag
+
+!> Fakes a register of a diagnostic to find out if an obsolete
+!! parameter appears in the diag_table.
+logical function found_in_diagtable(diag, varName)
+ type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics.
+ character(len=*), intent(in) :: varName !< The obsolete diagnostic name
+ ! Local
+ integer :: handle ! Integer handle returned from diag_manager
+
+ ! We use register_static_field_fms() instead of register_static_field() so
+ ! that the diagnostic does not appear in the available diagnostics list.
+ handle = register_static_field_infra('ice_shelf_model', varName, diag%axesT1%handles)
+
+ found_in_diagtable = (handle>0)
+
+end function found_in_diagtable
+
+!> Finishes the diag manager reduction methods as needed for the time_step
+subroutine MOM_IS_diag_send_complete()
+ call diag_send_complete_infra()
+end subroutine MOM_IS_diag_send_complete
+
end module MOM_IS_diag_mediator
diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90
index 9f50a77881..a1fce2feed 100644
--- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90
+++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Implements a crude placeholder for a later implementation of full
!! ice shelf dynamics.
module MOM_ice_shelf_dynamics
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE
use MOM_IS_diag_mediator, only : post_data=>post_IS_data
@@ -11,7 +13,7 @@ module MOM_ice_shelf_dynamics
!use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, set_IS_diag_mediator_grid
use MOM_IS_diag_mediator, only : diag_ctrl, time_type, enable_averages, disable_averaging
use MOM_domains, only : MOM_domains_init, clone_MOM_domain
-use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER, CENTER
+use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, AGRID, CORNER, CENTER
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type
use MOM_grid, only : MOM_grid_init, ocean_grid_type
@@ -92,6 +94,22 @@ module MOM_ice_shelf_dynamics
real, pointer, dimension(:,:,:) :: ice_visc => NULL() !< Area and depth-integrated Glen's law ice viscosity
!! (Pa m3 s) in [R L4 Z T-1 ~> kg m2 s-1].
!! at either 1 (cell-centered) or 4 quadrature points per cell
+ real, pointer, dimension(:,:,:) :: newton_visc_factor => NULL() !< Newton tangent stiffness coefficient:
+ !! (1/n_glen - 1)/2 * ice_visc / eps_e2 at each
+ !! viscosity quadrature point [R L4 Z T ~> kg m2 s]
+ real, pointer, dimension(:,:,:) :: newton_str_ux => NULL() !< Longitudinal x-strain-rate ux at each viscosity
+ !! quadrature point for Newton iterations [T-1 ~> s-1]
+ real, pointer, dimension(:,:,:) :: newton_str_vy => NULL() !< Longitudinal y-strain-rate vy at each viscosity
+ !! quadrature point for Newton iterations [T-1 ~> s-1]
+ real, pointer, dimension(:,:,:) :: newton_str_sh => NULL() !< Engineering shear strain-rate uy+vx at each
+ !! viscosity quadrature point for Newton iterations [T-1 ~> s-1]
+ real, pointer, dimension(:,:) :: newton_umid => NULL() !< Cell-averaged zonal velocity u at the current outer
+ !! iterate, for Newton basal drag correction [L T-1 ~> m s-1]
+ real, pointer, dimension(:,:) :: newton_vmid => NULL() !< Cell-averaged meridional velocity v at the current
+ !! outer iterate, for Newton basal drag correction [L T-1 ~> m s-1]
+ real, pointer, dimension(:,:) :: newton_drag_coef => NULL() !< Newton basal drag correction coefficient:
+ !! 2 * d(basal_trac)/d(|u|^2) * area = d(tau_b_i)/d(u_j) - basal_trac*delta_ij
+ !! expressed as the u_i*u_j tensor coefficient [R Z T ~> kg m-2 s]
real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity,
!! often in [Pa-3 s-1] if n_Glen is 3.
real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries
@@ -153,6 +171,9 @@ module MOM_ice_shelf_dynamics
character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally
!! according to Glen's flow law; is constant (for debugging purposes)
!! or using observed strain rates and read from a file
+ logical :: shelf_top_slope_bugs !< If true, use directionally inconsistent estimates of the grid
+ !! spacing when calculating the ice shelf surface slope, and underestimate
+ !! slopes near the edge of the ice shelf by a factor of 2.
logical :: GL_regularize !< Specifies whether to regularize the floatation condition
!! at the grounding line as in Goldberg Holland Schoof 2009
integer :: n_sub_regularize
@@ -191,8 +212,12 @@ module MOM_ice_shelf_dynamics
real :: T_shelf_missing !< An ice shelf temperature to use where there is no ice shelf [C ~> degC]
real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that
!! determines when to stop the conjugate gradient iterations [nondim].
+ real :: cg_tol_newton !< Working CG tolerance for the current inner solve [nondim].
real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error,
!! that sets when to stop the iterative velocity solver [nondim]
+ real :: newton_after_tolerance !< The fractional nonlinear tolerance, relative to the initial error, at
+ !! which to switch from Picard to Newton iterations in the velocity solver [nondim]
+ logical :: newton_adapt_cg_tol !< Use an adaptive CG tolerance during Newton iterations
integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver
integer :: nonlin_solve_err_mode !< 1: exit vel solve based on nonlin residual
!! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm
@@ -224,6 +249,8 @@ module MOM_ice_shelf_dynamics
logical :: debug !< If true, write verbose checksums for debugging purposes
!! and use reproducible sums
+ logical :: doing_newton = .false. !< If true, the outer iteration is using Newton (tangent) linearization
+ !! instead of Picard (secant) linearization for the ice viscosity
logical :: module_is_initialized = .false. !< True if this module has been initialized.
!>@{ Diagnostic handles
@@ -250,9 +277,10 @@ module MOM_ice_shelf_dynamics
!> A container for loop bounds
type :: loop_bounds_type ; private
- !>@{ Loop bounds
- integer :: ish, ieh, jsh, jeh
- !>@}
+ integer :: ish !< Starting i-index of the computational domain [nondim]
+ integer :: ieh !< Ending i-index of the computational domain [nondim]
+ integer :: jsh !< Starting j-index of the computational domain [nondim]
+ integer :: jeh !< Ending j-index of the computational domain [nondim]
end type loop_bounds_type
contains
@@ -357,6 +385,13 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS)
allocate(CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0)
allocate(CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing) ! [C ~> degC]
allocate(CS%ice_visc(isd:ied,jsd:jed,CS%visc_qps), source=0.0)
+ allocate(CS%newton_visc_factor(isd:ied,jsd:jed,CS%visc_qps), source=0.0)
+ allocate(CS%newton_str_ux(isd:ied,jsd:jed,CS%visc_qps), source=0.0)
+ allocate(CS%newton_str_vy(isd:ied,jsd:jed,CS%visc_qps), source=0.0)
+ allocate(CS%newton_str_sh(isd:ied,jsd:jed,CS%visc_qps), source=0.0)
+ allocate(CS%newton_umid(isd:ied,jsd:jed), source=0.0)
+ allocate(CS%newton_vmid(isd:ied,jsd:jed), source=0.0)
+ allocate(CS%newton_drag_coef(isd:ied,jsd:jed), source=0.0)
allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1]
allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R Z L2 T-1 ~> kg s-1]
allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10*US%Pa_to_RLZ_T2)
@@ -438,6 +473,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_
character(len=40) :: var_name
character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name.
logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics
+ logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
+ ! recreate the bugs, or if false bugs are only used if actively selected.
logical :: debug
integer :: i, j, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters
character(len=200) :: IS_energyfile ! The name of the energy file.
@@ -549,8 +586,15 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_
"A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, &
"tolerance in CG solver, relative to initial residual", units="nondim", default=1.e-6)
+ CS%cg_tol_newton = CS%cg_tolerance ! Will be tightened adaptively during Newton iterations
call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, &
"nonlin tolerance in iterative velocity solve", units="nondim", default=1.e-6)
+ call get_param(param_file, mdl, "NEWTON_AFTER_TOLERANCE", CS%newton_after_tolerance, &
+ "Switch from Picard to Newton iterations in the nonlinear ice velocity solve when "//&
+ "the fractional nonlinear residual falls below this tolerance.",&
+ units="none", default=CS%nonlinear_tolerance)
+ call get_param(param_file, mdl, "NEWTON_ADAPT_CG_TOL", CS%newton_adapt_cg_tol, &
+ "Use an adaptive CG tolerance during Newton iterations.", default=.true.)
call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, &
"max iteratiions in CG solver", default=2000)
call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, &
@@ -577,11 +621,18 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_
" If true, the domain is meridionally reentrant.", &
default=.false.)
call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, &
- "If MODEL, compute ice viscosity internally using 1 or 4 quadrature points,"//&
- "if OBS read from a file,"//&
+ "If MODEL, compute ice viscosity internally using 1 or 4 quadrature points, "//&
+ "if OBS read from a file, "//&
"if CONSTANT a constant value (for debugging).", &
default="MODEL")
+ call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
+ default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
+ call get_param(param_file, mdl, "ICE_SHELF_TOP_SLOPE_BUG", CS%shelf_top_slope_bugs, &
+ "If true, use directionally inconsistent estimates of the grid spacing when "//&
+ "calculating the ice shelf surface slope, and underestimate slopes near the "//&
+ "edge of the ice shelf by a factor of 2.", default=enable_bugs)
+
if ((CS%visc_qps/=1) .and. (trim(CS%ice_viscosity_compute) /= "MODEL")) then
call MOM_error(FATAL, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS must be 1 unless ICE_VISCOSITY_COMPUTE==MODEL.")
endif
@@ -659,7 +710,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_
allocate(CS%Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0)
do j=G%jsd,G%jed ; do i=G%isd,G%ied
call bilinear_shape_fn_grid(G, i, j, CS%Phi(:,:,i,j))
- enddo; enddo
+ enddo ; enddo
if (CS%GL_regularize) then
allocate(CS%Phisub(2,2,CS%n_sub_regularize,CS%n_sub_regularize,2,2), source=0.0)
@@ -671,7 +722,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_
allocate(CS%PhiC(1:8,G%isc:G%iec,G%jsc:G%jec), source=0.0)
do j=G%jsc,G%jec ; do i=G%isc,G%iec
call bilinear_shape_fn_grid_1qp(G, i, j, CS%PhiC(:,i,j))
- enddo; enddo
+ enddo ; enddo
endif
CS%elapsed_velocity_time = 0.0
@@ -820,11 +871,11 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_
'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa)
CS%id_taud_shelf = register_diag_field('ice_shelf_model','taud_shelf',CS%diag%axesB1, Time, &
'magnitude of driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa)
- CS%id_sx_shelf = register_diag_field('ice_shelf_model','sx_shelf',CS%diag%axesB1, Time, &
+ CS%id_sx_shelf = register_diag_field('ice_shelf_model', 'sx_shelf', CS%diag%axesT1, Time, &
'x-surface slope of ice', 'none')
- CS%id_sy_shelf = register_diag_field('ice_shelf_model','sy_shelf',CS%diag%axesB1, Time, &
+ CS%id_sy_shelf = register_diag_field('ice_shelf_model', 'sy_shelf', CS%diag%axesT1, Time, &
'y-surface slope of ice', 'none')
- CS%id_surf_slope_mag_shelf = register_diag_field('ice_shelf_model','surf_slope_mag_shelf', CS%diag%axesB1, Time, &
+ CS%id_surf_slope_mag_shelf = register_diag_field('ice_shelf_model', 'surf_slope_mag_shelf', CS%diag%axesT1, Time, &
'magnitude of surface slope of ice', 'none')
CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesB1, Time, &
'mask for u-nodes', 'none')
@@ -1034,19 +1085,19 @@ subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere)
mask(:,:)=0
if (IS_ID==0) then !Antarctica (S. Hemisphere) only
- do j = js,je; do i = is,ie
+ do j = js,je ; do i = is,ie
if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)<=0.0) mask(i,j)=1
- enddo; enddo
+ enddo ; enddo
elseif (IS_ID==1) then !Greenland (N. Hemisphere) only
- do j = js,je; do i = is,ie
+ do j = js,je ; do i = is,ie
if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)>0.0) mask(i,j)=1
- enddo; enddo
+ enddo ; enddo
else !All ice sheets
mask(is:ie,js:je)=ISS%hmask(is:ie,js:je)
endif
vaf_cell(:,:)=0.0
- do j = js,je; do i = is,ie
+ do j = js,je ; do i = is,ie
if (mask(i,j)>0) then
if (CS%bed_elev(i,j) <= 0) then
!grounded above sea level
@@ -1056,7 +1107,7 @@ subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere)
vaf_cell(i,j) = max(ISS%h_shelf(i,j) - rhow_rhoi * CS%bed_elev(i,j), 0.0) * ISS%area_shelf_h(i,j)
endif
endif
- enddo; enddo
+ enddo ; enddo
vaf = reproducing_sum(vaf_cell, unscale=G%US%Z_to_m*G%US%L_to_m**2)
end subroutine volume_above_floatation
@@ -1067,10 +1118,10 @@ subroutine masked_var_grounded(G,CS,var,varout)
type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure
real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< variable in
real, dimension(SZI_(G),SZJ_(G)), intent(out) :: varout ! Ice shelf dynamics post_data calls
@@ -1085,11 +1136,12 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, ISS, G)
real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged vertically integrated ice viscosity
!! [R L2 Z T-1 ~> Pa s m]
real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr ! area-averaged taub_beta field related to basal traction,
- !! [R L1 T-1 ~> Pa s m-1]
- real, dimension(SZDIB_(G),SZDJB_(G)) :: surf_slope ! the surface slope of the ice shelf/sheet [nondim]
+ !! [R L T-1 ~> Pa s m-1]
+ real, dimension(SZDI_(G),SZDJ_(G)) :: surf_slope ! the surface slope of the ice shelf/sheet [nondim]
real, dimension(SZDIB_(G),SZDJB_(G)) :: ice_speed ! ice sheet flow speed [L T-1 ~> m s-1]
- integer :: i,j
+ integer :: i, j
+
call enable_averages(time_step, Time, CS%diag)
if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag)
if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag)
@@ -1122,8 +1174,8 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, ISS, G)
if (CS%id_sx_shelf > 0) call post_data(CS%id_sx_shelf, CS%sx_shelf, CS%diag)
if (CS%id_sy_shelf > 0) call post_data(CS%id_sy_shelf, CS%sy_shelf, CS%diag)
if (CS%id_surf_slope_mag_shelf > 0) then
- do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB
- surf_slope(I,J) = sqrt((CS%sx_shelf(I,J)**2)+(CS%sy_shelf(I,J)**2))
+ do j=G%jsc,G%jec ; do i=G%isc,G%iec
+ surf_slope(i,j) = sqrt((CS%sx_shelf(i,j)**2)+(CS%sy_shelf(i,j)**2))
enddo ; enddo
call post_data(CS%id_surf_slope_mag_shelf, surf_slope, CS%diag)
endif
@@ -1249,7 +1301,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step)
tmp1(i,j) = 0.03125 * (mass(i,j) * area(i,j)) * &
((((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2) + &
(((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2))
- enddo; enddo
+ enddo ; enddo
KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, unscale=(US%RZL2_to_kg*US%L_T_to_m_s**2))
@@ -1257,7 +1309,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step)
tmp1(:,:) = 0.0
do j=js,je ; do i=is,ie
tmp1(i,j) = mass(i,j) * area(i,j)
- enddo; enddo
+ enddo ; enddo
mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, unscale=US%RZL2_to_kg)
@@ -1299,10 +1351,8 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step)
elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday
else ; write(day_str, '(ES15.9)') reday ; endif
- if (CS%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') CS%prev_IS_energy_calls
- elseif (CS%prev_IS_energy_calls < 10000000) then ; write(n_str, '(I7)') CS%prev_IS_energy_calls
- elseif (CS%prev_IS_energy_calls < 100000000) then ; write(n_str, '(I8)') CS%prev_IS_energy_calls
- else ; write(n_str, '(I10)') CS%prev_IS_energy_calls ; endif
+ if (CS%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') CS%prev_IS_energy_calls
+ else ; write(n_str, '(I0)') CS%prev_IS_energy_calls ; endif
write(CS%IS_fileenergy_ascii,'(A,",",A,", En ",ES22.16,", M ",ES11.5)') &
trim(n_str), trim(day_str), US%L_T_to_m_s**2*KE_tot/mass_tot, US%RZL2_to_kg*mass_tot
@@ -1395,23 +1445,23 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs)
call shelf_advance_front(CS, ISS, G, ISS%hmask, uh_ice, vh_ice)
!add mass of the partially-filled cells to calving field, which is used to initialize icebergs
!Then, remove the partially-filled cells from the ice shelf
- ISS%calving(:,:)=0.0
- ISS%calving_hflx(:,:)=0.0
- do j=jsc,jec; do i=isc,iec
+ ISS%calving(:,:) = 0.0
+ ISS%calving_hflx(:,:) = 0.0
+ do j=jsc,jec ; do i=isc,iec
if (ISS%hmask(i,j)==2) then
ISS%calving(i,j) = (ISS%h_shelf(i,j) * CS%density_ice) * &
(ISS%area_shelf_h(i,j) * G%IareaT(i,j)) / time_step
ISS%calving_hflx(i,j) = (CS%Cp_ice * CS%t_shelf(i,j)) * &
((ISS%h_shelf(i,j) * CS%density_ice) * &
(ISS%area_shelf_h(i,j) * G%IareaT(i,j)))
- ISS%h_shelf(i,j) = 0.0; ISS%area_shelf_h(i,j) = 0.0; ISS%hmask(i,j) = 0.0
+ ISS%h_shelf(i,j) = 0.0 ; ISS%area_shelf_h(i,j) = 0.0 ; ISS%hmask(i,j) = 0.0
endif
- enddo; enddo
+ enddo ; enddo
endif
- do j=jsc,jec; do i=isc,iec
+ do j=jsc,jec ; do i=isc,iec
ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice
- enddo; enddo
+ enddo ; enddo
call pass_var(ISS%mass_shelf, G%domain, complete=.false.)
call pass_var(ISS%h_shelf, G%domain, complete=.false.)
@@ -1454,6 +1504,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i
integer :: Isdq, Iedq, Jsdq, Jedq, isd, ied, jsd, jed
integer :: Iscq, Iecq, Jscq, Jecq, isc, iec, jsc, jec
real :: err_max, err_tempu, err_tempv, err_init ! Errors in [R L3 Z T-2 ~> kg m s-2] or [L T-1 ~> m s-1]
+ real :: ew_prev_err ! Previous outer residual for Eisenstat-Walker CG tolerance (same units as err_max)
real :: max_vel ! The maximum velocity magnitude [L T-1 ~> m s-1]
real :: tempu, tempv ! Temporary variables with velocity magnitudes [L T-1 ~> m s-1]
real :: Norm, PrevNorm ! Velocities used to assess convergence [L T-1 ~> m s-1]
@@ -1538,7 +1589,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i
call CG_action(CS, Au, Av, u_shlf, v_shlf, CS%Phi, CS%Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, &
CS%ice_visc, CS%float_cond, CS%bed_elev, CS%basal_traction, &
- G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow)
+ G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow, use_newton_in=.false.)
call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE)
err_init = 0 ; err_tempu = 0 ; err_tempv = 0
@@ -1579,6 +1630,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i
endif
u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:)
+ CS%cg_tol_newton = CS%cg_tolerance
+ ew_prev_err = err_init
!! begin loop
@@ -1598,7 +1651,12 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i
call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf)
call pass_var(CS%basal_traction, G%domain, complete=.true.)
call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf)
- call pass_var(CS%ice_visc, G%domain)
+ call pass_var(CS%ice_visc, G%domain, complete=.false.)
+ call pass_var(CS%newton_str_sh, G%domain, complete=.false.)
+ call pass_var(CS%newton_visc_factor, G%domain, complete=.true.)
+ call pass_var(CS%newton_drag_coef, G%domain)
+ call pass_vector(CS%newton_str_ux, CS%newton_str_vy, G%domain, TO_ALL, AGRID)
+ call pass_vector(CS%newton_umid, CS%newton_vmid, G%domain, TO_ALL, AGRID)
! makes sure basal stress is only applied when it is supposed to be
if (CS%GL_regularize) then
@@ -1617,7 +1675,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i
call CG_action(CS, Au, Av, u_shlf, v_shlf, CS%Phi, CS%Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, &
CS%ice_visc, CS%float_cond, CS%bed_elev, CS%basal_traction, &
- G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow)
+ G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow, use_newton_in=.false.)
call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE)
@@ -1667,7 +1725,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i
do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq
if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)**2
if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)**2
- enddo; enddo
+ enddo ; enddo
Norm = sqrt( reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, unscale=US%L_T_to_m_s**2 ) )
err_max = 2.*abs(Norm-PrevNorm) ; err_init = Norm+PrevNorm
endif
@@ -1675,11 +1733,30 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i
write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init
call MOM_mesg(mesg, 5)
+ if (err_max <= CS%newton_after_tolerance * err_init .and. .not. CS%doing_newton) then
+ CS%doing_newton = .true.
+ ew_prev_err = err_max ! seed Eisenstat-Walker with residual at the Newton switch point
+ write(mesg,*) "ice_shelf_solve_outer: switching to Newton iterations at iter = ", iter
+ call MOM_mesg(mesg, 5)
+ endif
+
+ ! Eisenstat-Walker Choice II (Eisenstat & Walker 1994): η_k = γ*(||F_k||/||F_{k-1}||)^α
+ ! with γ=0.9, α=2. Uses the ratio of consecutive outer residuals so that the CG
+ ! tolerance scales linearly with the current error (enabling quadratic outer convergence)
+ ! without over-tightening at later Newton steps. The first Newton step uses the standard
+ ! cg_tolerance (ratio = 1 on entry).
+ if (CS%doing_newton .and. CS%newton_adapt_cg_tol) then
+ CS%cg_tol_newton = min(CS%cg_tolerance, 0.9 * (err_max / ew_prev_err)**2)
+ ew_prev_err = err_max
+ endif
+
if (err_max <= CS%nonlinear_tolerance * err_init) then
exit
endif
enddo
+ CS%doing_newton = .false.
+ CS%cg_tol_newton = CS%cg_tolerance
write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init
call MOM_mesg(mesg)
@@ -1740,15 +1817,24 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H
RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2]
Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2]
Du, Dv, & ! Velocity changes [L T-1 ~> m s-1]
- sum_vec, sum_vec_2, sum_vec_3 !, &
- !ubd, vbd ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2]
- real :: beta_k, dot_p1, resid0tol2, cg_halo, max_cg_halo
+ sum_vec ! Sum of squares of residuals in stress calculations [m2 kg2 s-4]
+ real, dimension(SZDIB_(G),SZDJB_(G),3) :: sum_vec_3d ! Array used for various residuals
+ ! sum_vec_3d(:,:,1:2) [m s-1] [m kg s-2]
+ ! sum_vec_3d(:,:,3) [m2 kg2 s-4]
+ real :: beta_k ! Ratio of residuals used to update search direction [nondim]
+ real :: resid0tol2 ! Convergence tolerance times the initial residual [m2 kg2 s-4]
+ real :: sv3dsum ! An unused variable returned when taking global sum of residuals [various]
+ real :: sv3dsums(3) ! The index-wise global sums of sum_vec_3d
+ ! sv3dsums(:,:,1:2) [m s-1] [m kg s-2]
+ ! sv3dsums(:,:,3) [m2 kg2 s-4]
real :: alpha_k ! A scaling factor for iterative corrections [nondim]
- real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1]
- ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2]
+ real :: resid_scale ! A scaling factor for redimensionalizing the global residuals
+ ! [L T-1 ~> m s-1] [R L3 Z T-2 ~> m kg s-2]
real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals
- ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2]
+ ! [R2 L6 Z2 T-4 ~> m2 kg2 s-4]
real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim]
+ integer :: cg_halo ! Number of halo vertices to include during a CG iteration
+ integer :: max_cg_halo ! Maximum possible number of halo vertices to include in the CG iterations
integer :: iter, i, j, isd, ied, jsd, jed, isc, iec, jsc, jec, is, js, ie, je
integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1.
integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq, nx_halo, ny_halo
@@ -1765,7 +1851,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H
Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0
Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 ; RHSu(:,:) = 0 ; RHSv(:,:) = 0
Du(:,:) = 0 ; Dv(:,:) = 0
- dot_p1 = 0
! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1.
! Includes the edge of the tile is at the western/southern bdry (if symmetric)
@@ -1792,7 +1877,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H
call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, &
H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, &
- G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow)
+ G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow, use_newton_in=.false.)
call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.)
@@ -1807,7 +1892,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H
enddo ; enddo
!resid0 = sqrt(reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ))
- resid0tol2 = CS%cg_tolerance**2 * reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum )
+ resid0tol2 = CS%cg_tol_newton**2 * reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum )
do J=Jsdq,Jedq ; do I=Isdq,Iedq
if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J)
@@ -1850,23 +1935,24 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H
call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE)
- sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0
+ sum_vec_3d(:,:,1:2) = 0.0
do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq
if (CS%umask(I,J) == 1) then
- sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J))
- sum_vec_2(I,J) = resid_scale * (Du(I,J) * Au(I,J))
+ sum_vec_3d(I,J,1) = resid_scale * (Zu(I,J) * Ru(I,J))
+ sum_vec_3d(I,J,2) = resid_scale * (Du(I,J) * Au(I,J))
Ru_old(I,J) = Ru(I,J) ; Zu_old(I,J) = Zu(I,J)
endif
if (CS%vmask(I,J) == 1) then
- sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J))
- sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Dv(I,J) * Av(I,J))
+ sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid_scale * (Zv(I,J) * Rv(I,J))
+ sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid_scale * (Dv(I,J) * Av(I,J))
Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J)
endif
enddo ; enddo
- alpha_k = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / &
- reproducing_sum( sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum )
+ sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) )
+
+ alpha_k = sv3dsums(1)/sv3dsums(2)
do J=js,je-1 ; do I=is,ie-1
if (CS%umask(I,J) == 1) then
@@ -1879,29 +1965,30 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H
Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J)
if (DIAGv(I,J)/=0) Zv(I,J) = Rv(I,J) / DIAGv(I,J)
endif
- enddo; enddo
+ enddo ; enddo
! R,u,v,Z valid region moves in by 1
! beta_k = (Z \dot R) / (Zold \dot Rold)
- sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 ; sum_vec_3(:,:) = 0.0
+ sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(:) = 0.0
do J=jscq_sv,jecq ; do i=iscq_sv,iecq
if (CS%umask(I,J) == 1) then
- sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J))
- sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J))
- sum_vec_3(I,J) = resid2_scale * Ru(I,J)**2
+ sum_vec_3d(I,J,1) = resid_scale * (Zu(I,J) * Ru(I,J))
+ sum_vec_3d(I,J,2) = resid_scale * (Zu_old(I,J) * Ru_old(I,J))
+ sum_vec_3d(I,J,3) = resid2_scale * Ru(I,J)**2
endif
if (CS%vmask(I,J) == 1) then
- sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J))
- sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J))
- sum_vec_3(I,J) = sum_vec_3(I,J) + resid2_scale * Rv(I,J)**2
+ sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid_scale * (Zv(I,J) * Rv(I,J))
+ sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid_scale * (Zv_old(I,J) * Rv_old(I,J))
+ sum_vec_3d(I,J,3) = sum_vec_3d(I,J,3) + resid2_scale * Rv(I,J)**2
endif
enddo ; enddo
- beta_k = reproducing_sum(sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / &
- reproducing_sum(sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum )
+ sv3dsum = reproducing_sum( sum_vec_3d, Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums )
+
+ beta_k = sv3dsums(1)/sv3dsums(2)
do J=js,je-1 ; do I=is,ie-1
if (CS%umask(I,J) == 1) Du(I,J) = Zu(I,J) + beta_k * Du(I,J)
@@ -1910,10 +1997,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H
! D valid region moves in by 1
- dot_p1 = reproducing_sum( sum_vec_3, Is_sum, Ie_sum, Js_sum, Je_sum )
-
- !if sqrt(dot_p1) <= (CS%cg_tolerance * resid0)
- if (dot_p1 <= resid0tol2) then
+ !if sqrt(sv3dsums(3)) <= (CS%cg_tolerance * resid0)
+ if (sv3dsums(3) <= resid0tol2) then
iters = iter
conv_flag = 1
exit
@@ -2405,13 +2490,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD)
real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S ! surface elevation [Z ~> m].
real, dimension(SZDI_(G),SZDJ_(G)) :: sx_e, sy_e !element contributions to driving stress
real :: rho, rhow, rhoi_rhow ! Ice and ocean densities [R ~> kg m-3]
- real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> nondim]
+ real :: sx, sy ! Ice shelf top slopes at tracer points [Z L-1 ~> nondim]
real :: neumann_val ! [R Z L2 T-2 ~> kg s-2]
- real :: dxh, dyh,Dx,Dy ! Local grid spacing [L ~> m]
real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]
real :: scale ! Scaling factor used to ensure surface slope magnitude does not exceed CS%max_surface_slope
+ logical :: valid_N, valid_S, valid_E, valid_W
integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, is, js, iegq, jegq
- integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec
+ integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec
integer :: i_off, j_off
isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec
@@ -2422,7 +2507,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD)
gisc = 1 ; gjsc = 1
! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo
giec = G%domain%niglobal ; gjec = G%domain%njglobal
-! is = iscq - 1; js = jscq - 1
+! is = iscq - 1 ; js = jscq - 1
i_off = G%idg_offset ; j_off = G%jdg_offset
@@ -2433,115 +2518,95 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD)
! prelim - go through and calculate S
if (CS%GL_couple) then
- do j=jsc-G%domain%njhalo,jec+G%domain%njhalo
- do i=isc-G%domain%nihalo,iec+G%domain%nihalo
- S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + max(ISS%h_shelf(i,j),CS%min_h_shelf))
- enddo
- enddo
+ do j=jsc-2,jec+2 ; do i=isc-2,iec+2
+ S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + max(ISS%h_shelf(i,j),CS%min_h_shelf))
+ enddo ; enddo
else
! check whether the ice is floating or grounded
- do j=jsc-G%domain%njhalo,jec+G%domain%njhalo
- do i=isc-G%domain%nihalo,iec+G%domain%nihalo
- if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) <= 0) then
- S(i,j) = (1 - rhoi_rhow)*max(ISS%h_shelf(i,j),CS%min_h_shelf)
- else
- S(i,j) = max(ISS%h_shelf(i,j),CS%min_h_shelf)-CS%bed_elev(i,j)
- endif
- enddo
- enddo
+ do j=jsc-2,jec+2 ; do i=isc-2,iec+2
+ if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) <= 0) then
+ S(i,j) = (1 - rhoi_rhow)*max(ISS%h_shelf(i,j),CS%min_h_shelf)
+ else
+ S(i,j) = max(ISS%h_shelf(i,j),CS%min_h_shelf)-CS%bed_elev(i,j)
+ endif
+ enddo ; enddo
endif
call pass_var(S, G%domain)
- sx_e(:,:)=0.0; sy_e(:,:)=0.0
-
do j=jsc-1,jec+1
do i=isc-1,iec+1
- cnt = 0
- sx = 0
- sy = 0
- dxh = G%dxT(i,j)
- dyh = G%dyT(i,j)
- Dx=dxh
- Dy=dyh
+
if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then
! we are inside the global computational bdry, at an ice-filled cell
- ! calculate sx
- if (((i+i_off) == gisc) .and. (.not. CS%reentrant_x)) then ! at west computational bdry
- if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then
- sx = (S(i+1,j)-S(i,j))/dxh
- else
- sx = 0
- endif
- elseif (((i+i_off) == giec) .and. (.not. CS%reentrant_x)) then ! at east computational bdry
- if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then
- sx = (S(i,j)-S(i-1,j))/dxh
- else
- sx = 0
- endif
- else ! interior
- if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then
- cnt = cnt+1
- Dx = dxh + G%dxT(i+1,j)
- sx = S(i+1,j)
- else
- sx = S(i,j)
- endif
- if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then
- cnt = cnt+1
- Dx = dxh + G%dxT(i-1,j)
- sx = sx - S(i-1,j)
- else
- sx = sx - S(i,j)
+ ! Calculate the x-direction surface slope at tracer points.
+ sx = 0.0
+ valid_E = (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3)
+ valid_W = (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3)
+ if (CS%shelf_top_slope_bugs) then
+ if (((i+i_off) == gisc) .and. (.not.CS%reentrant_x)) then ! at west computational bdry
+ if (valid_E) sx = (S(i+1,j)-S(i,j)) / G%dxT(i,j)
+ elseif (((i+i_off) == giec) .and. (.not.CS%reentrant_x)) then ! at east computational bdry
+ if (valid_W) sx = (S(i,j)-S(i-1,j)) / G%dxT(i,j)
+ elseif (valid_E .and. valid_W) then
+ ! This is the usual interior point
+ sx = (S(i+1,j) - S(i-1,j)) / (G%dxT(i,j) + G%dxT(i-1,j))
+ elseif (valid_E) then
+ sx = (S(i+1,j) - S(i,j)) / (G%dxT(i,j) + G%dxT(i+1,j))
+ elseif (valid_W) then
+ sx = (S(i,j) - S(i-1,j)) / (G%dxT(i,j) + G%dxT(i-1,j))
endif
- if (cnt == 0) then
- sx = 0
- else
- sx = sx / Dx
+ else ! Correct the bugs in the version above.
+ if (((i+i_off) == gisc) .and. (.not.CS%reentrant_x)) then ! at west computational bdry
+ if (valid_E) sx = (S(i+1,j) - S(i,j)) * G%IdxCu(I,j)
+ elseif (((i+i_off) == giec) .and. (.not.CS%reentrant_x)) then ! at east computational bdry
+ if (valid_W) sx = (S(i,j) - S(i-1,j)) * G%IdxCu(I-1,j)
+ elseif (valid_E .and. valid_W) then
+ ! This is the usual interior point
+ sx = 0.5*(S(i+1,j) - S(i-1,j)) * G%IdxT(i,j)
+ elseif (valid_E) then ! Use a one-sided estimate from the east.
+ sx = (S(i+1,j) - S(i,j)) * G%IdxCu(I,j)
+ elseif (valid_W) then ! Use a one-sided estimate from the west.
+ sx = (S(i,j) - S(i-1,j)) * G%IdxCu(I-1,j)
endif
endif
- cnt = 0
-
- ! calculate sy, similarly
- if (((j+j_off) == gjsc) .and. (.not. CS%reentrant_y)) then ! at south computational bdry
- if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then
- sy = (S(i,j+1)-S(i,j))/dyh
- else
- sy = 0
+ ! Calculate the y-direction surface slope at tracer points.
+ sy = 0.0
+ valid_N = (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3)
+ valid_S = (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3)
+ if (CS%shelf_top_slope_bugs) then
+ if (((j+j_off) == gjsc) .and. (.not. CS%reentrant_y)) then ! at south computational bdry
+ if (valid_N) sy = (S(i,j+1)-S(i,j)) / G%dyT(i,j)
+ elseif (((j+j_off) == gjec) .and. (.not. CS%reentrant_y)) then ! at north computational bdry
+ if (valid_S) sy = (S(i,j)-S(i,j-1)) / G%dyT(i,j)
+ elseif (valid_N .and. valid_S) then
+ ! This is the usual interior point
+ sy = (S(i,j+1) - S(i,j-1)) / (G%dyT(i,j) + G%dyT(i,j-1))
+ elseif (valid_N) then
+ sy = (S(i,j+1) - S(i,j)) / (G%dyT(i,j) + G%dyT(i,j+1))
+ elseif (valid_S) then
+ sy = (S(i,j) - S(i,j-1)) / (G%dyT(i,j) + G%dyT(i,j-1))
endif
- elseif (((j+j_off) == gjec) .and. (.not. CS%reentrant_y)) then ! at north computational bdry
- if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then
- sy = (S(i,j)-S(i,j-1))/dyh
- else
- sy = 0
- endif
- else ! interior
- if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then
- cnt = cnt+1
- Dy = dyh + G%dyT(i,j+1)
- sy = S(i,j+1)
- else
- sy = S(i,j)
- endif
- if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then
- cnt = cnt+1
- Dy = dyh + G%dyT(i,j-1)
- sy = sy - S(i,j-1)
- else
- sy = sy - S(i,j)
- endif
- if (cnt == 0) then
- sy = 0
- else
- sy = sy / Dy
+ else ! Correct the bugs in the version above.
+ if (((j+j_off) == gjsc) .and. (.not. CS%reentrant_y)) then ! at south computational bdry
+ if (valid_N) sy = (S(i,j+1) - S(i,j)) * G%IdyCv(i,J)
+ elseif (((j+j_off) == gjec) .and. (.not. CS%reentrant_y)) then ! at north computational bdry
+ if (valid_S) sy = (S(i,j) - S(i,j-1)) * G%IdyCv(i,J-1)
+ elseif (valid_N .and. valid_S) then
+ ! This is the usual interior point
+ sy = 0.5*(S(i,j+1) - S(i,j-1)) * G%IdyT(i,j)
+ elseif (valid_N) then ! Use a one-sided estimate from the north.
+ sy = (S(i,j+1) - S(i,j)) * G%IdyCv(i,J)
+ elseif (valid_S) then ! Use a one-sided estimate from the south.
+ sy = (S(i,j) - S(i,j-1)) * G%IdyCv(i,J-1)
endif
endif
if (CS%max_surface_slope>0) then
- scale = min(CS%max_surface_slope/sqrt((sx**2)+(sy**2)),1.0)
- sx = scale*sx; sy = scale*sy
+ scale = CS%max_surface_slope / max( sqrt((sx**2) + (sy**2)), CS%max_surface_slope )
+ sx = scale*sx ; sy = scale*sy
endif
sx_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) * sx))
@@ -2566,42 +2631,46 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD)
! is not above the base of the ice in the current cell
! Note the negative sign due to the direction of the normal vector
- taudx(I-1,J-1) = taudx(I-1,J-1) - .5 * dyh * neumann_val
- taudx(I-1,J) = taudx(I-1,J) - .5 * dyh * neumann_val
+ taudx(I-1,J-1) = taudx(I-1,J-1) - .5 * G%dyT(i,j) * neumann_val
+ taudx(I-1,J) = taudx(I-1,J) - .5 * G%dyT(i,j) * neumann_val
endif
if ((CS%u_face_mask_bdry(I,j) == 2) .OR. &
((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (CS%reentrant_x .OR. (i+i_off /= giec)))) then
! east face of the cell is at a stress boundary
- taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val
- taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val
+ taudx(I,J-1) = taudx(I,J-1) + .5 * G%dyT(i,j) * neumann_val
+ taudx(I,J) = taudx(I,J) + .5 * G%dyT(i,j) * neumann_val
endif
if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. &
((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (CS%reentrant_y .OR. (j+j_off /= gjsc)))) then
! south face of the cell is at a stress boundary
- taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val
- taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val
+ taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * G%dxT(i,j) * neumann_val
+ taudy(I,J-1) = taudy(I,J-1) - .5 * G%dxT(i,j) * neumann_val
endif
if ((CS%v_face_mask_bdry(i,J) == 2) .OR. &
((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (CS%reentrant_y .OR. (j+j_off /= gjec)))) then
! north face of the cell is at a stress boundary
- taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val
- taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val
+ taudy(I-1,J) = taudy(I-1,J) + .5 * G%dxT(i,j) * neumann_val
+ taudy(I,J) = taudy(I,J) + .5 * G%dxT(i,j) * neumann_val
endif
+ else ! This is not an ice-filled cell, so zero out the slopes here
+ CS%sx_shelf(i,j) = 0.0 ; CS%sy_shelf(i,j) = 0.0
+ sx_e(i,j) = 0.0
+ sy_e(i,j) = 0.0
endif
enddo
enddo
- do J=jsc-2,jec+1; do I=isc-2,iec+1
+ do J=jsc-1,jec ; do I=isc-1,iec
taudx(I,J) = taudx(I,J) + ((sx_e(i,j)+sx_e(i+1,j+1)) + (sx_e(i+1,j)+sx_e(i,j+1)))
taudy(I,J) = taudy(I,J) + ((sy_e(i,j)+sy_e(i+1,j+1)) + (sy_e(i+1,j)+sy_e(i,j+1)))
- enddo; enddo
+ enddo ; enddo
end subroutine calc_shelf_driving_stress
subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, &
- ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio)
+ ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio, use_newton_in)
type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure
type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf.
@@ -2651,6 +2720,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask,
integer, intent(in) :: ie !< The ending i-index to work on
integer, intent(in) :: js !< The starting j-index to work on
integer, intent(in) :: je !< The ending j-index to work on
+ logical, optional, intent(in) :: use_newton_in !< If present, overrides CS%doing_newton for Newton correction
! the linear action of the matrix on (u,v) with bilinear finite elements
! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced,
@@ -2673,8 +2743,11 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask,
real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1]
real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1]
+ real :: strx_n, stry_n, strsh_n, dstrain_n, inner_dot_n ! Newton correction variables [T-1 ~> s-1], [T-2 ~> s-2]
integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt, qp, qpv
logical :: visc_qp4
+ logical :: use_newton ! Whether to apply Newton tangent stiffness corrections
+ logical :: do_newton_visc ! Whether to apply viscosity-related Newton tangent stiffness corrections
real, dimension(2) :: xquad ! Nondimensional quadrature ratios [nondim]
real, dimension(2,2) :: Ucell, Vcell, Usub, Vsub ! Velocities at the nodal points around the cell [L T-1 ~> m s-1]
real, dimension(2,2) :: Hcell ! Ice shelf thickness at notal (corner) points [Z ~> m]
@@ -2690,12 +2763,16 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask,
qpv = 1
endif
- uret(:,:) = 0.0; vret(:,:)=0.0
- uret_b(:,:,:)=0.0 ; vret_b(:,:,:)=0.0
+ use_newton = CS%doing_newton
+ if (present(use_newton_in)) use_newton = use_newton_in
+ do_newton_visc = use_newton .and. trim(CS%ice_viscosity_compute) == "MODEL"
+
+ uret(:,:) = 0.0 ; vret(:,:) = 0.0
+ uret_b(:,:,:) = 0.0 ; vret_b(:,:,:) = 0.0
do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then
- uret_qp(:,:,:)=0.0; vret_qp(:,:,:)=0.0
+ uret_qp(:,:,:) = 0.0 ; vret_qp(:,:,:) = 0.0
do iq=1,2 ; do jq=1,2
@@ -2733,6 +2810,20 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask,
if (visc_qp4) qpv = qp !current quad point for viscosity
+ ! Newton correction: compute dstrain scalar once per quadrature point
+ if (do_newton_visc) then
+ strx_n = CS%newton_str_ux(i,j,qpv)
+ stry_n = CS%newton_str_vy(i,j,qpv)
+ strsh_n = CS%newton_str_sh(i,j,qpv)
+ dstrain_n = (((2.*strx_n + stry_n)*ux) + ((2.*stry_n + strx_n)*vy)) + &
+ strsh_n * (uy + vx) * 0.5
+ endif
+
+ ! Newton correction for basal drag: compute inner_dot_n once per quadrature point
+ if (use_newton) then
+ inner_dot_n = CS%newton_umid(i,j)*uq + CS%newton_vmid(i,j)*vq
+ endif
+
do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi
if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * &
(((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
@@ -2741,6 +2832,18 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask,
(((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)))
+ ! Newton tangent stiffness correction: add (dη/dε_e^2) * (g·δε) * (g·φ_m) term
+ if (do_newton_visc) then
+ if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + &
+ CS%newton_visc_factor(i,j,qpv) * dstrain_n * &
+ ((2.*strx_n + stry_n) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + &
+ strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi),qp,i,j))
+ if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + &
+ CS%newton_visc_factor(i,j,qpv) * dstrain_n * &
+ (strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + &
+ (2.*stry_n + strx_n) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))
+ endif
+
if (float_cond(i,j) == 0) then
ilq = 1 ; if (iq == iphi) ilq = 2
jlq = 1 ; if (jq == jphi) jlq = 2
@@ -2748,6 +2851,13 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask,
((basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)))
if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + &
((basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)))
+ ! Newton basal drag tangent stiffness: (m-1)*basal_trac/|u|^2 * u_i * (u . delta_u) contribution
+ if (use_newton) then
+ if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + &
+ CS%newton_drag_coef(i,j) * CS%newton_umid(i,j) * inner_dot_n * (xquad(ilq) * xquad(jlq))
+ if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + &
+ CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j) * inner_dot_n * (xquad(ilq) * xquad(jlq))
+ endif
endif
enddo ; enddo
enddo ; enddo
@@ -2784,13 +2894,37 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask,
if (vmask(I-1,J ) == 1) vret_b(I-1,J ,2) = vret_b(I-1,J ,2) + (Vsub(1,2) * basal_trac(i,j))
if (vmask(I ,J-1) == 1) vret_b(I ,J-1,3) = vret_b(I ,J-1,3) + (Vsub(2,1) * basal_trac(i,j))
if (vmask(I ,J ) == 1) vret_b(I ,J ,1) = vret_b(I ,J ,1) + (Vsub(2,2) * basal_trac(i,j))
+
+ ! Newton basal drag correction for subgrid grounding line cells.
+ ! inner_dot_sub(m,n) = sum over grounded sub-QPs of (u^k . delta_u) * phi_{m,n} * weight
+ ! = newton_umid * Usub(m,n) + newton_vmid * Vsub(m,n)
+ ! Correction to u-node (m,n): newton_drag_coef * newton_umid * inner_dot_sub(m,n)
+ ! Correction to v-node (m,n): newton_drag_coef * newton_vmid * inner_dot_sub(m,n)
+ if (use_newton) then
+ if (umask(I-1,J-1)==1) uret_b(I-1,J-1,4) = uret_b(I-1,J-1,4) + CS%newton_drag_coef(i,j) * &
+ CS%newton_umid(i,j) * ((CS%newton_umid(i,j)*Usub(1,1)) + (CS%newton_vmid(i,j)*Vsub(1,1)))
+ if (umask(I-1,J )==1) uret_b(I-1,J ,2) = uret_b(I-1,J ,2) + CS%newton_drag_coef(i,j) * &
+ CS%newton_umid(i,j) * ((CS%newton_umid(i,j)*Usub(1,2)) + (CS%newton_vmid(i,j)*Vsub(1,2)))
+ if (umask(I ,J-1)==1) uret_b(I ,J-1,3) = uret_b(I ,J-1,3) + CS%newton_drag_coef(i,j) * &
+ CS%newton_umid(i,j) * ((CS%newton_umid(i,j)*Usub(2,1)) + (CS%newton_vmid(i,j)*Vsub(2,1)))
+ if (umask(I ,J )==1) uret_b(I ,J ,1) = uret_b(I ,J ,1) + CS%newton_drag_coef(i,j) * &
+ CS%newton_umid(i,j) * ((CS%newton_umid(i,j)*Usub(2,2)) + (CS%newton_vmid(i,j)*Vsub(2,2)))
+ if (vmask(I-1,J-1)==1) vret_b(I-1,J-1,4) = vret_b(I-1,J-1,4) + CS%newton_drag_coef(i,j) * &
+ CS%newton_vmid(i,j) * ((CS%newton_umid(i,j)*Usub(1,1)) + (CS%newton_vmid(i,j)*Vsub(1,1)))
+ if (vmask(I-1,J )==1) vret_b(I-1,J ,2) = vret_b(I-1,J ,2) + CS%newton_drag_coef(i,j) * &
+ CS%newton_vmid(i,j) * ((CS%newton_umid(i,j)*Usub(1,2)) + (CS%newton_vmid(i,j)*Vsub(1,2)))
+ if (vmask(I ,J-1)==1) vret_b(I ,J-1,3) = vret_b(I ,J-1,3) + CS%newton_drag_coef(i,j) * &
+ CS%newton_vmid(i,j) * ((CS%newton_umid(i,j)*Usub(2,1)) + (CS%newton_vmid(i,j)*Vsub(2,1)))
+ if (vmask(I ,J )==1) vret_b(I ,J ,1) = vret_b(I ,J ,1) + CS%newton_drag_coef(i,j) * &
+ CS%newton_vmid(i,j) * ((CS%newton_umid(i,j)*Usub(2,2)) + (CS%newton_vmid(i,j)*Vsub(2,2)))
+ endif
endif
endif ; enddo ; enddo
do J=js-1,je ; do I=is-1,ie
uret(I,J) = (uret_b(I,J,1)+uret_b(I,J,4)) + (uret_b(I,J,2)+uret_b(I,J,3))
vret(I,J) = (vret_b(I,J,1)+vret_b(I,J,4)) + (vret_b(I,J,2)+vret_b(I,J,3))
- enddo; enddo
+ enddo ; enddo
end subroutine CG_action
@@ -2822,9 +2956,9 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr,
nsub = size(Phisub,3)
subarea = 1.0 / (nsub**2)
- uloc_arr(:,:,:,:) = 0.0; vloc_arr(:,:,:,:)=0.0
+ uloc_arr(:,:,:,:) = 0.0 ; vloc_arr(:,:,:,:)=0.0
- do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2
+ do j=1,nsub ; do i=1,nsub ; do qy=1,2 ; do qx=1,2
hloc = ((Phisub(qx,qy,i,j,1,1)*H(1,1)) + (Phisub(qx,qy,i,j,2,2)*H(2,2))) + &
((Phisub(qx,qy,i,j,1,2)*H(1,2)) + (Phisub(qx,qy,i,j,2,1)*H(2,1)))
if (dens_ratio * hloc - bathyT > 0) then
@@ -2833,19 +2967,19 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr,
vloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * V(1,1)) + (Phisub(qx,qy,i,j,2,2) * V(2,2))) + &
((Phisub(qx,qy,i,j,1,2) * V(1,2)) + (Phisub(qx,qy,i,j,2,1) * V(2,1))))
endif
- enddo; enddo ; enddo ; enddo
+ enddo ; enddo ; enddo ; enddo
do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub
do qy=1,2 ; do qx=1,2
!calculate quadrature point contributions for the sub-cell, to each node
Ucontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * uloc_arr(qx,qy,i,j)
Vcontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * vloc_arr(qx,qy,i,j)
- enddo; enddo
+ enddo ; enddo
!calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell
Ucontr_sub(i,j,m,n) = (subarea * 0.25) * ((Ucontr_q(1,1) + Ucontr_q(2,2)) + (Ucontr_q(1,2)+Ucontr_q(2,1)))
Vcontr_sub(i,j,m,n) = (subarea * 0.25) * ((Vcontr_q(1,1) + Vcontr_q(2,2)) + (Vcontr_q(1,2)+Vcontr_q(2,1)))
- enddo; enddo ; enddo ; enddo
+ enddo ; enddo ; enddo ; enddo
!sum up the sub-cell contributions to each node
do n=1,2 ; do m=1,2
@@ -2861,11 +2995,11 @@ subroutine sum_square_matrix(sum_out, mat_in, n)
integer, intent(in) :: n !< The length and width of each matrix in mat_in
real, dimension(n,n), intent(in) :: mat_in !< The n x n matrix whose elements will be summed
real, intent(out) :: sum_out !< The sum of the elements of matrix mat_in
- integer :: s0,e0,s1,e1
+ integer :: s0, e0, s1, e1
- sum_out=0.0
+ sum_out = 0.0
- s0=1; e0=n
+ s0 = 1 ; e0 = n
!start by summing elements on outer edges of matrix
do while (s0 m-1]
real :: uq, vq
+ real :: strx_n, stry_n, strsh_n ! Newton viscosity strain rates [T-1 ~> s-1]
+ real :: dstrain_diag_u, dstrain_diag_v ! Newton viscosity diagonal correction factors [T-1 L-1 ~> s-1 m-1]
+ real :: phi_m_sq ! Squared basis function value at quadrature point [nondim]
real, dimension(2) :: xquad
real, dimension(2,2) :: Hcell, sub_ground
real, dimension(2,2,4) :: u_diag_qp, v_diag_qp
real, dimension(SZDIB_(G),SZDJB_(G),4) :: u_diag_b, v_diag_b
+ logical :: do_newton_visc ! Whether to apply viscosity-related Newton tangent stiffness corrections
logical :: visc_qp4
integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt, qp, qpv
@@ -2954,6 +3092,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac,
qpv = 1
endif
+ do_newton_visc = CS%doing_newton .and. trim(CS%ice_viscosity_compute) == "MODEL"
+
u_diag_b(:,:,:)=0.0
v_diag_b(:,:,:)=0.0
@@ -2962,17 +3102,25 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac,
! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j
! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j
- u_diag_qp(:,:,:)=0.0; v_diag_qp(:,:,:)=0.0
+ u_diag_qp(:,:,:) = 0.0 ; v_diag_qp(:,:,:) = 0.0
do iq=1,2 ; do jq=1,2
qp = 2*(jq-1)+iq !current quad point
if (visc_qp4) qpv = qp !current quad point for viscosity
+ ! Pre-compute Newton strain data for this QP (for viscosity diagonal correction)
+ if (do_newton_visc) then
+ strx_n = CS%newton_str_ux(i,j,qpv)
+ stry_n = CS%newton_str_vy(i,j,qpv)
+ strsh_n = CS%newton_str_sh(i,j,qpv)
+ endif
+
do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi
ilq = 1 ; if (iq == iphi) ilq = 2
jlq = 1 ; if (jq == jphi) jlq = 2
+ phi_m_sq = (xquad(ilq) * xquad(jlq))**2
if (CS%umask(Itgt,Jtgt) == 1) then
@@ -2985,10 +3133,24 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac,
ice_visc(i,j,qpv) * (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)))
+ ! Newton viscosity diagonal correction: newton_visc_factor * (g . grad_phi_m_u)^2
+ ! where grad_phi_m_u = [(2*strx+stry)*Phi_xm + strsh/2*Phi_ym] for u-DOF at node m
+ if (do_newton_visc) then
+ dstrain_diag_u = (2.*strx_n + stry_n) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + &
+ strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi),qp,i,j)
+ u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + &
+ CS%newton_visc_factor(i,j,qpv) * dstrain_diag_u**2
+ endif
+
if (float_cond(i,j) == 0) then
uq = xquad(ilq) * xquad(jlq)
u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + &
(basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq))
+ ! Newton basal drag diagonal correction: newton_drag_coef * (umid_i)^2 * phi_m^2
+ if (CS%doing_newton) then
+ u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + &
+ CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * phi_m_sq
+ endif
endif
endif
@@ -3003,10 +3165,23 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac,
ice_visc(i,j,qpv) * (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + &
((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)))
+ ! Newton viscosity diagonal correction for v-DOF: uses [strsh/2*Phi_xm + (2*stry+strx)*Phi_ym]
+ if (do_newton_visc) then
+ dstrain_diag_v = strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + &
+ (2.*stry_n + strx_n) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)
+ v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + &
+ CS%newton_visc_factor(i,j,qpv) * dstrain_diag_v**2
+ endif
+
if (float_cond(i,j) == 0) then
vq = xquad(ilq) * xquad(jlq)
v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + &
(basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq))
+ ! Newton basal drag diagonal correction: newton_drag_coef * (vmid_i)^2 * phi_m^2
+ if (CS%doing_newton) then
+ v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + &
+ CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * phi_m_sq
+ endif
endif
endif
enddo ; enddo
@@ -3041,6 +3216,28 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac,
if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j))
if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j))
if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j))
+
+ ! Newton basal drag diagonal correction for subgrid grounding line cells.
+ ! sub_ground(m,n) = sum over grounded sub-QPs of phi_{m,n}^2 * weight, computed by
+ ! CG_diagonal_subgrid_basal. Newton diagonal = newton_drag_coef * umid^2 * sub_ground (for u-block).
+ if (CS%doing_newton) then
+ if (CS%umask(I-1,J-1)==1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + &
+ CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * sub_ground(1,1)
+ if (CS%umask(I-1,J )==1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + &
+ CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * sub_ground(1,2)
+ if (CS%umask(I ,J-1)==1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + &
+ CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * sub_ground(2,1)
+ if (CS%umask(I ,J )==1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + &
+ CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * sub_ground(2,2)
+ if (CS%vmask(I-1,J-1)==1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + &
+ CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * sub_ground(1,1)
+ if (CS%vmask(I-1,J )==1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + &
+ CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * sub_ground(1,2)
+ if (CS%vmask(I ,J-1)==1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + &
+ CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * sub_ground(2,1)
+ if (CS%vmask(I ,J )==1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + &
+ CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * sub_ground(2,2)
+ endif
endif
endif ; enddo ; enddo
@@ -3076,11 +3273,11 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd
grnd_stat(:,:,:,:)=0
- do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2
+ do j=1,nsub ; do i=1,nsub ; do qy=1,2 ; do qx=1,2
hloc = ((Phisub(qx,qy,i,j,1,1)*H_node(1,1)) + (Phisub(qx,qy,i,j,2,2)*H_node(2,2))) + &
((Phisub(qx,qy,i,j,1,2)*H_node(1,2)) + (Phisub(qx,qy,i,j,2,1)*H_node(2,1)))
if (dens_ratio * hloc - bathyT > 0) grnd_stat(qx,qy,i,j) = 1
- enddo; enddo ; enddo ; enddo
+ enddo ; enddo ; enddo ; enddo
do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub
do qy=1,2 ; do qx = 1,2
@@ -3122,14 +3319,14 @@ subroutine IS_dynamics_post_data_2(CS, ISS, G)
allocate(CS%PhiC(1:8,G%isc:G%iec,G%jsc:G%jec), source=0.0)
do j=G%jsc,G%jec ; do i=G%isc,G%iec
call bilinear_shape_fn_grid_1qp(G, i, j, CS%PhiC(:,i,j))
- enddo; enddo
+ enddo ; enddo
endif
!Calculate flux divergence and its components
if (CS%id_duHdx > 0 .or. CS%id_dvHdy > 0 .or. CS%id_fluxdiv > 0) then
call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf)
- Hu(:,:) = 0.0; Hv(:,:) = 0.0; Hux(:,:) = 0.0 ; Hvy(:,:) = 0.0 ; flux_div(:,:) = 0.0
+ Hu(:,:) = 0.0 ; Hv(:,:) = 0.0 ; Hux(:,:) = 0.0 ; Hvy(:,:) = 0.0 ; flux_div(:,:) = 0.0
do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB
if (CS%umask(I,J) > 0) then
Hu(I,J) = (H_node(I,J) * CS%u_shelf(I,J))
@@ -3137,7 +3334,7 @@ subroutine IS_dynamics_post_data_2(CS, ISS, G)
if (CS%vmask(I,J) > 0) then
Hv(I,J) = (H_node(I,J) * CS%v_shelf(I,J))
endif
- enddo; enddo
+ enddo ; enddo
do j=G%jsc,G%jec ; do i=G%isc,G%iec
if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 3)) then
@@ -3211,7 +3408,7 @@ subroutine IS_dynamics_post_data_2(CS, ISS, G)
dev_stress(i,j,2) = 2*ice_visc(i,j)*strain_rate(i,j,2)/ISS%h_shelf(i,j) !deviatoric stress yy
dev_stress(i,j,3) = 2*ice_visc(i,j)*strain_rate(i,j,3)/ISS%h_shelf(i,j) !deviatoric stress xy
endif
- enddo; enddo
+ enddo ; enddo
if (CS%id_devstress_xx > 0) call post_data(CS%id_devstress_xx, dev_stress(:,:,1), CS%diag)
if (CS%id_devstress_yy > 0) call post_data(CS%id_devstress_yy, dev_stress(:,:,2), CS%diag)
if (CS%id_devstress_xy > 0) call post_data(CS%id_devstress_xy, dev_stress(:,:,3), CS%diag)
@@ -3224,7 +3421,7 @@ subroutine IS_dynamics_post_data_2(CS, ISS, G)
p_dev_stress(i,j,1) = 2*ice_visc(i,j)*p_strain_rate(i,j,1)/ISS%h_shelf(i,j) !max horiz principal dev stress
p_dev_stress(i,j,2) = 2*ice_visc(i,j)*p_strain_rate(i,j,2)/ISS%h_shelf(i,j) !min horiz principal dev stress
endif
- enddo; enddo
+ enddo ; enddo
if (CS%id_pdevstress_1 > 0) call post_data(CS%id_pdevstress_1, p_dev_stress(:,:,1), CS%diag)
if (CS%id_pdevstress_2 > 0) call post_data(CS%id_pdevstress_2, p_dev_stress(:,:,2), CS%diag)
endif
@@ -3262,7 +3459,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf)
iegq = G%iegB ; jegq = G%jegB
gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1
giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc
- is = iscq - 1; js = jscq - 1
+ is = iscq - 1 ; js = jscq - 1
if (trim(CS%ice_viscosity_compute) == "MODEL") then
if (CS%visc_qps==1) then
@@ -3274,7 +3471,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf)
endif
endif
- n_g = CS%n_glen; eps_min = CS%eps_glen_min
+ n_g = CS%n_glen ; eps_min = CS%eps_glen_min
do j=jsc,jec ; do i=isc,iec
@@ -3289,9 +3486,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf)
CS%ice_visc(i,j,1) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * &
max(CS%AGlen_visc(i,j) ,CS%min_ice_visc)
endif
- ! Here CS%Aglen_visc(i,j) is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file
+ ! Here CS%Aglen_visc(i,j) is the ice viscosity [R L2 T-1 ~> Pa s] computed from obs and read from a file
elseif (model_qp1) then
- !calculate viscosity at 1 cell-centered quadrature point per cell
+ ! calculate viscosity at 1 cell-centered quadrature point per cell
Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g)
! Units of Aglen_visc [Pa-(n_g) s-1]
@@ -3320,6 +3517,18 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf)
max(0.5 * Visc_coef * &
(US%s_to_T**2 * (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * &
(US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) ! Rescale after the fractional power law.
+ ! Store Newton tangent stiffness data: strain rates and coefficient for Newton iterations.
+ ! The Newton correction coefficient is (1/n-1)/2 * ice_visc / eps_e2,
+ ! where eps_e2 = ux^2 + vy^2 + ux*vy + (uy+vx)^2/4 + eps_min^2 [T-2].
+ ! It is zero where ice_visc is limited by min_ice_visc (viscosity is not smooth there).
+ CS%newton_str_ux(i,j,1) = ux ; CS%newton_str_vy(i,j,1) = vy
+ CS%newton_str_sh(i,j,1) = uy + vx
+ CS%newton_visc_factor(i,j,1) = 0.0
+ if (CS%ice_visc(i,j,1) > CS%min_ice_visc * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf))) then
+ CS%newton_visc_factor(i,j,1) = (0.5*(1./n_g - 1.) / &
+ (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2)) * &
+ CS%ice_visc(i,j,1)
+ endif
elseif (model_qp4) then
!calculate viscosity at 4 quadrature points per cell
@@ -3351,7 +3560,17 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf)
max(0.5 * Visc_coef * &
(US%s_to_T**2*(((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * &
(US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) ! Rescale after the fractional power law.
- enddo; enddo
+ ! Store Newton tangent stiffness data at each quadrature point.
+ CS%newton_str_ux(i,j,2*(jq-1)+iq) = ux ; CS%newton_str_vy(i,j,2*(jq-1)+iq) = vy
+ CS%newton_str_sh(i,j,2*(jq-1)+iq) = uy + vx
+ CS%newton_visc_factor(i,j,2*(jq-1)+iq) = 0.0
+ if (CS%ice_visc(i,j,2*(jq-1)+iq) > &
+ CS%min_ice_visc * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf))) then
+ CS%newton_visc_factor(i,j,2*(jq-1)+iq) = (0.5*(1./n_g - 1.) / &
+ (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2)) * &
+ CS%ice_visc(i,j,2*(jq-1)+iq)
+ endif
+ enddo ; enddo
endif
endif
enddo ; enddo
@@ -3384,6 +3603,8 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf)
real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m]
real :: fN ! Effective pressure (ice pressure - ocean pressure) for Coulomb friction [R Z L T-2 ~> Pa]
real :: fB !for Coulomb Friction [(T L-1)^CS%CF_PostPeak ~> (s m-1)^CS%CF_PostPeak]
+ real :: fBuq ! fB * unorm^CF_PostPeak, for Coulomb Newton correction [nondim]
+ real :: unorm_code2 ! Squared velocity magnitude in code units [L2 T-2 ~> m2 s-2]
isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec
iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB
@@ -3391,7 +3612,7 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf)
iegq = G%iegB ; jegq = G%jegB
gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1
giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc
- is = iscq - 1; js = jscq - 1
+ is = iscq - 1 ; js = jscq - 1
eps_min = CS%eps_glen_min
@@ -3405,10 +3626,12 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf)
do j=jsd+1,jed
do i=isd+1,ied
+ CS%newton_drag_coef(i,j) = 0.0
if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then
umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25
vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25
- unorm = US%L_T_to_m_s * sqrt( ((umid**2) + (vmid**2)) + (eps_min**2 * (G%dxT(i,j)**2 + G%dyT(i,j)**2)) )
+ unorm_code2 = ((umid**2) + (vmid**2)) + (eps_min**2 * ((G%dxT(i,j)**2) + (G%dyT(i,j)**2)))
+ unorm = US%L_T_to_m_s * sqrt( unorm_code2 )
!Coulomb friction (Schoof 2005, Gagliardini et al 2007)
if (CS%CoulombFriction) then
@@ -3416,17 +3639,38 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf)
Hf = max((CS%density_ocean_avg/CS%density_ice) * CS%bed_elev(i,j), 0.0)
fN = max((US%L_to_Z*(CS%density_ice * CS%g_Earth) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) - Hf)), CS%CF_MinN)
fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric)
+ fBuq = fB * unorm**CS%CF_PostPeak
CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * &
- (unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric))) * &
+ (unorm**(CS%n_basal_fric-1.0) / (1.0 + fBuq)**(CS%n_basal_fric))) * &
US%L_T_to_m_s ! Restore the scaling after the fractional power law.
else
!linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric /= 1)
+ fBuq = 0.0
CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * &
US%L_T_to_m_s ! Rescale after the fractional power law.
endif
CS%basal_traction(i,j)=max(CS%basal_traction(i,j), CS%min_basal_traction * G%areaT(i,j))
+
+ ! Store Newton basal drag data for Newton tangent stiffness correction.
+ ! newton_drag_coef = 2 * d(basal_trac)/d(|u|^2),
+ ! where d(tau_b_i)/d(u_j) = basal_trac*delta_ij + newton_drag_coef*u_i*u_j
+ ! This is the coefficient of the rank-1 correction u_i*(u.delta_u) to the Picard basal stiffness.
+ ! For Weertman: newton_drag_coef = (m-1) * basal_trac/|u|^2
+ ! For Coulomb: newton_drag_coef = basal_trac/|u|^2 * [(m-1) - m*q*fB*|u|^q/(1+fB*|u|^q)]
+ CS%newton_umid(i,j) = umid
+ CS%newton_vmid(i,j) = vmid
+ ! unorm_code2: squared velocity magnitude in code units [L2 T-2], including regularization
+ ! (same expression as inside the sqrt in unorm, without US%L_T_to_m_s factor)
+ if (CS%CoulombFriction) then
+ CS%newton_drag_coef(i,j) = (1.0 / max(unorm_code2, epsilon(unorm_code2))) * &
+ CS%basal_traction(i,j) * ((CS%n_basal_fric - 1.) - &
+ CS%n_basal_fric * CS%CF_PostPeak * fBuq / (1. + fBuq))
+ else
+ CS%newton_drag_coef(i,j) = real(CS%n_basal_fric - 1.) * CS%basal_traction(i,j) / &
+ max(unorm_code2, epsilon(unorm_code2))
+ endif
endif
enddo
enddo
@@ -3464,7 +3708,7 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg)
CS%ground_frac(i,j) = 1.0 - (CS%ground_frac_rt(i,j) * I_counter)
CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter
- CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0; CS%OD_rt_counter = 0
+ CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 ; CS%OD_rt_counter = 0
enddo ; enddo
call pass_var(CS%ground_frac, G%domain, complete=.false.)
@@ -3521,7 +3765,7 @@ subroutine change_in_draft(CS, G, h_shelf0, h_shelf1, ddraft)
do j=jsc,jec
do i=isc,iec
- b0=0.0; b1=0.0
+ b0 = 0.0 ; b1 = 0.0
if (h_shelf0(i,j)>0.0) then
OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf0(i,j)
@@ -3818,12 +4062,12 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face
is = isd+1 ; js = jsd+1
endif
- do j=js,G%jed; do i=is,G%ied
+ do j=js,G%jed ; do i=is,G%ied
if (hmask(i,j) == 1 .or. hmask(i,j)==3) then
umask(I-1:I,J-1:J)=1
vmask(I-1:I,J-1:J)=1
endif
- enddo; enddo
+ enddo ; enddo
do j=js,G%jed
do i=is,G%ied
@@ -3958,7 +4202,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node, min_h_shelf)
do j=jsc-1,jec
do i=isc-1,iec
num_h = 0
- do l=1,2; jc=j-1+l; do k=1,2; ic=i-1+k
+ do l=1,2 ; jc=j-1+l ; do k=1,2 ; ic=i-1+k
if (hmask(ic,jc) == 1.0 .or. hmask(ic,jc) == 3.0) then
h_arr(k,l)=max(h_shelf(ic,jc),min_h_shelf)
num_h = num_h + 1
@@ -3968,7 +4212,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node, min_h_shelf)
if (num_h > 0) then
H_node(i,j) = ((h_arr(1,1)+h_arr(2,2))+(h_arr(1,2)+h_arr(2,1))) / num_h
endif
- enddo; enddo
+ enddo ; enddo
enddo
enddo
@@ -3993,6 +4237,8 @@ subroutine ice_shelf_dyn_end(CS)
deallocate(CS%float_cond)
deallocate(CS%ice_visc, CS%AGlen_visc)
+ deallocate(CS%newton_visc_factor, CS%newton_str_ux, CS%newton_str_vy, CS%newton_str_sh)
+ deallocate(CS%newton_umid, CS%newton_vmid, CS%newton_drag_coef)
deallocate(CS%basal_traction,CS%C_basal_friction)
deallocate(CS%OD_rt, CS%OD_av)
deallocate(CS%t_bdry_val, CS%bed_elev)
diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90
index ec24aef2d0..8c06e2b535 100644
--- a/src/ice_shelf/MOM_ice_shelf_initialize.F90
+++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialize ice shelf variables
module MOM_ice_shelf_initialize
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_grid, only : ocean_grid_type
use MOM_array_transform, only : rotate_array
use MOM_hor_index, only : hor_index_type
@@ -31,7 +33,7 @@ module MOM_ice_shelf_initialize
contains
!> Initialize ice shelf thickness
-subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, PF, rotate_index, turns)
+subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, melt_mask, G, G_in, US, PF, rotate_index, turns)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
type(ocean_grid_type), intent(in) :: G_in !< The ocean's unrotated grid structure
real, dimension(SZDI_(G),SZDJ_(G)), &
@@ -40,7 +42,9 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P
intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2].
real, dimension(SZDI_(G),SZDJ_(G)), &
intent(inout) :: hmask !< A mask indicating which tracer points are
- !! partly or fully covered by an ice-shelf
+ !! partly or fully covered by an ice-shelf [nondim]
+ real, dimension(SZDI_(G),SZDJ_(G)), &
+ intent(inout) :: melt_mask !< A mask indicating where to allow ice-shelf melting [nondim]
type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters
logical, intent(in), optional :: rotate_index !< If true, this is a rotation test
@@ -49,9 +53,10 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P
character(len=40) :: mdl = "initialize_ice_thickness" ! This subroutine's name.
character(len=200) :: config
logical :: rotate = .false.
- real, allocatable, dimension(:,:) :: tmp1_2d ! Temporary array for storing ice shelf input data
- real, allocatable, dimension(:,:) :: tmp2_2d ! Temporary array for storing ice shelf input data
- real, allocatable, dimension(:,:) :: tmp3_2d ! Temporary array for storing ice shelf input data
+ real, allocatable, dimension(:,:) :: tmp1_2d ! Temporary array for storing ice shelf input data [Z~>m]
+ real, allocatable, dimension(:,:) :: tmp2_2d ! Temporary array for storing ice shelf input data [L2~>m2]
+ real, allocatable, dimension(:,:) :: tmp3_2d ! Temporary array for storing ice shelf input data [nondim]
+ real, allocatable, dimension(:,:) :: tmp4_2d ! Temporary array for storing ice shelf input data [nondim]
call get_param(PF, mdl, "ICE_PROFILE_CONFIG", config, &
"This specifies how the initial ice profile is specified. "//&
@@ -64,20 +69,22 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P
allocate(tmp1_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0)
allocate(tmp2_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0)
allocate(tmp3_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0)
+ allocate(tmp4_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=1.0)
select case ( trim(config) )
case ("CHANNEL") ; call initialize_ice_thickness_channel (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF)
- case ("FILE") ; call initialize_ice_thickness_from_file (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF)
+ case ("FILE") ; call initialize_ice_thickness_from_file (tmp1_2d, tmp2_2d, tmp3_2d, tmp4_2d, G_in, US, PF)
case ("USER") ; call USER_init_ice_thickness (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF)
case default ; call MOM_error(FATAL,"MOM_initialize: Unrecognized ice profile setup "//trim(config))
end select
call rotate_array(tmp1_2d,turns, h_shelf)
call rotate_array(tmp2_2d,turns, area_shelf_h)
call rotate_array(tmp3_2d,turns, hmask)
+ call rotate_array(tmp4_2d,turns, melt_mask)
deallocate(tmp1_2d,tmp2_2d,tmp3_2d)
else
select case ( trim(config) )
case ("CHANNEL") ; call initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, US, PF)
- case ("FILE") ; call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, US, PF)
+ case ("FILE") ; call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, melt_mask, G, US, PF)
case ("USER") ; call USER_init_ice_thickness (h_shelf, area_shelf_h, hmask, G, US, PF)
case default ; call MOM_error(FATAL,"MOM_initialize: Unrecognized ice profile setup "//trim(config))
end select
@@ -86,7 +93,7 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P
end subroutine initialize_ice_thickness
!> Initialize ice shelf thickness from file
-subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, US, PF)
+subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, melt_mask, G, US, PF)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
real, dimension(SZDI_(G),SZDJ_(G)), &
intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m].
@@ -94,14 +101,16 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U
intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2].
real, dimension(SZDI_(G),SZDJ_(G)), &
intent(inout) :: hmask !< A mask indicating which tracer points are
- !! partly or fully covered by an ice-shelf
+ !! partly or fully covered by an ice-shelf [nondim]
+ real, dimension(SZDI_(G),SZDJ_(G)), &
+ intent(inout) :: melt_mask !< A mask indicating where to allow ice-shelf melting [nondim]
type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors
type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters
! This subroutine reads ice thickness and area from a file and puts it into
! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask
character(len=200) :: filename,thickness_file,inputdir ! Strings for file/path
- character(len=200) :: thickness_varname, area_varname, hmask_varname ! Variable name in file
+ character(len=200) :: thickness_varname, area_varname, hmask_varname, melt_mask_varname ! Variable name in file
character(len=40) :: mdl = "initialize_ice_thickness_from_file" ! This subroutine's name.
integer :: i, j, isc, jsc, iec, jec
logical :: hmask_set
@@ -127,6 +136,9 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U
"The name of the area variable in ICE_THICKNESS_FILE.", &
default="area_shelf_h")
hmask_varname="h_mask"
+ call get_param(PF, mdl, "MELT_MASK_VARNAME", melt_mask_varname, &
+ "The name of the melt mask variable in ICE_THICKNESS_FILE.", &
+ default="melt_mask")
if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, &
" initialize_topography_from_file: Unable to open "//trim(filename))
call MOM_read_data(filename, trim(thickness_varname), h_shelf, G%Domain, scale=US%m_to_Z)
@@ -139,6 +151,12 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U
"from variable "//trim(hmask_varname)//", which does not exist in "//trim(filename))
hmask_set = .false.
endif
+ if (field_exists(filename, trim(melt_mask_varname), MOM_domain=G%Domain)) then
+ call MOM_read_data(filename, trim(melt_mask_varname), melt_mask, G%Domain)
+ else
+ melt_mask(:,:)=1.0
+ endif
+
isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec
if (.not.hmask_set) then
@@ -220,7 +238,7 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US,
! call get_param(param_file, mdl, "RHO_0", Rho_ocean, &
! "The mean ocean density used with BOUSSINESQ true to "//&
! "calculate accelerations and the mass for conservation "//&
-! "properties, or with BOUSSINSEQ false to convert some "//&
+! "properties, or with BOUSSINESQ false to convert some "//&
! "parameters from vertical units of m to kg m-2.", &
! units="kg m-3", default=1035.0, scale=US%Z_to_m)
@@ -311,7 +329,7 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b
character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name.
integer :: i, j, isd, jsd, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed
real :: input_thick ! The input ice shelf thickness [Z ~> m]
- real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1]
+ real :: input_vel ! The input ice velocity at the upstream boundary [L T-1 ~> m s-1]
real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises
lenlat = G%len_lat
@@ -649,10 +667,10 @@ subroutine initialize_ice_AGlen(AGlen, ice_viscosity_compute, G, US, PF)
" initialize_ice_stiffness_from_file: Unable to open "//trim(filename))
if (trim(ice_viscosity_compute) == "OBS") then
- !AGlen is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file
+ ! AGlen is the ice viscosity [R L2 T-1 ~> Pa s] computed from obs and read from a file
call MOM_read_data(filename, trim(varname), AGlen, G%Domain, scale=US%Pa_to_RL2_T2*US%s_to_T)
else
- !AGlen is the ice stiffness parameter [Pa-n_g s-1]
+ ! AGlen is the ice stiffness parameter [Pa-n_g s-1]
call MOM_read_data(filename, trim(varname), AGlen, G%Domain)
endif
endif
diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90
index d789c08bd4..10a3336871 100644
--- a/src/ice_shelf/MOM_ice_shelf_state.F90
+++ b/src/ice_shelf/MOM_ice_shelf_state.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Implements the thermodynamic aspects of ocean / ice-shelf interactions,
!! along with a crude placeholder for a later implementation of full
!! ice shelf dynamics, all using the MOM framework and coding style.
module MOM_ice_shelf_state
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE
use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid
@@ -24,6 +26,7 @@ module MOM_ice_shelf_state
real, pointer, dimension(:,:) :: &
mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet [R Z ~> kg m-2].
area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2].
+ melt_mask => NULL(), & !< Mask is > 0 where melting is allowed [nondim]
h_shelf => NULL(), & !< the thickness of the shelf [Z ~> m], redundant with mass but may
!! make the code more readable
dhdt_shelf => NULL(), & !< the change in thickness of the shelf over time [Z T-1 ~> m s-1]
@@ -45,10 +48,10 @@ module MOM_ice_shelf_state
!! ocean-ice interface [R Z T-1 ~> kg m-2 s-1].
tflux_shelf => NULL(), & !< The downward diffusive heat flux in the ice
!! shelf at the ice-ocean interface [Q R Z T-1 ~> W m-2].
-
tfreeze => NULL(), & !< The freezing point potential temperature
!! at the ice-ocean interface [C ~> degC].
-
+ frazil => NULL(), & !< Accumulated heating [J m-2] from frazil formation in the ocean
+ !! under ice-shelf cells
!only active when calve_ice_shelf_bergs=true:
calving => NULL(), & !< The mass flux per unit area of the ice shelf to convert to
!! bergs [R Z T-1 ~> kg m-2 s-1].
@@ -74,6 +77,7 @@ subroutine ice_shelf_state_init(ISS, G)
allocate(ISS%mass_shelf(isd:ied,jsd:jed), source=0.0 )
allocate(ISS%area_shelf_h(isd:ied,jsd:jed), source=0.0 )
+ allocate(ISS%melt_mask(isd:ied,jsd:jed), source=1.0 )
allocate(ISS%h_shelf(isd:ied,jsd:jed), source=0.0 )
allocate(ISS%dhdt_shelf(isd:ied,jsd:jed), source=0.0 )
allocate(ISS%hmask(isd:ied,jsd:jed), source=-2.0 )
@@ -84,6 +88,7 @@ subroutine ice_shelf_state_init(ISS, G)
allocate(ISS%tflux_shelf(isd:ied,jsd:jed), source=0.0 )
allocate(ISS%tfreeze(isd:ied,jsd:jed), source=0.0 )
+ allocate(ISS%frazil(isd:ied,jsd:jed), source=0.0 )
allocate(ISS%calving(isd:ied,jsd:jed), source=0.0 )
allocate(ISS%calving_hflx(isd:ied,jsd:jed), source=0.0 )
end subroutine ice_shelf_state_init
@@ -98,7 +103,7 @@ subroutine ice_shelf_state_end(ISS)
deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%dhdt_shelf, ISS%hmask)
deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf)
- deallocate(ISS%tfreeze)
+ deallocate(ISS%tfreeze, ISS%frazil)
deallocate(ISS%calving, ISS%calving_hflx)
diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90
index 3fec94e499..3eec43e335 100644
--- a/src/ice_shelf/MOM_marine_ice.F90
+++ b/src/ice_shelf/MOM_marine_ice.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Routines incorporating the effects of marine ice (sea-ice and icebergs) into
!! the ocean model dynamics and thermodynamics.
module MOM_marine_ice
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_constants, only : hlf
use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl
use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE
@@ -110,7 +112,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS
type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice
real :: fraz ! refreezing rate [R Z T-1 ~> kg m-2 s-1]
- real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion times [Q-1 T-1 ~> kg J-1 s-1].
+ real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [Q-1 T-1 ~> kg J-1 s-1].
integer :: i, j, is, ie, js, je, isd, ied, jsd, jed
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed
diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90
index 4d1f263ca8..57460227c5 100644
--- a/src/ice_shelf/user_shelf_init.F90
+++ b/src/ice_shelf/user_shelf_init.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module specifies the initial values and evolving properties of the
!! MOM6 ice shelf, using user-provided code.
module user_shelf_init
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_grid, only : ocean_grid_type
@@ -70,7 +72,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask,
call get_param(param_file, mdl, "RHO_0", CS%Rho_ocean, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "SHELF_MAX_DRAFT", CS%max_draft, &
diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90
index 9acf693f5f..571a365937 100644
--- a/src/initialization/MOM_coord_initialization.F90
+++ b/src/initialization/MOM_coord_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initializes fixed aspects of the related to its vertical coordinate.
module MOM_coord_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : chksum
use MOM_EOS, only : calculate_density, EOS_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe
diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90
index f54eb8a638..605671b0ff 100644
--- a/src/initialization/MOM_fixed_initialization.F90
+++ b/src/initialization/MOM_fixed_initialization.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initializes fixed aspects of the model, such as horizontal grid metrics,
!! topography and Coriolis.
module MOM_fixed_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum, qchksum, uvchksum
use MOM_domains, only : pass_var
use MOM_dyn_horgrid, only : dyn_horgrid_type
@@ -24,7 +26,8 @@ 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_shared_initialization, only : set_meanSL_from_file
use MOM_unit_scaling, only : unit_scale_type
use user_initialization, only : user_initialize_topography
@@ -51,19 +54,17 @@ 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.
character(len=200) :: config
- logical :: read_porous_file
+ logical :: OBC_projection_bug, open_corners, enable_bugs
+ logical :: read_porous_file, read_meanSL_file
character(len=40) :: mdl = "MOM_fixed_initialization" ! This module's name.
integer :: I, J
logical :: debug
@@ -71,35 +72,59 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir)
# include "version_variable.h"
call callTree_enter("MOM_initialize_fixed(), MOM_fixed_initialization.F90")
- call log_version(PF, mdl, version, "")
call get_param(PF, mdl, "DEBUG", debug, default=.false.)
- call get_param(PF, mdl, "INPUTDIR", inputdir, &
- "The directory in which input files are found.", default=".")
- inputdir = slasher(inputdir)
-
! Set up the parameters of the physical domain (i.e. the grid), G
call set_grid_metrics(G, PF, US)
+ ! Read time mean sea level from file
+ call get_param(PF, mdl, "READ_MEAN_SEA_LEVEL", read_meanSL_file, &
+ "If true, use a 2D map for time mean sea level, which is used to calculate "// &
+ "time mean ocean total thickness.", default=.False.)
+ if (read_meanSL_file) &
+ call set_meanSL_from_file(G%meanSL, G, PF, US)
+
! Set up the bottom depth, G%bathyT either analytically or from file
! This also sets G%max_depth based on the input parameter MAXIMUM_DEPTH,
! or, if absent, is diagnosed as G%max_depth = max( G%D(:,:) )
- call MOM_initialize_topography(G%bathyT, G%max_depth, G, PF, US)
+ call MOM_initialize_topography(G%bathyT, G%max_depth, G, PF, US, meanSL=G%meanSL)
! To initialize masks, the bathymetry in halo regions must be filled in
call pass_var(G%bathyT, G%Domain)
- ! Determine the position of any open boundaries
+ ! Determine the position of any open boundaries and create OBC
call open_boundary_config(G, US, PF, OBC)
- ! Make bathymetry consistent with open boundaries
- call open_boundary_impose_normal_slope(OBC, G, G%bathyT)
-
- ! This call sets masks that prohibit flow over any point interpreted as land
- call initialize_masks(G, PF, US)
-
- ! Make OBC mask consistent with land mask
- call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US)
+ ! Make bathymetry (if OBC_PROJECTION_BUG) and masks consistent with open boundaries.
+ if (associated(OBC)) then
+ call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
+ default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
+ call get_param(PF, mdl, "OBC_PROJECTION_BUG", OBC_projection_bug, &
+ "If false, use only interior ocean points at OBCs to specify several "//&
+ "calculations at OBC points, and it avoids applying a land mask at the "//&
+ "bay-like intersection of orthogonal OBC segments. Otherwise the "//&
+ "calculation of terms like the potential vorticity used in the barotropic "//&
+ "solver relies on bathymetry or other fields being projected outward across "//&
+ "OBCs. This option changes answers for some configurations that use OBCs.", &
+ default=enable_bugs)
+ open_corners = .not.OBC_projection_bug
+
+ if (OBC_projection_bug .and. read_meanSL_file) &
+ ! OBC_projection_bug modifies bathyT outside of the open boundaries, so meanSL would have to be
+ ! modified as well.
+ call MOM_error(FATAL, "MOM_initialize_fixed: To read mean sea level file, "//&
+ "OBC_PROJECTION_BUG needs to be False.")
+
+ ! This call sets masks that prohibit flow over any point interpreted as land
+ if (OBC_projection_bug) &
+ call open_boundary_impose_normal_slope(OBC, G, G%bathyT)
+ call initialize_masks(G, PF, US, OBC_dir_u=OBC%segnum_u, OBC_dir_v=OBC%segnum_v, &
+ open_corner_OBCs=open_corners)
+ ! Make OBC mask consistent with land mask
+ call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US)
+ else
+ call initialize_masks(G, PF, US)
+ endif
if (debug) then
call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, unscale=US%Z_to_m)
@@ -109,6 +134,9 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir)
call qchksum(G%mask2dBu, 'MOM_initialize_fixed: mask2dBu ', G%HI)
endif
+ ! Set up other fixed quantities
+ ! Parameters below are logged under "module MOM_fixed_initialization".
+ call log_version(PF, mdl, version, "")
! Modulate geometric scales according to geography.
call get_param(PF, mdl, "CHANNEL_CONFIG", config, &
"A parameter that determines which set of channels are \n"//&
@@ -153,12 +181,12 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir)
if (read_porous_file) &
call set_subgrid_topo_at_vel_from_file(G, PF, US)
-! Calculate the value of the Coriolis parameter at the latitude !
-! of the q grid points [T-1 ~> s-1].
+ ! Calculate the value of the Coriolis parameter at the latitude !
+ ! of the q grid points [T-1 ~> s-1].
call MOM_initialize_rotation(G%CoriolisBu, G, PF, US=US)
-! Calculate the components of grad f (beta)
+ ! Calculate the components of grad f (beta)
call MOM_calculate_grad_Coriolis(G%dF_dx, G%dF_dy, G, US=US)
-! Calculate the square of the Coriolis parameter
+ ! Calculate the square of the Coriolis parameter
do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB
G%Coriolis2Bu(I,J) = G%CoriolisBu(I,J)**2
enddo ; enddo
@@ -172,32 +200,37 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir)
call initialize_grid_rotation_angle(G, PF)
-! Compute global integrals of grid values for later use in scalar diagnostics !
+ ! Compute global integrals of grid values for later use in scalar diagnostics !
call compute_global_grid_integrals(G, US=US)
-! Write out all of the grid data used by this run.
- if (write_geom) call write_ocean_geometry_file(G, PF, output_dir, US=US)
-
call callTree_leave('MOM_initialize_fixed()')
end subroutine MOM_initialize_fixed
!> MOM_initialize_topography makes the appropriate call to set up the bathymetry in units of [Z ~> m].
-subroutine MOM_initialize_topography(D, max_depth, G, PF, US)
+subroutine MOM_initialize_topography(D, max_depth, G, PF, US, meanSL)
type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type
real, dimension(G%isd:G%ied,G%jsd:G%jed), &
intent(out) :: D !< Ocean bottom depth [Z ~> m]
type(param_file_type), intent(in) :: PF !< Parameter file structure
- real, intent(out) :: max_depth !< Maximum depth of model [Z ~> m]
+ real, intent(out) :: max_depth !< Maximum depth or geometric thickness,
+ !! with meanSL present, of model [Z ~> m]
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ real, dimension(G%isd:G%ied,G%jsd:G%jed), &
+ optional, intent(in) :: meanSL !< Mean sea level [Z ~> m]
! This subroutine makes the appropriate call to set up the bottom depth.
! This is a separate subroutine so that it can be made public and shared with
! the ice-sheet code or other components.
! Local variables
+ real :: max_depth_default = -1.e9 ! Default value of MAXIMUM_DEPTH parameter [m]
character(len=40) :: mdl = "MOM_initialize_topography" ! This subroutine's name.
character(len=200) :: config
+ real, dimension(G%isd:G%ied, G%jsd:G%jed) :: D_meanSL ! depth (positive below meanSL) referenced
+ ! to meanSL. A temporary field used to diagnose maximum
+ ! static column thickness. D_meanSL = D + meanSL [Z ~> m].
+ integer :: i, j
call get_param(PF, mdl, "TOPO_CONFIG", config, &
"This specifies how bathymetry is specified: \n"//&
@@ -227,7 +260,8 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US)
" \t dense - Denmark Strait-like dense water formation and overflow.\n"//&
" \t USER - call a user modified routine.", &
fail_if_missing=.true.)
- call get_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, units="m", default=-1.e9, scale=US%m_to_Z, do_not_log=.true.)
+ call get_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, units="m", default=max_depth_default, &
+ scale=US%m_to_Z, do_not_log=.true.)
select case ( trim(config) )
case ("file"); call initialize_topography_from_file(D, G, PF, US)
case ("flat"); call initialize_topography_named(D, G, PF, config, max_depth, US)
@@ -251,17 +285,27 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US)
case default ; call MOM_error(FATAL,"MOM_initialize_topography: "// &
"Unrecognized topography setup '"//trim(config)//"'")
end select
- if (max_depth>0.) then
+ if (max_depth /= max_depth_default * US%m_to_Z) then
call log_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, &
"The maximum depth of the ocean.", units="m", unscale=US%Z_to_m)
+ if (trim(config) /= "DOME") then
+ call limit_topography(D, G, PF, max_depth, US)
+ endif
else
- max_depth = diagnoseMaximumDepth(D,G)
+ if (present(meanSL)) then
+ D_meanSL(:,:) = 0.0
+ do j=G%jsc,G%jec ; do i=G%isc,G%iec ; D_meanSL(i,j) = D(i,j) + meanSL(i,j) ; enddo ; enddo
+ max_depth = diagnoseMaximumDepth(D_meanSL, G)
+ else
+ max_depth = diagnoseMaximumDepth(D, G)
+ endif
call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth, &
"The (diagnosed) maximum depth of the ocean.", &
units="m", unscale=US%Z_to_m, like_default=.true.)
- endif
- if (trim(config) /= "DOME") then
- call limit_topography(D, G, PF, max_depth, US)
+ if (trim(config) /= "DOME") then
+ ! MAXIMUM_DEPTH is not set and topography does not need to be trimmed by its maximum depth.
+ call limit_topography(D, G, PF, -max_depth_default * US%m_to_Z, US)
+ endif
endif
end subroutine MOM_initialize_topography
diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90
index 705cfc8b8d..7bc3838b19 100644
--- a/src/initialization/MOM_grid_initialize.F90
+++ b/src/initialization/MOM_grid_initialize.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initializes horizontal grid
module MOM_grid_initialize
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_checksums, only : hchksum, Bchksum, uvchksum, hchksum_pair, Bchksum_pair
use MOM_domains, only : pass_var, pass_vector, pe_here, root_PE, broadcast
use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All, Scalar_Pair
@@ -746,7 +748,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US)
fnRef = Int_dj_dy((GP%south_lat*PI/180.0), GP)
endif
- ! These calculations no longer depend on the the order in which they
+ ! These calculations no longer depend on the order in which they
! are performed because they all use the same (poor) starting guess and
! iterate to convergence.
! Note that the dynamic grid always uses symmetric memory for the global
@@ -756,14 +758,14 @@ subroutine set_grid_metrics_mercator(G, param_file, US)
y_q = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt2)
G%gridLatB(J) = y_q*180.0/PI
! if (is_root_pe()) &
- ! write(stdout, '("J, y_q = ",I4,ES14.4," itts = ",I4)') j, y_q, itt2
+ ! write(stdout, '("J, y_q = ",I0,", ",ES14.4," itts = ",I0)') j, y_q, itt2
enddo
do j=G%jsg,G%jeg
jd = fnRef + (j - jRef) - 0.5
y_h = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt1)
G%gridLatT(j) = y_h*180.0/PI
! if (is_root_pe()) &
- ! write(stdout, '("j, y_h = ",I4,ES14.4," itts = ",I4)') j, y_h, itt1
+ ! write(stdout, '("j, y_h = ",I0,", ",ES14.4," itts = ",I0)') j, y_h, itt1
enddo
do J=JsdB+J_off,JedB+J_off
jd = fnRef + (J - jRef)
@@ -786,7 +788,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US)
iRef = (G%isg-1) + GP%niglobal
fnRef = Int_di_dx(((GP%west_lon+GP%len_lon)*PI/180.0), GP)
- ! These calculations no longer depend on the the order in which they
+ ! These calculations no longer depend on the order in which they
! are performed because they all use the same (poor) starting guess and
! iterate to convergence.
do I=G%isg-1,G%ieg
@@ -853,7 +855,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US)
(dL(xq(I-1,J),xq(I,J),yq(I-1,J),yq(I,J)) + &
(dL(xq(I,J),xq(I,J-1),yq(I,J),yq(I,J-1)) + &
dL(xq(I,J-1),xq(I-1,J-1),yq(I,J-1),yq(I-1,J-1)))))
- enddo ;enddo
+ enddo ; enddo
if ((IsdB == isd) .or. (JsdB == jsq)) then
! Fill in row and column 1 to calculate the area in the southernmost
! and westernmost land cells when we are not using symmetric memory.
@@ -963,7 +965,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax)
fnbot = fn(ybot,GP) - fnval
if ((itt > 50) .and. (fnbot > 0.0)) then
- write(warnmesg, '("PE ",I2," unable to find bottom bound for grid function. &
+ write(warnmesg, '("PE ",I0," unable to find bottom bound for grid function. &
&x = ",ES10.4,", xmax = ",ES10.4,", fn = ",ES10.4,", dfn_dx = ",ES10.4,&
&", seeking fn = ",ES10.4," - fn = ",ES10.4,".")') &
pe_here(),ybot,ymin,fn(ybot,GP),dy_df(ybot,GP),fnval, fnbot
@@ -983,7 +985,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax)
fntop = fn(ytop,GP) - fnval
if ((itt > 50) .and. (fntop < 0.0)) then
- write(warnmesg, '("PE ",I2," unable to find top bound for grid function. &
+ write(warnmesg, '("PE ",I0," unable to find top bound for grid function. &
&x = ",ES10.4,", xmax = ",ES10.4,", fn = ",ES10.4,", dfn_dx = ",ES10.4, &
&", seeking fn = ",ES10.4," - fn = ",ES10.4,".")') &
pe_here(),ytop,ymax,fn(ytop,GP),dy_df(ytop,GP),fnval,fntop
@@ -994,7 +996,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax)
! Find the root using a bracketed variant of Newton's method, starting
! with a false-positon method first guess.
if ((fntop < 0.0) .or. (fnbot > 0.0) .or. (ytop < ybot)) then
- write(warnmesg, '("PE ",I2," find_root failed to bracket function. y = ",&
+ write(warnmesg, '("PE ",I0," find_root failed to bracket function. y = ",&
&2ES10.4,", fn = ",2ES10.4,".")') pe_here(),ybot,ytop,fnbot,fntop
call MOM_error(FATAL, warnmesg)
endif
@@ -1135,11 +1137,11 @@ end function Int_dj_dy
!> Extrapolates missing metric data into all the halo regions.
subroutine extrapolate_metric(var, jh, missing)
- real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos [abitrary]
+ real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos in arbitrary units [A]
integer, intent(in) :: jh !< The size of the halos to be filled
- real, optional, intent(in) :: missing !< The missing data fill value, 0 by default [abitrary]
+ real, optional, intent(in) :: missing !< The missing data fill value, 0 by default [A]
! Local variables
- real :: badval ! A bad data value [abitrary]
+ real :: badval ! A bad data value [A]
integer :: i, j
badval = 0.0 ; if (present(missing)) badval = missing
@@ -1169,8 +1171,8 @@ end subroutine extrapolate_metric
!> This function implements Adcroft's rule for reciprocals, namely that
!! Adcroft_Inv(x) = 1/x for |x|>0 or 0 for x=0.
function Adcroft_reciprocal(val) result(I_val)
- real, intent(in) :: val !< The value being inverted [abitrary]
- real :: I_val !< The Adcroft reciprocal of val [abitrary-1]
+ real, intent(in) :: val !< The value being inverted in arbitrary units [A]
+ real :: I_val !< The Adcroft reciprocal of val [A-1]
I_val = 0.0
if (val /= 0.0) I_val = 1.0/val
@@ -1182,16 +1184,37 @@ end function Adcroft_reciprocal
!! flow over any points which are shallower than Dmask and permit an
!! appropriate treatment of the boundary conditions. mask2dCu and mask2dCv
!! are 0.0 at any points adjacent to a land point. mask2dBu is 0.0 at
-!! any land or boundary point. For points in the interior, mask2dCu,
-!! mask2dCv, and mask2dBu are all 1.0.
-subroutine initialize_masks(G, PF, US)
+!! any land or boundary point. For points in the ocean interior or at open boundary
+!! condition points, mask2dCu, mask2dCv, and mask2dBu are all 1.0.
+subroutine initialize_masks(G, PF, US, OBC_dir_u, OBC_dir_v, open_corner_OBCs, maskT)
type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type
type(param_file_type), intent(in) :: PF !< Parameter file structure
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ integer, dimension(G%IsdB:G%IedB,G%jsd:G%jed), &
+ optional, intent(in) :: OBC_dir_u !< Trinary values that indicate whether there
+ !! is an open boundary condition at zonal velocity
+ !! faces and their orientation, with 0 for no OBC,
+ !! a positive value for an Eastern OBC and
+ !! a negative value for a Western OBC.
+ integer, dimension(G%isd:G%ied,G%JsdB:G%JedB), &
+ optional, intent(in) :: OBC_dir_v !< Trinary values that indicate whether there
+ !! is an open boundary condition at zonal velocity
+ !! faces and their orientation, with 0 for no OBC,
+ !! a positive value for a Northern OBC and
+ !! a negative value for a Southern OBC.
+ logical, optional, intent(in) :: open_corner_OBCs !< If present and true, the bay-like corner
+ !! between two orthogonal open boundary segments is open,
+ !! otherwise it is closed.
+ real, dimension(G%isd:G%ied,G%jsd:G%jed), &
+ optional, intent(in) :: maskT !< If present, this array is used to set the
+ !! the mask at tracer points instead of using the
+ !! bathymetry to determine the masks [nondim]
+
! Local variables
real :: Dmask ! The depth for masking in the same units as G%bathyT [Z ~> m].
real :: min_depth ! The minimum ocean depth in the same units as G%bathyT [Z ~> m].
real :: mask_depth ! The depth shallower than which to mask a point as land [Z ~> m].
+ logical :: open_corners ! If true, the bay-like corner between two orthogonal open boundary segments is open
character(len=40) :: mdl = "MOM_grid_init initialize_masks"
integer :: i, j
@@ -1207,57 +1230,107 @@ subroutine initialize_masks(G, PF, US)
"The depth below which to mask points as land points, for which all "//&
"fluxes are zeroed out. MASKING_DEPTH is ignored if it has the special "//&
"default value.", &
- units="m", default=-9999.0, scale=US%m_to_Z)
+ units="m", default=-9999.0, scale=US%m_to_Z, do_not_log=present(maskT))
Dmask = mask_depth
if (mask_depth == -9999.0*US%m_to_Z) Dmask = min_depth
- G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0
+ open_corners = .false. ; if (present(open_corner_OBCs)) open_corners = open_corner_OBCs
+
+ G%mask2dT(:,:) = 0.0 ; G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0
! Construct the h-point or T-point mask
- do j=G%jsd,G%jed ; do i=G%isd,G%ied
- if (G%bathyT(i,j) <= Dmask) then
- G%mask2dT(i,j) = 0.0
- else
- G%mask2dT(i,j) = 1.0
- endif
+ if (present(maskT)) then
+ do j=G%jsd,G%jed ; do i=G%isd,G%ied
+ G%mask2dT(i,j) = max(min(maskT(i,j), 1.0), 0.0)
+ enddo ; enddo
+ else
+ do j=G%jsd,G%jed ; do i=G%isd,G%ied
+ if (G%bathyT(i,j) <= Dmask) then
+ G%mask2dT(i,j) = 0.0
+ else
+ G%mask2dT(i,j) = 1.0
+ endif
+ enddo ; enddo
+ endif
+
+ call pass_var(G%mask2dT, G%Domain)
+
+ do j=G%jsd,G%jed ; do I=G%isd,G%ied-1
+ G%mask2dCu(I,j) = G%mask2dT(i,j) * G%mask2dT(i+1,j)
enddo ; enddo
+ if (present(OBC_dir_u)) then
+ do j=G%jsd,G%jed ; do I=G%isd,G%ied-1
+ if (OBC_dir_u(I,j) > 0) G%mask2dCu(I,j) = G%mask2dT(i,j)
+ if (OBC_dir_u(I,j) < 0) G%mask2dCu(I,j) = G%mask2dT(i+1,j)
+ enddo ; enddo
+ endif
+
do j=G%jsd,G%jed ; do I=G%isd,G%ied-1
- if ((G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i+1,j) <= Dmask)) then
- G%mask2dCu(I,j) = 0.0
- else
- G%mask2dCu(I,j) = 1.0
- endif
! This mask may be revised later after the open boundary positions are specified.
G%OBCmaskCu(I,j) = G%mask2dCu(I,j)
enddo ; enddo
do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied
- if ((G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then
- G%mask2dCv(i,J) = 0.0
- else
- G%mask2dCv(i,J) = 1.0
- endif
+ G%mask2dCv(i,J) = G%mask2dT(i,j) * G%mask2dT(i,j+1)
+ enddo ; enddo
+
+ if (present(OBC_dir_v)) then
+ do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied
+ if (OBC_dir_v(i,J) > 0) G%mask2dCv(i,J) = G%mask2dT(i,j)
+ if (OBC_dir_v(i,J) < 0) G%mask2dCv(i,J) = G%mask2dT(i,j+1)
+ enddo ; enddo
+ endif
+
+ do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied
! This mask may be revised later after the open boundary positions are specified.
G%OBCmaskCv(i,J) = G%mask2dCv(i,J)
enddo ; enddo
+ ! The mask at the vertex can be determined from the masks at the faces.
+ ! This works at interior ocean points or at convex OBC points.
do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1
- if ((G%bathyT(i+1,j) <= Dmask) .or. (G%bathyT(i+1,j+1) <= Dmask) .or. &
- (G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then
- G%mask2dBu(I,J) = 0.0
- else
- G%mask2dBu(I,J) = 1.0
- endif
+ G%mask2dBu(I,J) = (G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) * (G%mask2dCv(i,J) * G%mask2dCv(i+1,J))
enddo ; enddo
+ ! This block resets masks at the vertices when there are OBCs. The right logic is that if there
+ ! are 2 or more unmasked OBCs, this point should be open, but to recreate the previous answers,
+ if (present(OBC_dir_u)) then
+ do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1
+ ! These are conditions to set open vertex points on a straight north-south coastline
+ if ((G%mask2dCu(I,j) * OBC_dir_u(I,j)) * (G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1)) > 0.) &
+ G%mask2dBu(I,J) = 1.0
+ enddo ; enddo
+ endif
+ if (present(OBC_dir_v)) then
+ do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1
+ ! These are conditions to set open vertex points on a straight east-west coastline
+ if ((G%mask2dCv(i,J) * OBC_dir_v(i,J)) * (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J)) > 0.) &
+ G%mask2dBu(I,J) = 1.0
+ enddo ; enddo
+ endif
+ if (open_corners .and. present(OBC_dir_u) .and. present(OBC_dir_v)) then
+ do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1
+ ! These are the 4 conditions to set an open point in a concave (bay-like) corner
+ if ((G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1) < 0.) .and. (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J) < 0.)) &
+ G%mask2dBu(I,J) = 1.0 ! Southwestern corner
+ if ((G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1) > 0.) .and. (G%mask2dCv(i,J) * OBC_dir_v(i,J) < 0.)) &
+ G%mask2dBu(I,J) = 1.0 ! Southeastern corner
+ if ((G%mask2dCu(I,j) * OBC_dir_u(I,j) < 0.) .and. (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J) > 0.)) &
+ G%mask2dBu(I,J) = 1.0 ! Northwestern corner
+ if ((G%mask2dCu(I,j) * OBC_dir_u(I,j) > 0.) .and. (G%mask2dCv(i,J) * OBC_dir_v(i,J) > 0.)) &
+ G%mask2dBu(I,J) = 1.0 ! Northeastern corner
+ enddo ; enddo
+ endif
+
call pass_var(G%mask2dBu, G%Domain, position=CORNER)
call pass_vector(G%mask2dCu, G%mask2dCv, G%Domain, To_All+Scalar_Pair, CGRID_NE)
do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB
! This open face length may be revised later.
G%dy_Cu(I,j) = G%mask2dCu(I,j) * G%dyCu(I,j)
+ G%IdxCu_OBCmask(I,j) = G%OBCmaskCu(I,j) * G%IdxCu(I,j)
G%areaCu(I,j) = G%dxCu(I,j) * G%dy_Cu(I,j)
G%IareaCu(I,j) = G%mask2dCu(I,j) * Adcroft_reciprocal(G%areaCu(I,j))
enddo ; enddo
@@ -1265,6 +1338,7 @@ subroutine initialize_masks(G, PF, US)
do J=G%JsdB,G%JedB ; do i=G%isd,G%ied
! This open face length may be revised later.
G%dx_Cv(i,J) = G%mask2dCv(i,J) * G%dxCv(i,J)
+ G%IdyCv_OBCmask(i,J) = G%OBCmaskCv(i,J) * G%IdyCv(i,J)
G%areaCv(i,J) = G%dyCv(i,J) * G%dx_Cv(i,J)
G%IareaCv(i,J) = G%mask2dCv(i,J) * Adcroft_reciprocal(G%areaCv(i,J))
enddo ; enddo
diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90
index 08465659a6..8a7600c453 100644
--- a/src/initialization/MOM_shared_initialization.F90
+++ b/src/initialization/MOM_shared_initialization.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Code that initializes fixed aspects of the model grid, such as horizontal
!! grid metrics, topography and Coriolis, and can be shared between components.
module MOM_shared_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : max_across_PEs, reproducing_sum
use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast
use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID
@@ -30,6 +32,7 @@ module MOM_shared_initialization
public read_face_length_list, set_velocity_depth_max, set_velocity_depth_min
public set_subgrid_topo_at_vel_from_file
public compute_global_grid_integrals, write_ocean_geometry_file
+public set_meanSL_from_file
! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional
! consistency testing. These are noted in comments with units like Z, H, L, and T, along with
@@ -136,6 +139,41 @@ function diagnoseMaximumDepth(D, G)
call max_across_PEs(diagnoseMaximumDepth)
end function diagnoseMaximumDepth
+!> Read time mean ocean sea level from a file
+subroutine set_meanSL_from_file(meanSL, G, param_file, US)
+ type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type
+ real, dimension(G%isd:G%ied,G%jsd:G%jed), &
+ intent(out) :: meanSL !< Mean sea level referenced to a zero
+ !! reference height at tracer points [Z ~> m].
+ type(param_file_type), intent(in) :: param_file !< Parameter file structure
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ ! Local variables
+ character(len=200) :: filename, file, inputdir ! Strings for file/path
+ character(len=200) :: varname ! Variable name in file
+ character(len=40) :: mdl = "set_meanSL_from_file" ! This subroutine's name.
+ integer :: i, j
+
+ call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90")
+
+ call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".")
+ inputdir = slasher(inputdir)
+ call get_param(param_file, mdl, "MEAN_SEA_LEVEL_FILE", file, &
+ "The file from which the mean sea level is read.", &
+ default="mean_sea_level.nc")
+ call get_param(param_file, mdl, "MEAN_SEA_LEVEL_VARNAME", varname, &
+ "The name of the mean sea level variable in MEAN_SEA_LEVEL_FILE.", &
+ default="meanSL")
+ filename = trim(inputdir)//trim(file)
+ call log_param(param_file, mdl, "INPUTDIR/TOPO_FILE", filename)
+
+ if (.not.file_exists(filename, G%Domain)) &
+ call MOM_error(FATAL, " "//mdl//": Unable to open "//trim(filename))
+
+ call MOM_read_data(filename, trim(varname), meanSL, G%Domain, scale=US%m_to_Z)
+ call pass_var(meanSL, G%Domain)
+
+ call callTree_leave(trim(mdl)//'()')
+end subroutine set_meanSL_from_file
!> Read gridded depths from file
subroutine initialize_topography_from_file(D, G, param_file, US)
@@ -884,6 +922,8 @@ subroutine reset_face_lengths_list(G, param_file, US)
! Count the number of u_width and v_width entries.
call read_face_length_list(iounit, filename, num_lines, lines)
+ else
+ num_lines = 0
endif
len_lon = 360.0 ; if (G%len_lon > 0.0) len_lon = G%len_lon
@@ -930,12 +970,12 @@ subroutine reset_face_lengths_list(G, param_file, US)
do ln=1,num_lines
line = lines(ln)
! Detect keywords
- found_u = .false.; found_v = .false.
- found_u_por = .false.; found_v_por = .false.
- isu = index(uppercase(line), "U_WIDTH" ); if (isu > 0) found_u = .true.
- isv = index(uppercase(line), "V_WIDTH" ); if (isv > 0) found_v = .true.
- isu_por = index(uppercase(line), "U_WIDTH_POR" ); if (isu_por > 0) found_u_por = .true.
- isv_por = index(uppercase(line), "V_WIDTH_POR" ); if (isv_por > 0) found_v_por = .true.
+ found_u = .false. ; found_v = .false.
+ found_u_por = .false. ; found_v_por = .false.
+ isu = index(uppercase(line), "U_WIDTH") ; if (isu > 0) found_u = .true.
+ isv = index(uppercase(line), "V_WIDTH") ; if (isv > 0) found_v = .true.
+ isu_por = index(uppercase(line), "U_WIDTH_POR") ; if (isu_por > 0) found_u_por = .true.
+ isv_por = index(uppercase(line), "V_WIDTH_POR") ; if (isv_por > 0) found_v_por = .true.
! Store and check the relevant values.
if (found_u) then
@@ -1162,9 +1202,9 @@ subroutine read_face_length_list(iounit, filename, num_lines, lines)
! Detect keywords
line_up = uppercase(line)
- found_u = .false.; found_v = .false.
- isu = index(line_up(:last), "U_WIDTH" ); if (isu > 0) found_u = .true.
- isv = index(line_up(:last), "V_WIDTH" ); if (isv > 0) found_v = .true.
+ found_u = .false. ; found_v = .false.
+ isu = index(line_up(:last), "U_WIDTH") ; if (isu > 0) found_u = .true.
+ isv = index(line_up(:last), "V_WIDTH") ; if (isv > 0) found_v = .true.
if (found_u .and. found_v) call MOM_error(FATAL, &
"read_face_length_list : both U_WIDTH and V_WIDTH found when "//&
@@ -1251,8 +1291,8 @@ subroutine set_subgrid_topo_at_vel_from_file(G, param_file, US)
! The signs of the depth parameters need to be inverted to be backward compatible with input files
! used by subroutine reset_face_lengths_list, which assumes depth is negative below the sea surface.
- G%porous_DmaxU = -G%porous_DmaxU; G%porous_DminU = -G%porous_DminU; G%porous_DavgU = -G%porous_DavgU
- G%porous_DmaxV = -G%porous_DmaxV; G%porous_DminV = -G%porous_DminV; G%porous_DavgV = -G%porous_DavgV
+ G%porous_DmaxU = -G%porous_DmaxU ; G%porous_DminU = -G%porous_DminU ; G%porous_DavgU = -G%porous_DavgU
+ G%porous_DmaxV = -G%porous_DmaxV ; G%porous_DminV = -G%porous_DminV ; G%porous_DavgV = -G%porous_DavgV
call pass_vector(G%porous_DmaxU, G%porous_DmaxV, G%Domain, To_All+SCALAR_PAIR, CGRID_NE)
call pass_vector(G%porous_DminU, G%porous_DminV, G%Domain, To_All+SCALAR_PAIR, CGRID_NE)
diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90
index 054e5592c8..f5cd0722dc 100644
--- a/src/initialization/MOM_state_initialization.F90
+++ b/src/initialization/MOM_state_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization functions for state variables, u, v, h, T and S.
module MOM_state_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum, qchksum, uvchksum
use MOM_density_integrals, only : int_specific_vol_dp
use MOM_density_integrals, only : find_depth_of_pressure_in_cell
@@ -20,15 +22,10 @@ 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_grid_initialize, only : initialize_masks, set_grid_metrics
+use MOM_open_boundary, only : ocean_OBC_type, open_boundary_test_extern_h
+use MOM_open_boundary, only : fill_temp_salt_segments, setup_OBC_tracer_reservoirs
+use MOM_open_boundary, only : fill_thickness_segments
+use MOM_open_boundary, only : set_initialized_OBC_tracer_reservoirs
use MOM_restart, only : restore_state, is_new_run, copy_restart_var, copy_restart_vector
use MOM_restart, only : restart_registry_lock, MOM_restart_CS
use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density
@@ -103,7 +100,7 @@ module MOM_state_initialization
#include
-public MOM_initialize_state
+public MOM_initialize_state, MOM_initialize_OBCs
! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional
! consistency testing. These are noted in comments with units like Z, H, L, and T, along with
@@ -118,7 +115,8 @@ module MOM_state_initialization
!! conditions or by reading them from a restart (or saves) file.
subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, &
restart_CS, ALE_CSp, tracer_Reg, sponge_CSp, &
- ALE_sponge_CSp, oda_incupd_CSp, OBC, Time_in, frac_shelf_h, mass_shelf)
+ ALE_sponge_CSp, oda_incupd_CSp, OBC_for_remap, &
+ Time_in, frac_shelf_h, mass_shelf, OBC_for_bug)
type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
@@ -142,7 +140,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, &
type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry
type(sponge_CS), pointer :: sponge_CSp !< The layerwise sponge control structure.
type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< The ALE sponge control structure.
- type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure.
+ type(ocean_OBC_type), pointer :: OBC_for_remap !< The open boundary condition control
+ !! structure that may be used for remapping velocities.
+ !! This must be on the unrotated grid, but only the
+ !! position and directions of the OBC faces are used.
type(oda_incupd_CS), pointer :: oda_incupd_CSp !< The oda_incupd control structure.
type(time_type), optional, intent(in) :: Time_in !< Time at the start of the run segment.
real, dimension(SZI_(G),SZJ_(G)), &
@@ -150,20 +151,24 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, &
!! by a floating ice shelf [nondim].
real, dimension(SZI_(G),SZJ_(G)), &
optional, intent(in) :: mass_shelf !< The mass per unit area of the overlying
- !! ice shelf [ R Z ~> kg m-2 ]
+ !! ice shelf [R Z ~> kg m-2]
+ type(ocean_OBC_type), optional, pointer :: OBC_for_bug !< An open boundary condition control structure
+ !! that might be used to store OBC temperatures and
+ !! salinities if OBC_RESERVOIR_INIT_BUG is true.
! Local variables
real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m]
real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The layer thicknesses in geopotential (z) units [Z ~> m]
character(len=200) :: inputdir ! The directory where NetCDF input files are.
character(len=200) :: config, h_config
- real :: H_rescale ! A rescaling factor for thicknesses from the representation in
- ! a restart file to the internal representation in this run [various units ~> 1]
real :: dt ! The baroclinic dynamics timestep for this run [T ~> s].
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 +181,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, &
! is a run from a restart file; this option
! allows the use of Fatal unused parameters.
type(EOS_type), pointer :: eos => NULL()
+ logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
+ ! recreate the bugs, or if false bugs are only used if actively selected.
logical :: debug ! If true, write debugging output.
- logical :: debug_obc ! If true, do debugging calls related to OBCs.
logical :: debug_layers = .false.
logical :: use_ice_shelf
character(len=80) :: mesg
@@ -201,7 +207,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
@@ -213,7 +218,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)
@@ -440,8 +444,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 (present(OBC_for_bug)) then ; if (use_temperature .and. associated(OBC_for_bug)) then
+ call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
+ default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
+ ! Log this parameter later with the other OBC parameters.
+ call get_param(PF, mdl, "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, &
+ "If true, set the OBC tracer reservoirs at the startup of a new run from the "//&
+ "interior tracer concentrations regardless of properties that may be explicitly "//&
+ "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.)
+ if (OBC_reservoir_init_bug) then
+ ! These calls should be moved down to join the OBC code, but doing so changes answers because
+ ! the temperatures and salinities can change due to the remapping and reading from the restarts.
+ call pass_var(tv%T, G%Domain, complete=.false.)
+ call pass_var(tv%S, G%Domain, complete=.true.)
+ call fill_temp_salt_segments(G, GV, US, OBC_for_bug, tv)
+ endif
+ endif ; endif
init_t_perturb = 0.0
if (use_temperature) then
@@ -519,8 +538,10 @@ 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)
- call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, &
- dt=dt, initial=.true.)
+ ! In this call, OBC_for_remap is only used for the directions of OBCs when setting thicknesses at
+ ! velocity points.
+ call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC_for_remap, &
+ tracer_Reg, dt=dt, initial=.true.)
endif
endif
@@ -607,9 +628,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, &
if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, unscale=US%C_to_degC)
if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, unscale=US%S_to_ppt)
if ( use_temperature .and. debug_layers) then ; do k=1,nz
- write(mesg,'("MOM_IS: T[",I2,"]")') k
+ write(mesg,'("MOM_IS: T[",I0,"]")') k
call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1, unscale=US%C_to_degC)
- write(mesg,'("MOM_IS: S[",I2,"]")') k
+ write(mesg,'("MOM_IS: S[",I0,"]")') k
call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1, unscale=US%S_to_ppt)
enddo ; endif
endif
@@ -636,7 +657,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, &
sponge_CSp, ALE_sponge_CSp)
case ("ISOMIP"); call ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, useALE, &
sponge_CSp, ALE_sponge_CSp)
- case("RGC"); call RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, useALE, &
+ case ("RGC"); call RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, useALE, &
sponge_CSp, ALE_sponge_CSp)
case ("USER"); call user_initialize_sponges(G, GV, use_temperature, tv, PF, sponge_CSp, h)
case ("BFB"); call BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, depth_tot, PF, &
@@ -653,19 +674,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()')
- ! This controls user code for setting open boundary data
+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(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]
+ type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic
+ !! variables
+ type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure.
+ type(time_type), intent(in) :: Time !< Time at the start of the run segment.
+ type(param_file_type), intent(in) :: PF !< A structure indicating the open file to parse
+ !! for model parameter values.
+ type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure
+ type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry
+
+ ! Local variables
+ character(len=200) :: config
+ logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
+ ! recreate the bugs, or if false bugs are only used if actively selected.
+ logical :: debug ! If true, write debugging output.
+ logical :: debug_obc ! If true, do additional calls resetting values to help debug the correctness
+ ! of the open boundary condition code.
+ logical :: OBC_reservoir_init_bug ! If true, set the OBC tracer reservoirs at the startup of a new
+ ! run from the interior tracer concentrations regardless of properties that
+ ! may be explicitly specified for the reservoir concentrations.
+
+ call callTree_enter('MOM_initialize_OBCs()')
if (associated(OBC)) then
- call initialize_segment_data(G, 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"//&
@@ -697,30 +771,21 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, &
call MOM_error(FATAL, "The open boundary conditions specified by "//&
"OBC_USER_CONFIG = "//trim(config)//" have not been fully implemented.")
endif
- if (open_boundary_query(OBC, apply_open_OBC=.true.)) then
- call set_tracer_data(OBC, tv, h, G, GV, PF)
+
+ if (debug) then
+ call hchksum(G%mask2dT, 'MOM_initialize_OBCs: mask2dT ', G%HI)
+ call uvchksum('MOM_initialize_OBCs: mask2dC[uv]', G%mask2dCu, G%mask2dCv, G%HI)
+ call qchksum(G%mask2dBu, 'MOM_initialize_OBCs: mask2dBu ', G%HI)
endif
- endif
-! if (open_boundary_query(OBC, apply_nudged_OBC=.true.)) then
-! call set_3D_OBC_data(OBC, tv, h, G, PF, tracer_Reg)
-! endif
- ! Still need a way to specify the boundary values
- if (debug.and.associated(OBC)) then
- call hchksum(G%mask2dT, 'MOM_initialize_state: mask2dT ', G%HI)
- call uvchksum('MOM_initialize_state: mask2dC[uv]', G%mask2dCu, &
- G%mask2dCv, G%HI)
- call qchksum(G%mask2dBu, 'MOM_initialize_state: mask2dBu ', G%HI)
+ if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h)
+
+ if (OBC%use_h_res) &
+ call fill_thickness_segments(G, GV, US, OBC, h)
endif
- if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h)
- call callTree_leave('MOM_initialize_state()')
+ call callTree_leave('MOM_initialize_OBCs()')
- ! Set-up of data Assimilation with incremental update
- if (use_oda_incupd) then
- call initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, &
- PF, oda_incupd_CSp, restart_CS, Time)
- endif
-end subroutine MOM_initialize_state
+end subroutine MOM_initialize_OBCs
!> Reads the layer thicknesses or interface heights from a file.
subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, file_has_thickness, &
@@ -847,7 +912,7 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f
if ((inconsistent > 0) .and. (is_root_pe())) then
write(mesg,'("Thickness initial conditions are inconsistent ",'// &
- '"with topography in ",I8," places.")') inconsistent
+ '"with topography in ",I0," places.")') inconsistent
call MOM_error(WARNING, mesg)
endif
endif
@@ -892,7 +957,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta)
call sum_across_PEs(contractions)
if ((contractions > 0) .and. (is_root_pe())) then
write(mesg,'("Thickness initial conditions were contracted ",'// &
- '"to fit topography in ",I8," places.")') contractions
+ '"to fit topography in ",I0," places.")') contractions
call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg)
endif
@@ -930,7 +995,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta)
call sum_across_PEs(dilations)
if ((dilations > 0) .and. (is_root_pe())) then
write(mesg,'("Thickness initial conditions were dilated ",'// &
- '"to fit topography in ",I8," places.")') dilations
+ '"to fit topography in ",I0," places.")') dilations
call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg)
endif
@@ -1189,11 +1254,14 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read, z_top_shelf)
else
do j=js,je ; do i=is,ie
eta_sfc(i,j) = z_top_shelf(i,j)
- enddo; enddo
+ enddo ; enddo
endif
! Convert thicknesses to interface heights.
+ !$omp target update from(h)
+ !$omp target enter data map(alloc: eta)
call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref)
+ !$omp target exit data map(from: eta)
do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then
! if (eta_sfc(i,j) < eta(i,j,nz+1)) then
@@ -1375,7 +1443,10 @@ subroutine calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h)
max_iter = 1e3
call MOM_mesg("Started calculating initial interface position under ice shelf ")
! Convert thicknesses to interface heights.
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: eta)
call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref)
+ !$omp target exit data map(from: eta)
do j=js,je ; do i=is,ie
iter = 1
z_top_shelf(i,j) = 0.0
@@ -1411,7 +1482,7 @@ subroutine calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h)
enddo
residual = mass_shelf(i,j) - mass_disp
iter = iter+1
- end do
+ enddo
if (iter >= max_iter) call MOM_mesg("Warning: calc_sfc_displacement too many iterations.")
z_top_shelf(i,j) = z_top
endif
@@ -2013,7 +2084,6 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t
! Local variables
real, allocatable, dimension(:,:,:) :: eta ! The target interface heights [Z ~> m].
real, allocatable, dimension(:,:,:) :: dz ! The target interface thicknesses in height units [Z ~> m]
- real, allocatable, dimension(:,:,:) :: h ! The target interface thicknesses [H ~> m or kg m-2].
real, dimension (SZI_(G),SZJ_(G),SZK_(GV)) :: &
tmp, & ! A temporary array for temperatures [C ~> degC] or other tracers.
@@ -2230,7 +2300,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t
enddo ; enddo ; enddo
do k=1,nz_data ; do j=js,je ; do i=is,ie
dz(i,j,k) = eta(i,j,k)-eta(i,j,k+1)
- enddo; enddo ; enddo
+ enddo ; enddo ; enddo
deallocate(eta)
if (use_temperature) then
@@ -2616,11 +2686,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just
! from data when finding the initial interface locations in
! layered mode from a dataset of T and S.
character(len=64) :: remappingScheme
- real :: tempAvg ! Spatially averaged temperatures on a layer [C ~> degC]
- real :: saltAvg ! Spatially averaged salinities on a layer [S ~> ppt]
logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm (only used if useALEremapping)
logical :: do_conv_adj, ignore
- integer :: nPoints
+ logical :: use_depth_based_time_fitler, use_adjust_interface_motion
integer :: id_clock_routine, id_clock_ALE
id_clock_routine = cpu_clock_id('(Initialize from Z)', grain=CLOCK_ROUTINE)
@@ -2775,6 +2843,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just
"from an input dataset using horiz_interp_and_extrap_tracer. This routine "//&
"converges slowly, so an overly small tolerance can get expensive.", &
units="ppt", default=1.0e-3, scale=US%ppt_to_S, do_not_log=just_read)
+ call get_param(PF, mdl, "REGRID_USE_DEPTH_BASED_TIME_FILTER", use_depth_based_time_fitler, &
+ default=.true., do_not_log=.true.)
+ call get_param(PF, mdl, "USE_ADJUST_INTERFACE_MOTION", use_adjust_interface_motion, &
+ default=.true., do_not_log=.true.)
if (just_read) then
if ((.not.useALEremapping) .and. adjust_temperature) &
@@ -2873,7 +2945,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just
! Build the target grid (and set the model thickness to it)
- call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS
+ call ALE_initRegridding( G, GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS
if (remap_general) then
dz_neglect = set_h_neglect(GV, remap_answer_date, dz_neglect_edge)
else
@@ -2885,8 +2957,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just
! Now remap from source grid to target grid, first setting reconstruction parameters
if (remap_general) then
- call set_regrid_params( regridCS, min_thickness=0. )
- allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used
+ call set_regrid_params( regridCS, min_thickness=0., &
+ use_adjust_interface_motion=use_adjust_interface_motion, &
+ use_depth_based_time_filter=use_depth_based_time_fitler)
+ allocate( dz_interface(isd:ied,jsd:jed,nkd+1), source=0.) ! Need for argument to regridding_main() but is not used
call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore)
if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc)
@@ -2970,7 +3044,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just
call find_interfaces(rho_z, z_in, kd, Rb, Z_bottom, zi, G, GV, US, nlevs, nkml, &
Hmix_depth, eps_z, eps_rho, density_extrap_bug)
- deallocate(rho_z)
+ deallocate(rho_z, Rb)
dz(:,:,:) = 0.0
if (correct_thickness) then
@@ -2993,7 +3067,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just
if ((inconsistent > 0) .and. (is_root_pe())) then
write(mesg, '("Thickness initial conditions are inconsistent ",'// &
- '"with topography in ",I5," places.")') inconsistent
+ '"with topography in ",I0," places.")') inconsistent
call MOM_error(WARNING, mesg)
endif
endif
diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90
index b100e0bf1c..d444fafdd9 100644
--- a/src/initialization/MOM_tracer_initialization_from_Z.F90
+++ b/src/initialization/MOM_tracer_initialization_from_Z.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initializes hydrography from z-coordinate climatology files
module MOM_tracer_initialization_from_Z
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP
diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90
index 48e7ca1c4f..7ab89310b4 100644
--- a/src/ocean_data_assim/MOM_oda_driver.F90
+++ b/src/ocean_data_assim/MOM_oda_driver.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interfaces for MOM6 ensembles and data assimilation.
module MOM_oda_driver_mod
@@ -48,7 +52,7 @@ module MOM_oda_driver_mod
use MOM_hor_index, only : hor_index_type, hor_index_init
use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid
use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid
-use MOM_fixed_initialization, only : MOM_initialize_fixed, MOM_initialize_topography
+use MOM_fixed_initialization, only : MOM_initialize_topography
use MOM_coord_initialization, only : MOM_initialize_coord
use MOM_file_parser, only : read_param, get_param, param_file_type
use MOM_string_functions, only : lowercase
@@ -126,7 +130,7 @@ module MOM_oda_driver_mod
integer :: ensemble_id = 0 !< id of the current ensemble member
integer, pointer, dimension(:,:) :: ensemble_pelist !< PE list for ensemble members
integer, pointer, dimension(:) :: filter_pelist !< PE list for ensemble members
- real :: assim_interval !< analysis interval [ T ~> s]
+ real :: assim_interval !< analysis interval [T ~> s]
! Profiles local to the analysis domain
type(ocean_profile_type), pointer :: Profiles => NULL() !< pointer to linked list of all available profiles
type(ocean_profile_type), pointer :: CProfiles => NULL()!< pointer to linked list of current profiles
@@ -144,6 +148,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
@@ -175,6 +180,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)
@@ -258,6 +265,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)))
@@ -304,7 +317,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS)
call set_grid_metrics(dG, PF, CS%US)
call MOM_initialize_topography(dG%bathyT, dG%max_depth, dG, PF, CS%US)
call MOM_initialize_coord(CS%GV, CS%US, PF, tv_dummy, dG%max_depth)
- call ALE_init(PF, CS%GV, CS%US, dG%max_depth, CS%ALE_CS)
+ call ALE_init(PF, CS%G, CS%GV, CS%US, dG%max_depth, CS%ALE_CS)
call MOM_grid_init(CS%Grid, PF, global_indexing=.false.)
call ALE_updateVerticalGridType(CS%ALE_CS, CS%GV)
call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US)
@@ -329,19 +342,19 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS)
"If true, use the OM4 remapping-via-subcells algorithm for ODA. "//&
"See REMAPPING_USE_OM4_SUBCELLS for more details. "//&
"We recommend setting this option to false.", default=om4_remap_via_sub_cells)
- call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','')
+ call initialize_regridding(CS%regridCS, CS%G, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','')
h_neglect = set_h_neglect(GV, CS%answer_date, h_neglect_edge)
call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells, &
- h_neglect=h_neglect, h_neglect_edge=h_neglect_edge)
+ h_neglect=h_neglect, h_neglect_edge=h_neglect_edge, answer_date=CS%answer_date)
call set_regrid_params(CS%regridCS, min_thickness=0.)
- isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed
+ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
! breaking with the MOM6 convention and using global indices
!call get_domain_extent(G%Domain,is,ie,js,je,isd,ied,jsd,jed,&
! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric)
- !isd=isd+idg_offset; ied=ied+idg_offset ! using global indexing within the DA module
- !jsd=jsd+jdg_offset; jed=jed+jdg_offset ! TODO: switch to local indexing? (mjh)
+ !isd = isd+idg_offset ; ied = ied+idg_offset ! using global indexing within the DA module
+ !jsd = jsd+jdg_offset ; jed = jed+jdg_offset ! TODO: switch to local indexing? (mjh)
if (.not. associated(CS%h)) then
allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke), source=CS%GV%Angstrom_H)
@@ -363,7 +376,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
@@ -407,7 +422,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS)
! if (CS%write_obs) then
! temp_fid = open_profile_file("temp_"//trim(obs_file))
! salt_fid = open_profile_file("salt_"//trim(obs_file))
-! end if
+! endif
end subroutine init_oda
@@ -436,7 +451,7 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS)
!call MOM_mesg('Setting prior')
! computational domain for the analysis grid
- isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec
+ isc = CS%Grid%isc ; iec = CS%Grid%iec ; jsc = CS%Grid%jsc ; jec = CS%Grid%jec
! array extents for the ensemble member
!call get_domain_extent(CS%domains(CS%ensemble_id),is,ie,js,je,isd,ied,jsd,jed,&
! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric)
@@ -493,17 +508,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),&
@@ -569,25 +583,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
@@ -606,7 +633,7 @@ subroutine oda_end(CS)
end subroutine oda_end
!> Initialize DA module
-subroutine init_ocean_ensemble(CS,Grid,GV,ens_size)
+subroutine init_ocean_ensemble(CS, Grid, GV, ens_size)
type(ocean_control_struct), pointer :: CS !< Pointer to ODA control structure
type(ocean_grid_type), pointer :: Grid !< Pointer to ocean analysis grid
type(verticalGrid_type), pointer :: GV !< Pointer to DA vertical grid
@@ -614,10 +641,10 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size)
integer :: is, ie, js, je, nk
- nk=GV%ke
- is=Grid%isd;ie=Grid%ied
- js=Grid%jsd;je=Grid%jed
- CS%ensemble_size=ens_size
+ nk = GV%ke
+ is = Grid%isd ; ie = Grid%ied
+ js = Grid%jsd ; je = Grid%jed
+ CS%ensemble_size = ens_size
allocate(CS%T(is:ie,js:je,nk,ens_size))
allocate(CS%S(is:ie,js:je,nk,ens_size))
allocate(CS%SSH(is:ie,js:je,ens_size))
@@ -633,7 +660,7 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size)
end subroutine init_ocean_ensemble
!> Set the next analysis time
-subroutine set_analysis_time(Time,CS)
+subroutine set_analysis_time(Time, CS)
type(time_type), intent(in) :: Time !< the current model time
type(ODA_CS), pointer, intent(inout) :: CS !< the DA control structure
@@ -642,7 +669,7 @@ subroutine set_analysis_time(Time,CS)
if (Time >= CS%Time) then
! increment the analysis time to the next step
- CS%Time = CS%Time + real_to_time(CS%US%T_to_s*(CS%assim_interval))
+ CS%Time = CS%Time + real_to_time(CS%assim_interval, unscale=CS%US%T_to_s)
call get_date(Time, yr, mon, day, hr, min, sec)
write(mesg,*) 'Model Time: ', yr, mon, day, hr, min, sec
@@ -689,7 +716,7 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS)
call cpu_clock_begin(id_clock_apply_increments)
- T_tend_inc(:,:,:) = 0.0; S_tend_inc(:,:,:) = 0.0; T_tend(:,:,:) = 0.0; S_tend(:,:,:) = 0.0
+ T_tend_inc(:,:,:) = 0.0 ; S_tend_inc(:,:,:) = 0.0 ; T_tend(:,:,:) = 0.0 ; S_tend(:,:,:) = 0.0
if (CS%assim_method > 0 ) then
T_tend = T_tend + CS%T_tend
S_tend = S_tend + CS%S_tend
@@ -699,13 +726,13 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS)
S_tend = S_tend + CS%S_bc_tend
endif
- isc=G%isc; iec=G%iec; jsc=G%jsc; jec=G%jec
- do j=jsc,jec; do i=isc,iec
+ isc=G%isc ; iec=G%iec ; jsc=G%jsc ; jec=G%jec
+ do j=jsc,jec ; do i=isc,iec
call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), T_tend(i,j,:), &
G%ke, h(i,j,:), T_tend_inc(i,j,:))
call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S_tend(i,j,:), &
G%ke, h(i,j,:), S_tend_inc(i,j,:))
- enddo; enddo
+ enddo ; enddo
call pass_var(T_tend_inc, G%Domain)
@@ -772,7 +799,7 @@ subroutine set_up_global_tgrid(T_grid, CS, G)
if ( global2D(i,j) > 1 ) then
T_grid%mask(i,j,k) = 1.0
endif
- enddo; enddo
+ enddo ; enddo
if (k == 1) then
T_grid%z(:,:,k) = global2D/2
else
diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90
index f174bf14ad..e0823999ef 100644
--- a/src/ocean_data_assim/MOM_oda_incupd.F90
+++ b/src/ocean_data_assim/MOM_oda_incupd.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the routines used to apply incremental updates
!! from data assimilation.
!
@@ -13,7 +17,6 @@
module MOM_oda_incupd
-! This file is part of MOM6. See LICENSE.md for the license.
use MOM_array_transform, only : rotate_array
use MOM_coms, only : sum_across_PEs
use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field
@@ -223,8 +226,8 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re
endif
write(mesg,'(i12)') CS%nstep_incupd
if (is_root_pe()) &
- call MOM_error(NOTE,"initialize_oda_incupd: Number of Timestep of inc. update:"//&
- trim(mesg))
+ call MOM_error(NOTE, "initialize_oda_incupd: Number of Timestep of inc. update: "//&
+ trim(mesg))
! number of inc. update already done, CS%ncount, either from restart or set to 0.0
if (query_initialized(CS%ncount, "oda_incupd_ncount", restart_CS) .and. &
@@ -235,15 +238,15 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re
endif
write(mesg,'(f4.1)') CS%ncount
if (is_root_pe()) &
- call MOM_error(NOTE,"initialize_oda_incupd: Inc. update already done:"//&
- trim(mesg))
+ call MOM_error(NOTE, "initialize_oda_incupd: Inc. update already done: "//&
+ trim(mesg))
! get the vertical grid (h_obs) of the increments
CS%nz_data = nz_data
allocate(CS%Ref_h%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0)
- do j=G%jsc,G%jec; do i=G%isc,G%iec ; do k=1,CS%nz_data
+ do j=G%jsc,G%jec ; do i=G%isc,G%iec ; do k=1,CS%nz_data
CS%Ref_h%p(i,j,k) = data_h(i,j,k)
- enddo; enddo ; enddo
+ enddo ; enddo ; enddo
!### Doing a halo update here on CS%Ref_h%p would avoid needing halo updates each timestep.
! Call the constructor for remapping control structure
@@ -278,7 +281,7 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS)
CS%fldno = CS%fldno + 1
if (CS%fldno > MAX_FIELDS_) then
- write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease &
+ write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease &
&the number of fields increments in the call to &
&initialize_oda_incupd." )') CS%fldno
call MOM_error(FATAL,"set_up_oda_incupd_field: "//mesg)
@@ -471,7 +474,7 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS)
enddo ; enddo
! remap v to h_obs to get increment
- hv(:) = 0.0;
+ hv(:) = 0.0
do j=jsB,jeB ; do i=is,ie
if (G%mask2dCv(i,j) == 1) then
! get v-velocity
@@ -599,19 +602,19 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS)
tmp_val1(:) = 0.0
tmp_t(:,:,:) = 0.0 ; tmp_s(:,:,:) = 0.0 ! diagnostics
do j=js,je ; do i=is,ie
- ! account for the different SSH
- sum_h1 = 0.0
- do k=1,nz
- sum_h1 = sum_h1+h(i,j,k)
- enddo
- sum_h2 = 0.0
- do k=1,nz_data
- sum_h2 = sum_h2+h_obs(i,j,k)
- enddo
- do k=1,nz_data
- tmp_h(k) = ( sum_h1 / sum_h2 ) * h_obs(i,j,k)
- enddo
if (G%mask2dT(i,j) == 1) then
+ ! account for the different SSH
+ sum_h1 = 0.0
+ do k=1,nz
+ sum_h1 = sum_h1+h(i,j,k)
+ enddo
+ sum_h2 = 0.0
+ do k=1,nz_data
+ sum_h2 = sum_h2+h_obs(i,j,k)
+ enddo
+ do k=1,nz_data
+ tmp_h(k) = ( sum_h1 / sum_h2 ) * h_obs(i,j,k)
+ enddo
! get temperature increment
do k=1,nz_data
tmp_val2(k) = CS%Inc(1)%p(i,j,k)
diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90
index 24a637bfae..c513db2c5a 100644
--- a/src/parameterizations/lateral/MOM_MEKE.F90
+++ b/src/parameterizations/lateral/MOM_MEKE.F90
@@ -1,9 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Implements the Mesoscale Eddy Kinetic Energy framework
!! with topographic beta effect included in computing beta in Rhines scale
module MOM_MEKE
-! This file is part of MOM6. See LICENSE.md for the license.
use iso_fortran_env, only : real32
use MOM_coms, only : PE_here
@@ -372,12 +375,12 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h
if (GV%Boussinesq) then
!$OMP parallel do default(shared)
do j=js-1,je+1 ; do i=is-1,ie+1
- depth_tot(i,j) = (G%bathyT(i,j) + G%Z_ref) * GV%Z_to_H
+ depth_tot(i,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * GV%Z_to_H
enddo ; enddo
else
!$OMP parallel do default(shared)
do j=js-1,je+1 ; do i=is-1,ie+1
- depth_tot(i,j) = (G%bathyT(i,j) + G%Z_ref) * CS%rho_fixed_total_depth * GV%RZ_to_H
+ depth_tot(i,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * CS%rho_fixed_total_depth * GV%RZ_to_H
enddo ; enddo
endif
else
@@ -617,7 +620,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h
!$OMP parallel do default(shared)
do j=js-1,je+1 ; do I=is-2,ie+1
! MEKE_uflux is used here as workspace with units of [L2 T-2 ~> m2 s-2].
- MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * G%OBCmaskCu(I,j)) * &
+ MEKE_uflux(I,j) = (G%dy_Cu(I,j)*G%IdxCu_OBCmask(I,j)) * &
(MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j))
! This would have units of [R Z L2 T-2 ~> kg s-2]
! MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * &
@@ -627,7 +630,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h
!$OMP parallel do default(shared)
do J=js-2,je+1 ; do i=is-1,ie+1
! MEKE_vflux is used here as workspace with units of [L2 T-2 ~> m2 s-2].
- MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * G%OBCmaskCv(i,J)) * &
+ MEKE_vflux(i,J) = (G%dx_Cv(i,J)*G%IdyCv_OBCmask(i,J)) * &
(MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j))
! This would have units of [R Z L2 T-2 ~> kg s-2]
! MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * &
@@ -1364,7 +1367,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME
if (.not. MEKE_init) return
CS%initialized = .true.
call get_param(param_file, mdl, "MEKE_IN_DYNAMICS", meke_in_dynamics, &
- "If true, step MEKE forward with the dynamics"// &
+ "If true, step MEKE forward with the dynamics "// &
"otherwise with the tracer timestep.", &
default=.true.)
@@ -1428,7 +1431,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME
"The nondimensional coefficient governing the efficiency of the GEOMETRIC \n"//&
"thickness diffusion.", units="nondim", default=0.05)
call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_ALT", CS%MEKE_equilibrium_alt, &
- "If true, use an alternative formula for computing the (equilibrium)"//&
+ "If true, use an alternative formula for computing the (equilibrium) "//&
"initial value of MEKE.", default=.false.)
call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, &
"If true, restore MEKE back to its equilibrium value, which is calculated at "//&
@@ -1522,15 +1525,15 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME
"the deformation radius or grid-spacing. Only used if "//&
"MEKE_OLD_LSCALE=True", default=.false.)
call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_KU", CS%viscosity_coeff_Ku, &
- "If non-zero, is the scaling coefficient in the expression for"//&
- "viscosity used to parameterize harmonic lateral momentum mixing by"//&
- "unresolved eddies represented by MEKE. Can be negative to"//&
+ "If non-zero, is the scaling coefficient in the expression for "//&
+ "viscosity used to parameterize harmonic lateral momentum mixing by "//&
+ "unresolved eddies represented by MEKE. Can be negative to "//&
"represent backscatter from the unresolved eddies.", &
units="nondim", default=0.0)
call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_AU", CS%viscosity_coeff_Au, &
- "If non-zero, is the scaling coefficient in the expression for"//&
- "viscosity used to parameterize biharmonic lateral momentum mixing by"//&
- "unresolved eddies represented by MEKE. Can be negative to"//&
+ "If non-zero, is the scaling coefficient in the expression for "//&
+ "viscosity used to parameterize biharmonic lateral momentum mixing by "//&
+ "unresolved eddies represented by MEKE. Can be negative to "//&
"represent backscatter from the unresolved eddies.", &
units="nondim", default=0.0)
call get_param(param_file, mdl, "MEKE_FIXED_MIXING_LENGTH", CS%Lfixed, &
@@ -1539,7 +1542,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME
units="m", default=0.0, scale=US%m_to_L)
call get_param(param_file, mdl, "MEKE_FIXED_TOTAL_DEPTH", CS%fixed_total_depth, &
"If true, use the nominal bathymetric depth as the estimate of the "//&
- "time-varying ocean depth. Otherwise base the depth on the total ocean mass"//&
+ "time-varying ocean depth. Otherwise base the depth on the total ocean mass "//&
"per unit area.", default=.true.)
call get_param(param_file, mdl, "MEKE_TOTAL_DEPTH_RHO", CS%rho_fixed_total_depth, &
"A density used to translate the nominal bathymetric depth into an estimate "//&
@@ -1721,11 +1724,13 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME
if (coldStart) CS%initialize = .false.
if (CS%initialize) call MOM_error(WARNING, &
"MEKE_init: Initializing MEKE with a local equilibrium balance.")
- if (.not.query_initialized(MEKE%Le, "MEKE_Le", restart_CS) .and. allocated(MEKE%Le)) then
- !$OMP parallel do default(shared)
- do j=js,je ; do i=is,ie
- MEKE%Le(i,j) = sqrt(G%areaT(i,j))
- enddo ; enddo
+ if (allocated(MEKE%Le)) then
+ if (.not.query_initialized(MEKE%Le, "MEKE_Le", restart_CS)) then
+ !$OMP parallel do default(shared)
+ do j=js,je ; do i=is,ie
+ MEKE%Le(i,j) = sqrt(G%areaT(i,j))
+ enddo ; enddo
+ endif
endif
! Set up group passes. In the case of a restart, these fields need a halo update now.
@@ -1870,7 +1875,10 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f
h_u(I,j,k) = 0.5*(h(i,j,k)*G%mask2dT(i,j) + h(i+1,j,k)*G%mask2dT(i+1,j)) + GV%Angstrom_H
h_v(i,J,k) = 0.5*(h(i,j,k)*G%mask2dT(i,j) + h(i,j+1,k)*G%mask2dT(i,j+1)) + GV%Angstrom_H
enddo ; enddo ; enddo
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: e)
call find_eta(h, tv, G, GV, US, e, halo_size=2)
+ !$omp target exit data map(from: e)
! Note the hard-coded dimenisional constant in the following line.
call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*1.e-7*GV%m2_s_to_HZ_T, .false., slope_x, slope_y)
call pass_vector(slope_x, slope_y, G%Domain)
diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90
index e277036716..26bc168730 100644
--- a/src/parameterizations/lateral/MOM_MEKE_types.F90
+++ b/src/parameterizations/lateral/MOM_MEKE_types.F90
@@ -1,6 +1,8 @@
-module MOM_MEKE_types
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
-! This file is part of MOM6. See LICENSE.md for the license.
+module MOM_MEKE_types
implicit none ; private
diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90
index db3542764d..8473c58b35 100644
--- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90
+++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90
@@ -1,8 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Calculates Zanna and Bolton 2020 parameterization
!! Implemented by Perezhogin P.A. Contact: pperezhogin@gmail.com
module MOM_Zanna_Bolton
-! This file is part of MOM6. See LICENSE.md for the license.
use MOM_grid, only : ocean_grid_type
use MOM_verticalGrid, only : verticalGrid_type
use MOM_diag_mediator, only : diag_ctrl, time_type
@@ -15,6 +18,7 @@ module MOM_Zanna_Bolton
use MOM_domains, only : pass_var, CORNER
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE
+use MOM_ANN, only : ANN_init, ANN_apply_array_sio, ANN_end, ANN_CS
implicit none ; private
@@ -76,6 +80,12 @@ module MOM_Zanna_Bolton
maskw_h, & !< Mask of land point at h points multiplied by filter weight [nondim]
maskw_q !< Same mask but for q points [nondim]
+ logical :: use_ann !< If True, momentum fluxes are inferred with ANN
+ integer :: stencil_size !< Default is 3x3
+ type(ANN_CS) :: ann_Tall !< ANN instance for off-diagonal and diagonal stress
+ character(len=200) :: ann_file_Tall !< Path to netcdf file with ANN
+ real :: subroundoff_shear !< Small dimensional constant for save division by zero [T-1 ~> s-1]
+
type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output
!>@{ Diagnostic handles
integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1
@@ -90,6 +100,7 @@ module MOM_Zanna_Bolton
integer :: id_clock_copy
integer :: id_clock_cdiss
integer :: id_clock_stress
+ integer :: id_clock_stress_ANN
integer :: id_clock_divergence
integer :: id_clock_mpi
integer :: id_clock_filter
@@ -141,6 +152,16 @@ subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020)
"subgrid momentum parameterization of mesoscale eddies.", default=.false.)
if (.not. use_ZB2020) return
+ call get_param(param_file, mdl, "ZB2020_USE_ANN", CS%use_ann, &
+ "ANN inference of momentum fluxes", default=.false.)
+
+ call get_param(param_file, mdl, "ZB2020_ANN_STENCIL_SIZE", CS%stencil_size, &
+ "ANN stencil size", default=3)
+
+ call get_param(param_file, mdl, "ZB2020_ANN_FILE_TALL", CS%ann_file_Tall, &
+ "ANN parameters for prediction of Txy, Txx and Tyy netcdf input", &
+ default="INPUT/EXP1/Tall.nc")
+
call get_param(param_file, mdl, "ZB_SCALING", CS%amplitude, &
"The nondimensional scaling factor in ZB model, " //&
"typically 0.5-2.5", units="nondim", default=0.5)
@@ -214,12 +235,18 @@ subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020)
CS%id_clock_copy = cpu_clock_id('(ZB2020 copy fields)', grain=CLOCK_ROUTINE, sync=.false.)
CS%id_clock_cdiss = cpu_clock_id('(ZB2020 compute c_diss)', grain=CLOCK_ROUTINE, sync=.false.)
CS%id_clock_stress = cpu_clock_id('(ZB2020 compute stress)', grain=CLOCK_ROUTINE, sync=.false.)
+ CS%id_clock_stress_ANN = cpu_clock_id('(ZB2020 compute stress ANN)', grain=CLOCK_ROUTINE, sync=.false.)
CS%id_clock_divergence = cpu_clock_id('(ZB2020 compute divergence)', grain=CLOCK_ROUTINE, sync=.false.)
CS%id_clock_mpi = cpu_clock_id('(ZB2020 filter MPI exchanges)', grain=CLOCK_ROUTINE, sync=.false.)
CS%id_clock_filter = cpu_clock_id('(ZB2020 filter no MPI)', grain=CLOCK_ROUTINE, sync=.false.)
CS%id_clock_post = cpu_clock_id('(ZB2020 post data)', grain=CLOCK_ROUTINE, sync=.false.)
CS%id_clock_source = cpu_clock_id('(ZB2020 compute energy source)', grain=CLOCK_ROUTINE, sync=.false.)
+ CS%subroundoff_shear = 1e-30 * US%T_to_s
+ if (CS%use_ann) then
+ call ANN_init(CS%ann_Tall, CS%ann_file_Tall)
+ endif
+
! Allocate memory
! We set the stress tensor and velocity gradient tensor to zero
! with full halo because they potentially may be filtered
@@ -237,13 +264,13 @@ subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020)
! Precomputing the scaling coefficient
! Mask is included to automatically satisfy B.C.
- do j=js-1,je+1 ; do i=is-1,ie+1
+ do j=js-2,je+2 ; do i=is-2,ie+2
CS%kappa_h(i,j) = -CS%amplitude * G%areaT(i,j) * G%mask2dT(i,j)
- enddo; enddo
+ enddo ; enddo
- do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2
CS%kappa_q(I,J) = -CS%amplitude * G%areaBu(I,J) * G%mask2dBu(I,J)
- enddo; enddo
+ enddo ; enddo
if (CS%Klower_R_diss > 0) then
allocate(CS%ICoriolis_h(SZI_(G),SZJ_(G)))
@@ -255,13 +282,13 @@ subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020)
CS%ICoriolis_h(i,j) = 1. / ((abs(0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) &
+ (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1)))) + subroundoff_Cor) &
* CS%Klower_R_diss)
- enddo; enddo
+ enddo ; enddo
endif
if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then
! Include 1/16. factor to the mask for filter implementation
- allocate(CS%maskw_h(SZI_(G),SZJ_(G))); CS%maskw_h(:,:) = G%mask2dT(:,:) * 0.0625
- allocate(CS%maskw_q(SZIB_(G),SZJB_(G))); CS%maskw_q(:,:) = G%mask2dBu(:,:) * 0.0625
+ allocate(CS%maskw_h(SZI_(G),SZJ_(G))) ; CS%maskw_h(:,:) = G%mask2dT(:,:) * 0.0625
+ allocate(CS%maskw_q(SZIB_(G),SZJB_(G))) ; CS%maskw_q(:,:) = G%mask2dBu(:,:) * 0.0625
endif
! Initialize MPI group passes
@@ -318,6 +345,10 @@ subroutine ZB2020_end(CS)
deallocate(CS%maskw_q)
endif
+ if (CS%use_ann) then
+ call ANN_end(CS%ann_Tall)
+ endif
+
end subroutine ZB2020_end
!> Save precomputed velocity gradients and thickness
@@ -359,7 +390,7 @@ subroutine ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, &
do J=js-1,Jeq ; do I=is-1,Ieq
CS%hq(I,J,k) = hq(I,J)
- enddo; enddo
+ enddo ; enddo
! No physical B.C. is required for
! sh_xx in ZB2020. However, filtering
@@ -373,11 +404,11 @@ subroutine ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, &
! flag in hor_visc module
do J=js-2,Jeq+1 ; do I=is-2,Ieq+1
CS%sh_xy(I,J,k) = sh_xy(I,J) * G%mask2dBu(I,J)
- enddo; enddo
+ enddo ; enddo
do J=js-2,Jeq+1 ; do I=is-2,Ieq+1
CS%vort_xy(I,J,k) = vort_xy(I,J) * G%mask2dBu(I,J)
- enddo; enddo
+ enddo ; enddo
call cpu_clock_end(CS%id_clock_copy)
@@ -416,14 +447,8 @@ subroutine ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS, &
real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2]
real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2]
- integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
- integer :: i, j, k, n
-
call cpu_clock_begin(CS%id_clock_module)
- is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
- Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
-
! Compute attenuation if specified
call compute_c_diss(G, GV, CS)
@@ -432,7 +457,11 @@ subroutine ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS, &
! Compute the stress tensor given the
! (optionally sharpened) velocity gradients
- call compute_stress(G, GV, CS)
+ if (CS%use_ann) then
+ call compute_stress_ANN_collocated(G, GV, CS)
+ else
+ call compute_stress(G, GV, CS)
+ endif
! Smooth the stress tensor if specified
call filter_stress(G, GV, CS)
@@ -466,7 +495,7 @@ subroutine compute_c_diss(G, GV, CS)
type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure.
integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
- integer :: i, j, k, n
+ integer :: i, j, k
real :: shear ! Shear in Klower2018 formula at h points [T-1 ~> s-1]
@@ -488,7 +517,7 @@ subroutine compute_c_diss(G, GV, CS)
+ ((CS%sh_xy(I-1,J ,k)**2) + (CS%sh_xy(I,J-1,k)**2)) &
))
CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j))
- enddo; enddo
+ enddo ; enddo
! sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2)
elseif (CS%Klower_shear == 1) then
@@ -500,7 +529,7 @@ subroutine compute_c_diss(G, GV, CS)
+ (CS%sh_xy(I,J-1,k)**2 + CS%vort_xy(I,J-1,k)**2)) &
))
CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j))
- enddo; enddo
+ enddo ; enddo
endif
enddo ! end of k loop
@@ -541,7 +570,7 @@ subroutine compute_stress(G, GV, CS)
real :: vort_sh ! vort_xy*sh_xy in h point [T-2 ~> s-2]
integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
- integer :: i, j, k, n
+ integer :: i, j, k
logical :: sum_sq_flag ! Flag to compute trace
logical :: vort_sh_scheme_0, vort_sh_scheme_1 ! Flags to compute diagonal trace-free part
@@ -613,6 +642,144 @@ subroutine compute_stress(G, GV, CS)
end subroutine compute_stress
+!> Compute stress tensor T =
+!! (Txx, Txy;
+!! Txy, Tyy)
+!! with ANN in non-dimensional form:
+!! T = dx^2 * |grad V|^2 * ANN(grad V / |grad V|)
+!! The sign of the stress tensor is such that:
+!! (du/dt, dv/dt) = 1/h * div(h * T)
+!! Algorithm:
+!! 1) Interpolate input features (sh_xy, sh_xx, vort_xy) to grid centers
+!! 2) Compute norm of velocity gradients on a stencil
+!! 3) Non-dimensionalize input features
+!! 4) Make ANN inference in grid centers
+!! 5) Restore physical dimensionality and interpolate Txy back to corners
+subroutine compute_stress_ANN_collocated(G, GV, CS)
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
+ type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure.
+
+ integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
+ integer :: i, j, k, m
+ integer :: ii, jj
+ integer :: nij
+
+ real, allocatable :: x(:,:) ! Vector of non-dimensional input features
+ ! number of horizontal grid points x
+ ! (sh_xy, sh_xx, vort_xy) on a stencil [nondim]
+ real, allocatable :: y(:,:) ! Vector of nondimensional
+ ! output features number of horizontal grid points x
+ ! (Txy,Txx,Tyy) [nondim]
+ real :: yy(3) ! Vector of dimensional
+ ! output features (Txy,Txx,Tyy) [L2 T-2 ~> m2 s-2]
+ real :: tmp ! Temporal value of squared norm [T-2 ~> s-2]
+ integer :: offset ! Half the stencil size. Used for selection
+ integer :: stencil_points ! The number of points after flattening
+
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: &
+ sh_xy_h, & ! sh_xy interpolated to the center [T-1 ~> s-1]
+ vort_xy_h, & ! vort_xy interpolated to the center [T-1 ~> s-1]
+ norm_h ! Norm of input feautres in center points [T-1 ~> s-1]
+
+ real, dimension(SZI_(G),SZJ_(G)) :: &
+ sqr_h, & ! Squared norm of velocity gradients in center points [T-2 ~> s-2]
+ Txy ! Predicted Txy in center points [T-1 ~> s-1]
+
+ call cpu_clock_begin(CS%id_clock_stress_ANN)
+
+ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
+ Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
+
+ ! Number of horizontal grid points in ANN inference loop below
+ nij = (ie - is + 5) * (je - js + 5)
+ allocate(x(nij, 3 * CS%stencil_size**2))
+ allocate(y(nij, 3))
+
+ sh_xy_h = 0.
+ vort_xy_h = 0.
+ norm_h = 0.
+
+ call pass_var(CS%sh_xy, G%Domain, clock=CS%id_clock_mpi, position=CORNER)
+ call pass_var(CS%sh_xx, G%Domain, clock=CS%id_clock_mpi)
+ call pass_var(CS%vort_xy, G%Domain, clock=CS%id_clock_mpi, position=CORNER)
+
+ offset = (CS%stencil_size-1)/2
+ stencil_points = CS%stencil_size**2
+
+ ! Interpolate input features
+ do k=1,nz
+ do j=js-2,je+2 ; do i=is-2,ie+2
+ ! It is assumed that B.C. is applied to sh_xy and vort_xy
+ sh_xy_h(i,j,k) = 0.25 * ( (CS%sh_xy(I-1,J-1,k) + CS%sh_xy(I,J,k)) &
+ + (CS%sh_xy(I-1,J,k) + CS%sh_xy(I,J-1,k)) )
+
+ vort_xy_h(i,j,k) = 0.25 * ( (CS%vort_xy(I-1,J-1,k) + CS%vort_xy(I,J,k)) &
+ + (CS%vort_xy(I-1,J,k) + CS%vort_xy(I,J-1,k)) )
+
+ sqr_h(i,j) = (((CS%sh_xx(i,j,k)**2) + (sh_xy_h(i,j,k)**2)) + (vort_xy_h(i,j,k)**2)) * G%mask2dT(i,j)
+ enddo ; enddo
+
+ do j=js,je ; do i=is,ie
+ tmp = 0.0
+ do jj=j-offset,j+offset ; do ii=i-offset,i+offset
+ tmp = tmp + sqr_h(ii,jj)
+ enddo ; enddo
+ norm_h(i,j,k) = sqrt(tmp)
+ enddo ; enddo
+ enddo
+
+ call pass_var(sh_xy_h, G%Domain, clock=CS%id_clock_mpi)
+ call pass_var(vort_xy_h, G%Domain, clock=CS%id_clock_mpi)
+ call pass_var(norm_h, G%Domain, clock=CS%id_clock_mpi)
+
+ do k=1,nz
+ m = 0
+ do j=js-2,je+2 ; do i=is-2,ie+2
+ m = m + 1
+ x(m,1:stencil_points) = &
+ RESHAPE(sh_xy_h(i-offset:i+offset, &
+ j-offset:j+offset,k), (/stencil_points/))
+ x(m,stencil_points+1:2*stencil_points) = &
+ RESHAPE(CS%sh_xx(i-offset:i+offset, &
+ j-offset:j+offset,k), (/stencil_points/))
+ x(m,2*stencil_points+1:3*stencil_points) = &
+ RESHAPE(vort_xy_h(i-offset:i+offset, &
+ j-offset:j+offset,k), (/stencil_points/))
+
+ x(m,:) = x(m,:) / (norm_h(i,j,k) + CS%subroundoff_shear)
+ enddo ; enddo
+
+ call ANN_apply_array_sio(nij, x, y, CS%ann_Tall)
+
+ m = 0
+ do j=js-2,je+2 ; do i=is-2,ie+2
+ m = m+1
+ yy(:) = y(m, :) * norm_h(i,j,k) * norm_h(i,j,k) * CS%kappa_h(i,j)
+
+ Txy(i,j) = yy(1)
+ CS%Txx(i,j,k) = yy(2)
+ CS%Tyy(i,j,k) = yy(3)
+ enddo ; enddo
+
+ do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ CS%Txy(I,J,k) = 0.25 * ( (Txy(i+1,j+1) + Txy(i,j)) &
+ + (Txy(i+1,j) + Txy(i,j+1))) * G%mask2dBu(I,J)
+ enddo ; enddo
+
+ enddo ! end of k loop
+
+ call pass_var(CS%Txy, G%Domain, clock=CS%id_clock_mpi, position=CORNER)
+ call pass_var(CS%Txx, G%Domain, clock=CS%id_clock_mpi)
+ call pass_var(CS%Tyy, G%Domain, clock=CS%id_clock_mpi)
+
+ deallocate(x)
+ deallocate(y)
+
+ call cpu_clock_end(CS%id_clock_stress_ANN)
+
+end subroutine compute_stress_ANN_collocated
+
!> Compute the divergence of subgrid stress
!! weighted with thickness, i.e.
!! (fx,fy) = 1/h Div(h * [Txx, Txy; Txy, Tyy])
@@ -712,24 +879,22 @@ subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy
enddo ; enddo
endif
- ! Evaluate 1/h x.Div(h S) (Line 1495 of MOM_hor_visc.F90)
- ! Minus occurs because in original file (du/dt) = - div(S),
- ! but here is the discretization of div(S)
+ ! Evaluate du/dt=1/h x.Div(h T) (Line 1495 of MOM_hor_visc.F90)
do j=js,je ; do I=Isq,Ieq
h_u = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_neglect
- fx = -((G%IdyCu(I,j)*(Mxx(i,j) - Mxx(i+1,j)) + &
- G%IdxCu(I,j)*(dx2q(I,J-1)*Mxy(I,J-1) - dx2q(I,J)*Mxy(I,J))) * &
+ fx = ((G%IdyCu(I,j)*(Mxx(i+1,j) - Mxx(i,j)) + &
+ G%IdxCu(I,j)*((dx2q(I,J)*Mxy(I,J)) - (dx2q(I,J-1)*Mxy(I,J-1)))) * &
G%IareaCu(I,j)) / h_u
diffu(I,j,k) = diffu(I,j,k) + fx
if (save_ZB2020u) &
ZB2020u(I,j,k) = fx
enddo ; enddo
- ! Evaluate 1/h y.Div(h S) (Line 1517 of MOM_hor_visc.F90)
+ ! Evaluate dv/dt=1/h y.Div(h T) (Line 1517 of MOM_hor_visc.F90)
do J=Jsq,Jeq ; do i=is,ie
h_v = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + h_neglect
- fy = -((G%IdxCv(i,J)*(Myy(i,j) - Myy(i,j+1)) + &
- G%IdyCv(i,J)*(dy2q(I-1,J)*Mxy(I-1,J) - dy2q(I,J)*Mxy(I,J))) * &
+ fy = ((G%IdxCv(i,J)*(Myy(i,j+1) - Myy(i,j)) + &
+ G%IdyCv(i,J)*((dy2q(I,J)*Mxy(I,J)) - (dy2q(I-1,J)*Mxy(I-1,J)))) * &
G%IareaCv(i,J)) / h_v
diffv(i,J,k) = diffv(i,J,k) + fy
if (save_ZB2020v) &
@@ -771,7 +936,7 @@ subroutine filter_velocity_gradients(G, GV, CS)
integer :: niter ! required number of iterations
integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
- integer :: i, j, k, n
+ integer :: i, j, k
niter = CS%HPF_iter
@@ -788,19 +953,19 @@ subroutine filter_velocity_gradients(G, GV, CS)
call cpu_clock_begin(CS%id_clock_filter)
do k=1,nz
! Halo of size 2 is valid
- do j=js-2,je+2; do i=is-2,ie+2
+ do j=js-2,je+2 ; do i=is-2,ie+2
sh_xx(i,j,k) = CS%sh_xx(i,j,k)
- enddo; enddo
+ enddo ; enddo
! Only halo of size 1 is valid
- do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1
+ do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
sh_xy(I,J,k) = CS%sh_xy(I,J,k)
vort_xy(I,J,k) = CS%vort_xy(I,J,k)
- enddo; enddo
+ enddo ; enddo
enddo
call cpu_clock_end(CS%id_clock_filter)
- xx_halo = 2; xy_halo = 1; vort_halo = 1;
- xx_iter = niter; xy_iter = niter; vort_iter = niter;
+ xx_halo = 2 ; xy_halo = 1 ; vort_halo = 1
+ xx_iter = niter ; xy_iter = niter ; vort_iter = niter
do while &
(xx_iter > 0 .or. xy_iter > 0 .or. & ! filter iterations remain to be done
@@ -820,7 +985,7 @@ subroutine filter_velocity_gradients(G, GV, CS)
! ------ filtering sh_xy, vort_xy ----
if (xy_halo < 1) then
call complete_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi)
- xy_halo = CS%HPF_halo; vort_halo = CS%HPF_halo
+ xy_halo = CS%HPF_halo ; vort_halo = CS%HPF_halo
endif
call filter_hq(G, GV, CS, xy_halo, xy_iter, q=CS%sh_xy)
@@ -835,13 +1000,13 @@ subroutine filter_velocity_gradients(G, GV, CS)
! B.C. are already applied to all fields
call cpu_clock_begin(CS%id_clock_filter)
do k=1,nz
- do j=js-2,je+2; do i=is-2,ie+2
+ do j=js-2,je+2 ; do i=is-2,ie+2
CS%sh_xx(i,j,k) = sh_xx(i,j,k) - CS%sh_xx(i,j,k)
- enddo; enddo
- do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1
+ enddo ; enddo
+ do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1
CS%sh_xy(I,J,k) = sh_xy(I,J,k) - CS%sh_xy(I,J,k)
CS%vort_xy(I,J,k) = vort_xy(I,J,k) - CS%vort_xy(I,J,k)
- enddo; enddo
+ enddo ; enddo
enddo
call cpu_clock_end(CS%id_clock_filter)
@@ -868,8 +1033,8 @@ subroutine filter_stress(G, GV, CS)
if (niter == 0) return
- Txx_halo = 1; Tyy_halo = 1; Txy_halo = 1; ! these are required halo for Txx, Tyy, Txy
- Txx_iter = niter; Tyy_iter = niter; Txy_iter = niter;
+ Txx_halo = 1 ; Tyy_halo = 1 ; Txy_halo = 1 ; ! these are required halo for Txx, Tyy, Txy
+ Txx_iter = niter ; Tyy_iter = niter ; Txy_iter = niter
do while &
(Txx_iter > 0 .or. Txy_iter > 0 .or. & ! filter iterations remain to be done
@@ -889,7 +1054,7 @@ subroutine filter_stress(G, GV, CS)
! ------- filtering Txx, Tyy ---------
if (Txx_halo < 1) then
call complete_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi)
- Txx_halo = CS%Stress_halo; Tyy_halo = CS%Stress_halo
+ Txx_halo = CS%Stress_halo ; Tyy_halo = CS%Stress_halo
endif
call filter_hq(G, GV, CS, Txx_halo, Txx_iter, h=CS%Txx)
@@ -993,21 +1158,21 @@ subroutine filter_3D(x, maskw, isd, ied, jsd, jed, is, ie, js, je, nz, &
do iter=1,niter
if (direction) then
- do j = js-halo, je+halo; do i = is-halo-1, ie+halo+1
+ do j = js-halo, je+halo ; do i = is-halo-1, ie+halo+1
tmp(i,j) = weight * x(i,j,k) + (x(i,j-1,k) + x(i,j+1,k))
- enddo; enddo
+ enddo ; enddo
- do j = js-halo, je+halo; do i = is-halo, ie+halo;
+ do j = js-halo, je+halo ; do i = is-halo, ie+halo
x(i,j,k) = (weight * tmp(i,j) + (tmp(i-1,j) + tmp(i+1,j))) * maskw(i,j)
- enddo; enddo
+ enddo ; enddo
else
- do j = js-halo-1, je+halo+1; do i = is-halo, ie+halo
+ do j = js-halo-1, je+halo+1 ; do i = is-halo, ie+halo
tmp(i,j) = weight * x(i,j,k) + (x(i-1,j,k) + x(i+1,j,k))
- enddo; enddo
+ enddo ; enddo
- do j = js-halo, je+halo; do i = is-halo, ie+halo;
+ do j = js-halo, je+halo ; do i = is-halo, ie+halo
x(i,j,k) = (weight * tmp(i,j) + (tmp(i,j-1) + tmp(i,j+1))) * maskw(i,j)
- enddo; enddo
+ enddo ; enddo
endif
halo = halo - 1
@@ -1076,7 +1241,7 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS)
G%dxCv(i,J)
KE_v(i,J) = vh * G%dyCv(i,J) * fy(i,J,k)
enddo ; enddo
- call do_group_pass(pass_KE_uv, G%domain)
+ call do_group_pass(pass_KE_uv, G%domain, clock=CS%id_clock_mpi)
do j=js,je ; do i=is,ie
KE_term(i,j,k) = 0.5 * G%IareaT(i,j) &
* ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1)))
diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90
index f6e45cffb0..a8ed92d76d 100644
--- a/src/parameterizations/lateral/MOM_hor_visc.F90
+++ b/src/parameterizations/lateral/MOM_hor_visc.F90
@@ -1,7 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Calculates horizontal viscosity and viscous stresses
module MOM_hor_visc
-! This file is part of MOM6. See LICENSE.md for the license.
use MOM_checksums, only : hchksum, Bchksum, uvchksum
use MOM_coms, only : min_across_PEs
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
@@ -20,7 +23,9 @@ module MOM_hor_visc
use MOM_io, only : MOM_read_data, slasher
use MOM_MEKE_types, only : MEKE_type
use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W
-use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE
+use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S
+use MOM_open_boundary, only : OBC_STRAIN_NONE, OBC_STRAIN_ZERO, OBC_STRAIN_FREESLIP
+use MOM_open_boundary, only : OBC_STRAIN_COMPUTED, OBC_STRAIN_SPECIFIED
use MOM_stochastics, only : stochastic_CS
use MOM_unit_scaling, only : unit_scale_type
use MOM_verticalGrid, only : verticalGrid_type
@@ -49,15 +54,11 @@ module MOM_hor_visc
!! are not implemented with the biharmonic viscosity.
logical :: bound_Kh !< If true, the Laplacian coefficient is locally
!! limited to guarantee stability.
- logical :: better_bound_Kh !< If true, use a more careful bounding of the
- !! Laplacian viscosity to guarantee stability.
logical :: EY24_EBT_BS !! If true, use an equivalent barotropic backscatter
!! with a stabilizing kill switch in MEKE,
!< developed by Yankovsky et al. 2024
logical :: bound_Ah !< If true, the biharmonic coefficient is locally
!! limited to guarantee stability.
- logical :: better_bound_Ah !< If true, use a more careful bounding of the
- !! biharmonic viscosity to guarantee stability.
real :: Re_Ah !! If nonzero, the biharmonic coefficient is scaled
!< so that the biharmonic Reynolds number is equal to this [nondim].
real :: bound_coef !< The nondimensional coefficient of the ratio of
@@ -101,8 +102,10 @@ module MOM_hor_visc
!! in setting the corner-point viscosities when USE_KH_BG_2D=True.
real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal
!! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0.
- logical :: FrictWork_bug !< If true, retain an answer-changing bug in calculating FrictWork,
+ logical :: FrictWork_bug !< If true, retain an answer-changing bug in calculating FrictWork,
!! which cancels the h in thickness flux and the h at velocity point.
+ logical :: OBC_strain_bug !< If true, recover a bug that specified shear strain option at open
+ !! boundaries cannot be applied.
logical :: use_land_mask !< Use the land mask for the computation of thicknesses
!! at velocity locations. This eliminates the dependence on
!! arbitrary values over land or outside of the domain.
@@ -133,12 +136,13 @@ module MOM_hor_visc
logical :: use_cont_thick_bug !< If true, retain an answer-changing bug for thickness at velocity points.
type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure.
logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization.
+ logical :: use_circulation !< If true, use circulation theorem to compute vorticity (for ZB20 or Leith)
real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx
!< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1].
!! The actual viscosity may be the larger of this
!! viscosity and the Smagorinsky and Leith viscosities.
- real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_2d
+ real, allocatable :: Kh_bg_2d(:,:)
!< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1].
!! The actual viscosity may be the larger of this
!! viscosity and the Smagorinsky and Leith viscosities.
@@ -149,12 +153,13 @@ module MOM_hor_visc
real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx
!< The amount by which stresses through h points are reduced
!! due to partial barriers [nondim].
+ real, allocatable :: Kh_Max_xx(:,:) !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1].
+ real, allocatable :: Ah_Max_xx(:,:) !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1].
+ real, allocatable :: Ah_Max_xx_KS(:,:) !< The maximum permitted biharmonic viscosity for
+ !! the kill switch [L4 T-1 ~> m4 s-1].
+ real, allocatable :: n1n2_h(:,:) !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim]
+ real, allocatable :: n1n1_m_n2n2_h(:,:) !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points [nondim]
real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: &
- Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1].
- Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1].
- 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 +173,20 @@ module MOM_hor_visc
real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy
!< The amount by which stresses through q points are reduced
!! due to partial barriers [nondim].
- real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: &
- Kh_Max_xy, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1].
- Ah_Max_xy, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1].
- 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 +201,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
@@ -442,9 +445,11 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
real :: grid_Kh ! Laplacian viscosity bound by grid [L2 T-1 ~> m2 s-1]
real :: grid_Ah ! Biharmonic viscosity bound by grid [L4 T-1 ~> m4 s-1]
- logical :: rescale_Kh, legacy_bound
+ logical :: rescale_Kh
logical :: find_FrictWork
+ logical :: find_FrictWork_bh
logical :: apply_OBC = .false.
+ logical :: apply_OBC_strain
logical :: use_MEKE_Ku
logical :: use_MEKE_Au
logical :: skeb_use_frict
@@ -473,6 +478,15 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim]
visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim]
+ ! New variables: move these up once ready
+ logical :: use_Leith ! True if any Leith parameterizations are enabled
+ logical :: use_vort_xy ! True if vort_xy must be computed
+ logical :: use_Smag ! True if a Smagorinsky viscosity is enabled
+
+ use_Leith = CS%Leith_Kh .or. CS%Leith_Ah .or. CS%use_Leithy
+ use_vort_xy = use_Leith .or. CS%id_vort_xy_q > 0 .or. CS%use_ZB2020
+ use_Smag = CS%Smagorinsky_Kh .or. CS%Smagorinsky_Ah
+
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
@@ -502,15 +516,22 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
apply_OBC = .true.
endif ; endif ; endif
+ apply_OBC_strain = .false.
+ if (present(OBC)) then ; if (associated(OBC)) then
+ apply_OBC_strain = (OBC%strain_config /= OBC_STRAIN_NONE) &
+ .and. ((.not. CS%OBC_strain_bug) .or. (OBC%strain_config /= OBC_STRAIN_SPECIFIED))
+ endif ; endif
+
if (.not.CS%initialized) call MOM_error(FATAL, &
"MOM_hor_visc: Module must be initialized before it is used.")
if (.not.(CS%Laplacian .or. CS%biharmonic)) return
- find_FrictWork = (CS%id_FrictWork > 0)
- if (CS%id_FrictWorkIntz > 0) find_FrictWork = .true.
+ find_FrictWork = CS%id_FrictWork > 0 .or. CS%id_FrictWorkIntz > 0 &
+ .or. allocated(MEKE%mom_src)
+ find_FrictWork_bh = CS%id_FrictWork_bh > 0 .or. CS%id_FrictWorkIntz_bh > 0 &
+ .or. allocated(MEKE%mom_src_bh)
- if (allocated(MEKE%mom_src)) find_FrictWork = .true.
use_kh_struct = allocated(VarMix%BS_struct)
backscat_subround = 0.0
if (find_FrictWork .and. allocated(MEKE%mom_src) .and. (MEKE%backscatter_Ro_c > 0.0) .and. &
@@ -554,9 +575,6 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
js_vort = js-2 ; je_vort = Jeq+1 ; is_vort = is-2 ; ie_vort = Ieq+1
endif
- legacy_bound = (CS%Smagorinsky_Kh .or. CS%Leith_Kh) .and. &
- (CS%bound_Kh .and. .not.CS%better_bound_Kh)
-
if (CS%use_GME) then
! Initialize diagnostic arrays with zeros
@@ -667,70 +685,50 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
! call pass_vector(slope_x, slope_y, G%Domain, halo=2)
endif
- !$OMP parallel do default(none) if (.not. CS%smooth_AH) &
- !$OMP shared( &
- !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, uh, vh, &
- !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, &
- !$OMP is_vort, ie_vort, js_vort, je_vort, &
- !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, &
- !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, use_kh_struct, skeb_use_frict, &
- !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, use_cont_huv, slope_x, slope_y, dz, &
- !$OMP backscat_subround, GME_effic_h, GME_effic_q, &
- !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, &
- !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_bh, FrictWork_GME, &
- !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, &
- !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt, hu_cont, hv_cont, STOCH &
- !$OMP ) &
- !$OMP private( &
- !$OMP i, j, k, n, tmp, &
- !$OMP dudx, dudy, dvdx, dvdy, sh_xx, sh_xy, h_u, h_v, &
- !$OMP Del2u, Del2v, DY_dxBu, DX_dyBu, sh_xx_bt, sh_xy_bt, &
- !$OMP str_xx, str_xy, bhstr_xx, bhstr_xy, str_xx_GME, str_xy_GME, &
- !$OMP vort_xy, vort_xy_dx, vort_xy_dy, div_xx, div_xx_dx, div_xx_dy, &
- !$OMP grad_div_mag_h, grad_div_mag_q, grad_vort_mag_h, grad_vort_mag_q, &
- !$OMP grad_vort, grad_vort_qg, grad_vort_mag_h_2d, grad_vort_mag_q_2d, &
- !$OMP sh_xx_sq, sh_xy_sq, meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, &
- !$OMP h_min, hrat_min, visc_bound_rem, Kh_max_here, &
- !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, &
- !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, &
- !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, &
- !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, &
- !$OMP dudx_smooth, dudy_smooth, dvdx_smooth, dvdy_smooth, &
- !$OMP vort_xy_smooth, vort_xy_dx_smooth, vort_xy_dy_smooth, &
- !$OMP sh_xx_smooth, sh_xy_smooth, &
- !$OMP vert_vort_mag_smooth, m_leithy, Ah_sq, AhLthy, &
- !$OMP Kh_BS, str_xx_bs, str_xy_bs, bs_coeff_h, bs_coeff_q &
- !$OMP ) &
- !$OMP firstprivate( &
- !$OMP visc_limit_h, visc_limit_h_frac, visc_limit_h_flag, &
- !$OMP visc_limit_q, visc_limit_q_frac, visc_limit_q_flag &
- !$OMP )
- do k=1,nz
+ !$omp target enter data map(alloc: dudx, dudy, dvdx, dvdy, sh_xx, sh_xy)
+ !$omp target enter data map(alloc: h_u, h_v, hq)
+ !$omp target enter data map(alloc: str_xx, str_xy)
+ !$omp target enter data map(alloc: Del2u, Del2v) if (CS%biharmonic)
+ !$omp target enter data map(alloc: dDel2vdx, dDel2udy) if (CS%biharmonic)
+ !$omp target enter data map(alloc: Shear_mag) if (use_Smag)
+ !$omp target enter data map(alloc: Kh) if (CS%Laplacian)
+ !$omp target enter data map(alloc: Ah) if (CS%biharmonic)
+ ! TODO: Only needed if FrictWork_bh is true, and currently only used on CPU,
+ ! but I do not yet see any benefit to breaking up the calculation.
+ !$omp target enter data map(alloc: bhstr_xx, bhstr_xy) if (CS%biharmonic)
+
+ !$omp target enter data map(alloc: hrat_min) &
+ !$omp if (CS%bound_Kh .or. CS%bound_Ah)
+ !$omp target enter data map(alloc: visc_bound_rem) &
+ !$omp if (CS%bound_Kh .or. CS%bound_Ah)
+ !$omp target enter data map(alloc: sh_xy_q) &
+ !$omp if (CS%id_sh_xy_q > 0)
+ do k=1,nz
! The following are the forms of the horizontal tension and horizontal
! shearing strain advocated by Smagorinsky (1993) and discussed in
! Griffies and Hallberg (2000).
- ! NOTE: There is a ~1% speedup when the tension and shearing loops below
- ! are fused (presumably due to shared access of Id[xy]C[uv]). However,
- ! this breaks the center/vertex index case convention, and also evaluates
- ! the dudx and dvdy terms beyond their valid bounds.
- ! TODO: Explore methods for retaining both the syntax and speedup.
-
! Calculate horizontal tension
- do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2
+ do concurrent (j=Jsq-1:Jeq+2, i=Isq-1:Ieq+2)
dudx(i,j) = CS%DY_dxT(i,j)*((G%IdyCu(I,j) * u(I,j,k)) - &
(G%IdyCu(I-1,j) * u(I-1,j,k)))
+ enddo
+
+ do concurrent (j=Jsq-1:Jeq+2, i=Isq-1:Ieq+2)
dvdy(i,j) = CS%DX_dyT(i,j)*((G%IdxCv(i,J) * v(i,J,k)) - &
(G%IdxCv(i,J-1) * v(i,J-1,k)))
+ enddo
+
+ do concurrent (j=Jsq-1:Jeq+2, i=Isq-1:Ieq+2)
sh_xx(i,j) = dudx(i,j) - dvdy(i,j)
- enddo ; enddo
+ enddo
! Components for the shearing strain
- do J=js_vort,je_vort ; do I=is_vort,ie_vort
+ do concurrent (J=js_vort:je_vort, I=is_vort:ie_vort)
dvdx(I,J) = CS%DY_dxBu(I,J)*((v(i+1,J,k)*G%IdyCv(i+1,J)) - (v(i,J,k)*G%IdyCv(i,J)))
dudy(I,J) = CS%DX_dyBu(I,J)*((u(I,j+1,k)*G%IdxCu(I,j+1)) - (u(I,j,k)*G%IdxCu(I,j)))
- enddo ; enddo
+ enddo
if (CS%use_Leithy) then
! Calculate horizontal tension from smoothed velocity
@@ -752,6 +750,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif ! use Leith+E
if (CS%id_normstress > 0) then
+ !$omp target update from(sh_xx)
do j=js,je ; do i=is,ie
NoSt(i,j,k) = sh_xx(i,j)
enddo ; enddo
@@ -763,54 +762,59 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
! even with OBCs if the accelerations are zeroed at OBC points, in which
! case the j-loop for h_u could collapse to j=js=1,je+1. -RWH
if (use_cont_huv) then
- do j=js-2,je+2 ; do I=Isq-1,Ieq+1
+ do concurrent (j=js-2:je+2, I=Isq-1:Ieq+1)
h_u(I,j) = hu_cont(I,j,k)
- enddo ; enddo
- do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2
+ enddo
+ do concurrent (J=Jsq-1:Jeq+1, i=is-2:ie+2)
h_v(i,J) = hv_cont(i,J,k)
- enddo ; enddo
+ enddo
elseif (CS%use_land_mask) then
- do j=js-2,je+2 ; do I=is-2,Ieq+1
+ do concurrent (j=js-2:je+2, I=is-2:Ieq+1)
h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k))
- enddo ; enddo
- do J=js-2,Jeq+1 ; do i=is-2,ie+2
+ enddo
+ do concurrent (J=js-2:Jeq+1, i=is-2:ie+2)
h_v(i,J) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k))
- enddo ; enddo
+ enddo
else
- do j=js-2,je+2 ; do I=is-2,Ieq+1
+ do concurrent (j=js-2:je+2, I=is-2:Ieq+1)
h_u(I,j) = 0.5 * (h(i,j,k) + h(i+1,j,k))
- enddo ; enddo
- do J=js-2,Jeq+1 ; do i=is-2,ie+2
+ enddo
+ do concurrent (J=js-2:Jeq+1, i=is-2:ie+2)
h_v(i,J) = 0.5 * (h(i,j,k) + h(i,j+1,k))
- enddo ; enddo
+ enddo
endif
! Adjust contributions to shearing strain and interpolated values of
! thicknesses on open boundaries.
- if (apply_OBC) then ; do n=1,OBC%number_of_segments
+ if (apply_OBC) then
+ !$omp target update from(dvdx, dudy, h_u, h_v)
+ ! TODO: Reindent this later
+ do n=1,OBC%number_of_segments
+
J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB
- if (OBC%zero_strain .or. OBC%freeslip_strain .or. OBC%computed_strain) then
+ if (apply_OBC_strain) then
if (OBC%segment(n)%is_N_or_S .and. (J >= Js_vort) .and. (J <= Je_vort)) then
do I = max(OBC%segment(n)%HI%IsdB,Is_vort), min(OBC%segment(n)%HI%IedB,Ie_vort)
- if (OBC%zero_strain) then
- dvdx(I,J) = 0. ; dudy(I,J) = 0.
- elseif (OBC%freeslip_strain) then
- dudy(I,J) = 0.
- elseif (OBC%computed_strain) then
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* &
- (OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%IdxCu(I,j)
- else
- dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* &
- (u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdxCu(I,j+1)
- endif
- elseif (OBC%specified_strain) then
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j)*G%dxBu(I,J)
- else
- dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j+1)*G%dxBu(I,J)
- endif
- endif
+ select case (OBC%strain_config)
+ case (OBC_STRAIN_ZERO)
+ dvdx(I,J) = 0. ; dudy(I,J) = 0.
+ case (OBC_STRAIN_FREESLIP)
+ dudy(I,J) = 0.
+ case (OBC_STRAIN_COMPUTED)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
+ dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* &
+ (OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%IdxCu(I,j)
+ else
+ dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* &
+ (u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdxCu(I,j+1)
+ endif
+ case (OBC_STRAIN_SPECIFIED)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
+ dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j)*G%dxBu(I,J)
+ else
+ dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j+1)*G%dxBu(I,J)
+ endif
+ end select
if (CS%use_Leithy) then
dvdx_smooth(I,J) = dvdx(I,J)
dudy_smooth(I,J) = dudy(I,J)
@@ -818,25 +822,26 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
enddo
elseif (OBC%segment(n)%is_E_or_W .and. (I >= is_vort) .and. (I <= ie_vort)) then
do J = max(OBC%segment(n)%HI%JsdB,js_vort), min(OBC%segment(n)%HI%JedB,je_vort)
- if (OBC%zero_strain) then
- dvdx(I,J) = 0. ; dudy(I,J) = 0.
- elseif (OBC%freeslip_strain) then
- dvdx(I,J) = 0.
- elseif (OBC%computed_strain) then
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* &
- (OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%IdyCv(i,J)
- else
- dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* &
- (v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdyCv(i+1,J)
- endif
- elseif (OBC%specified_strain) then
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i,J)*G%dxBu(I,J)
- else
- dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i+1,J)*G%dxBu(I,J)
- endif
- endif
+ select case (OBC%strain_config)
+ case (OBC_STRAIN_ZERO)
+ dvdx(I,J) = 0. ; dudy(I,J) = 0.
+ case (OBC_STRAIN_FREESLIP)
+ dvdx(I,J) = 0.
+ case (OBC_STRAIN_COMPUTED)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
+ dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* &
+ (OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%IdyCv(i,J)
+ else
+ dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* &
+ (v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdyCv(i+1,J)
+ endif
+ case (OBC_STRAIN_SPECIFIED)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
+ dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i,J)*G%dxBu(I,J)
+ else
+ dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i+1,J)*G%dxBu(I,J)
+ endif
+ end select
if (CS%use_Leithy) then
dvdx_smooth(I,J) = dvdx(I,J)
dudy_smooth(I,J) = dudy(I,J)
@@ -903,20 +908,27 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
enddo
endif
endif
- enddo ; endif
+ enddo
+ ! TODO: Fix indentation
+ !$omp target update to(dvdx, dudy, h_u, h_v)
+ endif
! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask).
! dudy and dvdx include modifications at OBCs from above.
if (CS%no_slip) then
- do J=js-2,Jeq+1 ; do I=is-2,Ieq+1
+ do concurrent (J=js-2:Jeq+1, I=is-2:Ieq+1)
sh_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) + dudy(I,J) )
- if (CS%id_shearstress > 0) ShSt(I,J,k) = sh_xy(I,J)
- enddo ; enddo
+ enddo
else
- do J=js-2,Jeq+1 ; do I=is-2,Ieq+1
+ do concurrent (J=js-2:Jeq+1, I=is-2:Ieq+1)
sh_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) + dudy(I,J) )
- if (CS%id_shearstress > 0) ShSt(I,J,k) = sh_xy(I,J)
- enddo ; enddo
+ enddo
+ endif
+
+ if (CS%id_shearstress > 0) then
+ do concurrent (J=js-2:Jeq+1, I=is-2:Ieq+1)
+ ShSt(I,J,k) = sh_xy(I,J)
+ enddo
endif
if (CS%use_Leithy) then
@@ -935,15 +947,18 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
! Evaluate Del2u = x.Div(Grad u) and Del2v = y.Div( Grad u)
if (CS%biharmonic) then
- do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1
+ do concurrent (j=js-1:Jeq+1, I=Isq-1:Ieq+1)
Del2u(I,j) = CS%Idx2dyCu(I,j) * ((CS%dx2q(I,J)*sh_xy(I,J)) - (CS%dx2q(I,J-1)*sh_xy(I,J-1))) + &
CS%Idxdy2u(I,j) * ((CS%dy2h(i+1,j)*sh_xx(i+1,j)) - (CS%dy2h(i,j)*sh_xx(i,j)))
- enddo ; enddo
- do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1
+ enddo
+
+ do concurrent (J=Jsq-1:Jeq+1, i=is-1:Ieq+1)
Del2v(i,J) = CS%Idxdy2v(i,J) * ((CS%dy2q(I,J)*sh_xy(I,J)) - (CS%dy2q(I-1,J)*sh_xy(I-1,J))) - &
CS%Idx2dyCv(i,J) * ((CS%dx2h(i,j+1)*sh_xx(i,j+1)) - (CS%dx2h(i,j)*sh_xx(i,j)))
- enddo ; enddo
+ enddo
+
if (apply_OBC) then ; if (OBC%zero_biharmonic) then
+ !$omp target update from(Del2u, Del2v)
do n=1,OBC%number_of_segments
I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then
@@ -956,19 +971,34 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
enddo
endif
enddo
+ !$omp target update to(Del2u, Del2v)
endif ; endif
endif
! Vorticity
- if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy) .or. (CS%id_vort_xy_q>0) .or. CS%use_ZB2020) then
+
+ ! NOTE: Keep Leith code on CPU for now, but moving it should be
+ ! straightforward.
+
+ if (use_vort_xy) then
+ !$omp target update from(dvdx, dudy)
if (CS%no_slip) then
do J=js_vort,je_vort ; do I=is_vort,ie_vort
vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) )
enddo ; enddo
else
- do J=js_vort,je_vort ; do I=is_vort,ie_vort
- vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) )
- enddo ; enddo
+ if (CS%use_circulation) then
+ do J=js_vort,je_vort ; do I=is_vort,ie_vort
+ vort_xy(I,J) = G%mask2dBu(I,J) * G%IareaBu(I,J) * ( &
+ ((v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J))) &
+ - ((u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j))) &
+ )
+ enddo ; enddo
+ else
+ do J=js_vort,je_vort ; do I=is_vort,ie_vort
+ vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) )
+ enddo ; enddo
+ endif
endif
endif
@@ -984,8 +1014,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif
endif
-
- if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then
+ if (use_Leith) then
! Vorticity gradient
do J=js-2,je_Kh ; do i=is_Kh-1,ie_Kh+1
@@ -1025,6 +1054,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
! endif
if (CS%modified_Leith) then
+ !$omp target update from(dudx, dvdy)
! Divergence
do j=js_Kh-1,je_Kh+1 ; do i=is_Kh-1,ie_Kh+1
@@ -1067,6 +1097,8 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif ! CS%modified_Leith
! Add in beta for the Leith viscosity
+ ! TODO: Move G%dF_dx, G%dF_dy to GPU
+
if (CS%use_beta_in_Leith) then
do J=js-2,Jeq+1 ; do i=is-1,ie+1
vort_xy_dx(i,J) = vort_xy_dx(i,J) + 0.5 * ( G%dF_dx(i,j) + G%dF_dx(i,j+1))
@@ -1114,19 +1146,19 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif ! CS%Leith_Kh
if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
sh_xx_sq = sh_xx(i,j)**2
sh_xy_sq = 0.25 * ( ((sh_xy(I-1,J-1)**2) + (sh_xy(I,J)**2)) &
+ ((sh_xy(I-1,J)**2) + (sh_xy(I,J-1)**2)) )
Shear_mag(i,j) = sqrt(sh_xx_sq + sh_xy_sq)
- enddo ; enddo
+ enddo
endif
- if (CS%better_bound_Ah .or. CS%better_bound_Kh) then
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ if (CS%bound_Ah .or. CS%bound_Kh) then
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
h_min = min(h_u(I,j), h_u(I-1,j), h_v(i,J), h_v(i,J-1))
hrat_min(i,j) = min(1.0, h_min / (h(i,j,k) + h_neglect))
- enddo ; enddo
+ enddo
endif
if (CS%Laplacian) then
@@ -1149,47 +1181,55 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif
! Static (pre-computed) background viscosity
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
Kh(i,j) = CS%Kh_bg_xx(i,j)
- enddo ; enddo
+ enddo
- ! NOTE: The following do-block can be decomposed and vectorized after the
- ! stack size has been reduced.
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- if (CS%add_LES_viscosity) then
- if (CS%Smagorinsky_Kh) &
+ if (CS%add_LES_viscosity) then
+ if (CS%Smagorinsky_Kh) then
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
Kh(i,j) = Kh(i,j) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j)
- if (CS%Leith_Kh) &
- Kh(i,j) = Kh(i,j) + CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3
- else
- if (CS%Smagorinsky_Kh) &
+ enddo
+ endif
+
+ if (CS%Leith_Kh) then
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
+ Kh(i,j) = Kh(i,j) &
+ + CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3
+ enddo
+ endif
+ else
+ if (CS%Smagorinsky_Kh) then
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
Kh(i,j) = max(Kh(i,j), CS%Laplac2_const_xx(i,j) * Shear_mag(i,j))
- if (CS%Leith_Kh) &
- Kh(i,j) = max(Kh(i,j), CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3)
+ enddo
endif
- enddo ; enddo
+
+ if (CS%Leith_Kh) then
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
+ Kh(i,j) = max(Kh(i,j), &
+ CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3)
+ enddo
+ endif
+ endif
! All viscosity contributions above are subject to resolution scaling
if (rescale_Kh) then
+ !$omp target update from(Kh)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
Kh(i,j) = VarMix%Res_fn_h(i,j) * Kh(i,j)
enddo ; enddo
- endif
-
- if (legacy_bound) then
- ! Older method of bounding for stability
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- Kh(i,j) = min(Kh(i,j), CS%Kh_Max_xx(i,j))
- enddo ; enddo
+ !$omp target update to(Kh)
endif
! Place a floor on the viscosity, if desired.
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min)
- enddo ; enddo
+ enddo
if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then
+ !$omp target update from(Kh)
! *Add* the MEKE contribution (which might be negative)
if (use_kh_struct) then
if (CS%res_scale_MEKE) then
@@ -1212,18 +1252,24 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
enddo ; enddo
endif
endif
+ !$omp target update to(Kh)
endif
if (CS%anisotropic) then
+ !$omp target update from(Kh)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
! *Add* the tension component of anisotropic viscosity
Kh(i,j) = Kh(i,j) + CS%Kh_aniso * (1. - CS%n1n2_h(i,j)**2)
enddo ; enddo
+ !$omp target update to(Kh)
endif
+ !$omp target update to(Kh) &
+ !$omp if ((use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) .or. CS%anisotropic)
+
! Newer method of bounding for stability
- if ((CS%better_bound_Kh) .and. (CS%better_bound_Ah)) then
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ if ((CS%bound_Kh) .and. (CS%bound_Ah)) then
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
visc_bound_rem(i,j) = 1.0
Kh_max_here = hrat_min(i,j) * CS%Kh_Max_xx(i,j)
if (Kh(i,j) >= Kh_max_here) then
@@ -1232,28 +1278,32 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
elseif ((Kh(i,j) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then
visc_bound_rem(i,j) = 1.0 - Kh(i,j) / Kh_max_here
endif
- enddo ; enddo
- elseif (CS%better_bound_Kh) then
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ enddo
+ elseif (CS%bound_Kh) then
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
Kh(i,j) = min(Kh(i,j), hrat_min(i,j) * CS%Kh_Max_xx(i,j))
- enddo ; enddo
+ enddo
endif
! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop.
! The harmonic component of str_xx is added in the biharmonic loop.
if (CS%use_Leithy) then
+ !$omp target update from(Kh)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
Kh(i,j) = 0.
enddo ; enddo
+ !$omp target update to(Kh)
endif
if (CS%id_Kh_h>0 .or. CS%debug) then
+ !$omp target update from(Kh)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
Kh_h(i,j,k) = Kh(i,j)
enddo ; enddo
endif
if (CS%id_grid_Re_Kh>0) then
+ !$omp target update from(Kh)
do j=js,je ; do i=is,ie
KE = 0.125*(((u(I,j,k)+u(I-1,j,k))**2) + ((v(i,J,k)+v(i,J-1,k))**2))
grid_Kh = max(Kh(i,j), CS%min_grid_Kh)
@@ -1262,69 +1312,77 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif
if (CS%id_div_xx_h>0) then
+ !$omp target update from(dudx, dvdy)
do j=js,je ; do i=is,ie
div_xx_h(i,j,k) = dudx(i,j) + dvdy(i,j)
enddo ; enddo
endif
if (CS%id_sh_xx_h>0) then
+ !$omp target update from(sh_xx)
do j=js,je ; do i=is,ie
sh_xx_h(i,j,k) = sh_xx(i,j)
enddo ; enddo
endif
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
str_xx(i,j) = -Kh(i,j) * sh_xx(i,j)
- enddo ; enddo
+ enddo
else
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
str_xx(i,j) = 0.0
- enddo ; enddo
+ enddo
endif ! Get Kh at h points and get Laplacian component of str_xx
if (CS%anisotropic) then
+ !$omp target update from(str_xx, sh_xy)
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
! Shearing-strain averaged to h-points
local_strain = 0.25 * ( (sh_xy(I,J) + sh_xy(I-1,J-1)) + (sh_xy(I-1,J) + sh_xy(I,J-1)) )
! *Add* the shear-strain contribution to the xx-component of stress
str_xx(i,j) = str_xx(i,j) - CS%Kh_aniso * CS%n1n2_h(i,j) * CS%n1n1_m_n2n2_h(i,j) * local_strain
enddo ; enddo
+ !$omp target update to(str_xx)
endif
if (CS%biharmonic) then
! Determine the biharmonic viscosity at h points, using the
! largest value from several parameterizations. Also get the
! biharmonic component of str_xx.
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
Ah(i,j) = CS%Ah_bg_xx(i,j)
- enddo ; enddo
+ enddo
if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then
if (CS%Smagorinsky_Ah) then
if (CS%bound_Coriolis) then
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
AhSm = Shear_mag(i,j) * (CS%Biharm_const_xx(i,j) &
+ CS%Biharm_const2_xx(i,j) * Shear_mag(i,j))
Ah(i,j) = max(Ah(i,j), AhSm)
- enddo ; enddo
+ enddo
else
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
AhSm = CS%Biharm_const_xx(i,j) * Shear_mag(i,j)
Ah(i,j) = max(Ah(i,j), AhSm)
- enddo ; enddo
+ enddo
endif
endif
if (CS%Leith_Ah) then
+ !$omp target update from(Ah)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + &
(Del2vort_q(I-1,J) + Del2vort_q(I,J-1)))
AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h) * inv_PI6
Ah(i,j) = max(Ah(i,j), AhLth)
enddo ; enddo
+ !$omp target update to(Ah)
endif
if (CS%use_Leithy) then
+ ! TODO: !$omp target update from(...?)
+
! Get m_leithy
if (CS%smooth_Ah) m_leithy(:,:) = 0.0 ! This is here to initialize domain edge halo values.
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
@@ -1377,52 +1435,52 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
enddo ; enddo
endif
endif
-
- if (CS%bound_Ah .and. .not. CS%better_bound_Ah) then
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- Ah(i,j) = min(Ah(i,j), CS%Ah_Max_xx(i,j))
- enddo ; enddo
- endif
endif ! Smagorinsky_Ah or Leith_Ah or Leith+E
if (use_MEKE_Au) then
! *Add* the MEKE contribution
+ !$omp target update from(Ah)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
Ah(i,j) = Ah(i,j) + MEKE%Au(i,j)
enddo ; enddo
+ !$omp target update to(Ah)
endif
if (CS%Re_Ah > 0.0) then
+ !$omp target update from(Ah)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
KE = 0.125*(((u(I,j,k)+u(I-1,j,k))**2) + ((v(i,J,k)+v(i,J-1,k))**2))
Ah(i,j) = sqrt(KE) * CS%Re_Ah_const_xx(i,j)
enddo ; enddo
+ !$omp target update to(Ah)
endif
- if (CS%better_bound_Ah) then
- if (CS%better_bound_Kh) then
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ if (CS%bound_Ah) then
+ if (CS%bound_Kh) then
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
Ah(i,j) = min(Ah(i,j), visc_bound_rem(i,j) * hrat_min(i,j) * CS%Ah_Max_xx(i,j))
- enddo ; enddo
+ enddo
else
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ do concurrent (j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
Ah(i,j) = min(Ah(i,j), hrat_min(i,j) * CS%Ah_Max_xx(i,j))
- enddo ; enddo
+ enddo
endif
endif
if (CS%EY24_EBT_BS) then
- do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
- tmp = CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j)
- visc_limit_h(i,j,k) = tmp
- visc_limit_h_frac(i,j,k) = Ah(i,j) / (CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j))
- if (Ah(i,j) >= tmp) then
- visc_limit_h_flag(i,j,k) = 1.
- endif
- enddo ; enddo
+ !$omp target update from(Ah)
+ do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
+ tmp = CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j)
+ visc_limit_h(i,j,k) = tmp
+ visc_limit_h_frac(i,j,k) = Ah(i,j) / (CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j))
+ if (Ah(i,j) >= tmp) then
+ visc_limit_h_flag(i,j,k) = 1.
+ endif
+ enddo ; enddo
endif
if ((CS%id_Ah_h>0) .or. CS%debug .or. CS%use_Leithy) then
+ !$omp target update from(Ah)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
Ah_h(i,j,k) = Ah(i,j)
enddo ; enddo
@@ -1431,13 +1489,16 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
if (CS%use_Leithy) then
! Compute Leith+E Kh after bounds have been applied to Ah
! and after it has been smoothed. Kh = -m_leithy * Ah
+ !$omp target update from(Ah, Kh)
do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
Kh(i,j) = -m_leithy(i,j) * Ah(i,j)
Kh_h(i,j,k) = Kh(i,j)
enddo ; enddo
+ !$omp target update to(Kh)
endif
if (CS%id_grid_Re_Ah > 0) then
+ !$omp target update from(Ah)
do j=js,je ; do i=is,ie
KE = 0.125 * (((u(I,j,k) + u(I-1,j,k))**2) + ((v(i,J,k) + v(i,J-1,k))**2))
grid_Ah = max(Ah(i,j), CS%min_grid_Ah)
@@ -1445,22 +1506,30 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
enddo ; enddo
endif
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
d_del2u = (G%IdyCu(I,j) * Del2u(I,j)) - (G%IdyCu(I-1,j) * Del2u(I-1,j))
d_del2v = (G%IdxCv(i,J) * Del2v(i,J)) - (G%IdxCv(i,J-1) * Del2v(i,J-1))
d_str = Ah(i,j) * ((CS%DY_dxT(i,j) * d_del2u) - (CS%DX_dyT(i,j) * d_del2v))
str_xx(i,j) = str_xx(i,j) + d_str
- if (CS%use_Leithy) str_xx(i,j) = str_xx(i,j) - Kh(i,j) * sh_xx_smooth(i,j)
-
! Keep a copy of the biharmonic contribution for backscatter parameterization
- bhstr_xx(i,j) = d_str * (h(i,j,k) * CS%reduction_xx(i,j))
- enddo ; enddo
+ ! XXX: Need to get out of the loop somehow
+ if (find_FrictWork_bh) &
+ bhstr_xx(i,j) = d_str * (h(i,j,k) * CS%reduction_xx(i,j))
+ enddo
+
+ if (CS%use_Leithy) then
+ !$omp target update from(Kh)
+ do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ str_xx(i,j) = str_xx(i,j) - Kh(i,j) * sh_xx_smooth(i,j)
+ enddo ; enddo
+ endif
endif ! Get biharmonic coefficient at h points and biharmonic part of str_xx
! Backscatter using MEKE
if (CS%EY24_EBT_BS) then
+ !$omp target update from(sh_xx)
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
if (visc_limit_h_flag(i,j,k) > 0) then
Kh_BS(i,j) = 0.
@@ -1486,63 +1555,68 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
str_xx(i,j) = str_xx(i,j) + str_xx_BS(i,j)
enddo ; enddo
+ !$omp target update to(str_xx)
endif ! Backscatter
if (CS%biharmonic) then
! Gradient of Laplacian, for use in bi-harmonic term
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
dDel2vdx(I,J) = CS%DY_dxBu(I,J)*((Del2v(i+1,J)*G%IdyCv(i+1,J)) - (Del2v(i,J)*G%IdyCv(i,J)))
dDel2udy(I,J) = CS%DX_dyBu(I,J)*((Del2u(I,j+1)*G%IdxCu(I,j+1)) - (Del2u(I,j)*G%IdxCu(I,j)))
- enddo ; enddo
+ enddo
+
! Adjust contributions to shearing strain on open boundaries.
- if (apply_OBC) then ; if (OBC%zero_strain .or. OBC%freeslip_strain) then
+ if (apply_OBC) then ; if ((OBC%strain_config == OBC_STRAIN_ZERO) .or. &
+ (OBC%strain_config == OBC_STRAIN_FREESLIP)) then
+ !$omp target update from(dDel2vdx, dDel2udy)
do n=1,OBC%number_of_segments
J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB
if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= Jeq)) then
do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB
- if (OBC%zero_strain) then
+ if (OBC%strain_config == OBC_STRAIN_ZERO) then
dDel2vdx(I,J) = 0. ; dDel2udy(I,J) = 0.
- elseif (OBC%freeslip_strain) then
+ elseif (OBC%strain_config == OBC_STRAIN_FREESLIP) then
dDel2udy(I,J) = 0.
endif
enddo
elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= Ieq)) then
do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB
- if (OBC%zero_strain) then
+ if (OBC%strain_config == OBC_STRAIN_ZERO) then
dDel2vdx(I,J) = 0. ; dDel2udy(I,J) = 0.
- elseif (OBC%freeslip_strain) then
+ elseif (OBC%strain_config == OBC_STRAIN_FREESLIP) then
dDel2vdx(I,J) = 0.
endif
enddo
endif
enddo
+ !$omp target update to(dDel2vdx, dDel2udy)
endif ; endif
endif
if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
sh_xy_sq = sh_xy(I,J)**2
sh_xx_sq = 0.25 * ( ((sh_xx(i,j)**2) + (sh_xx(i+1,j+1)**2)) &
+ ((sh_xx(i,j+1)**2) + (sh_xx(i+1,j)**2)) )
Shear_mag(I,J) = sqrt(sh_xy_sq + sh_xx_sq)
- enddo ; enddo
+ enddo
endif
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
h2uq = 4.0 * (h_u(I,j) * h_u(I,j+1))
h2vq = 4.0 * (h_v(i,J) * h_v(i+1,J))
hq(I,J) = (2.0 * (h2uq * h2vq)) &
/ (h_neglect3 + (h2uq + h2vq) * ((h_u(I,j) + h_u(I,j+1)) + (h_v(i,J) + h_v(i+1,J))))
- enddo ; enddo
+ enddo
- if (CS%better_bound_Ah .or. CS%better_bound_Kh) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ if (CS%bound_Ah .or. CS%bound_Kh) then
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
h_min = min(h_u(I,j), h_u(I,j+1), h_v(i,J), h_v(i+1,J))
hrat_min(I,J) = min(1.0, h_min / (hq(I,J) + h_neglect))
- enddo ; enddo
-
+ enddo
endif
+ ! TODO: GPU?? Are h_[uv] on CPU? update to hrat_min?
if (CS%no_slip) then
do J=js-1,Jeq ; do I=is-1,Ieq
if (CS%no_slip .and. (G%mask2dBu(I,J) < 0.5)) then
@@ -1569,9 +1643,20 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
! Pass the velocity gradients and thickness to ZB2020
if (CS%use_ZB2020) then
- call ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, G, GV, CS%ZB2020, k)
+ !$omp target update to(sh_xx, sh_xy, vort_xy, hq)
+ call ZB2020_copy_gradient_and_thickness( &
+ sh_xx, sh_xy, vort_xy, &
+ hq, &
+ G, GV, CS%ZB2020, k)
endif
+ !!$omp target update from(sh_xx, sh_xy)
+ !!$omp target update from(h_u, h_v, hq)
+ !!$omp target update from(str_xx)
+ !!$omp target update from(Shear_mag) if (use_Smag)
+ !!$omp target update from(Del2u, Del2v) if (CS%biharmonic)
+ !!$omp target update from(dDel2vdx, dDel2udy) if (CS%biharmonic)
+
if (CS%Laplacian) then
! Determine the Laplacian viscosity at q points, using the
! largest value from several parameterizations. Also get the
@@ -1592,23 +1677,24 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif
! Static (pre-computed) background viscosity
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
Kh(I,J) = CS%Kh_bg_xy(I,J)
- enddo ; enddo
+ enddo
if (CS%Smagorinsky_Kh) then
if (CS%add_LES_viscosity) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
Kh(I,J) = Kh(I,J) + CS%Laplac2_const_xy(I,J) * Shear_mag(I,J)
- enddo ; enddo
+ enddo
else
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
Kh(I,J) = max(Kh(I,J), CS%Laplac2_const_xy(I,J) * Shear_mag(I,J) )
- enddo ; enddo
+ enddo
endif
endif
if (CS%Leith_Kh) then
+ !$omp target update from(Kh)
if (CS%add_LES_viscosity) then
do J=js-1,Jeq ; do I=is-1,Ieq
Kh(I,J) = Kh(I,J) + CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J) * inv_PI3 ! Is this right? -AJA
@@ -1618,28 +1704,25 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
Kh(I,J) = max(Kh(I,J), CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J) * inv_PI3)
enddo ; enddo
endif
+ !$omp target update to(Kh)
endif
! All viscosity contributions above are subject to resolution scaling
if (rescale_Kh) then
+ !$omp target update from(Kh)
do J=js-1,Jeq ; do I=is-1,Ieq
Kh(I,J) = VarMix%Res_fn_q(I,J) * Kh(I,J)
enddo ; enddo
+ !$omp target update to(Kh)
endif
- if (legacy_bound) then
- ! Older method of bounding for stability
- do J=js-1,Jeq ; do I=is-1,Ieq
- Kh(I,J) = min(Kh(I,J), CS%Kh_Max_xy(I,J))
- enddo ; enddo
- endif
-
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
Kh(I,J) = max(Kh(I,J), CS%Kh_bg_min) ! Place a floor on the viscosity, if desired.
- enddo ; enddo
+ enddo
if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then
+ !$omp target update from(Kh)
if (use_kh_struct) then
do J=js-1,Jeq ; do I=is-1,Ieq
meke_res_fn = 1.
@@ -1661,18 +1744,21 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
MEKE%Ku(i,j+1)) ) * meke_res_fn
enddo ; enddo
endif
+ !$omp target update to(Kh)
endif
if (CS%anisotropic) then
+ !$omp target update from(Kh)
! *Add* the shear component of anisotropic viscosity
do J=js-1,Jeq ; do I=is-1,Ieq
Kh(I,J) = Kh(I,J) + CS%Kh_aniso * CS%n1n2_q(I,J)**2
enddo ; enddo
+ !$omp target update to(Kh)
endif
- do J=js-1,Jeq ; do I=is-1,Ieq
+ if ((CS%bound_Kh) .and. (CS%bound_Ah)) then
! Newer method of bounding for stability
- if ((CS%better_bound_Kh) .and. (CS%better_bound_Ah)) then
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
visc_bound_rem(I,J) = 1.0
Kh_max_here = hrat_min(I,J) * CS%Kh_Max_xy(I,J)
if (Kh(I,J) >= Kh_max_here) then
@@ -1681,20 +1767,24 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
elseif ((Kh(I,J) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then
visc_bound_rem(I,J) = 1.0 - Kh(I,J) / Kh_max_here
endif
- elseif (CS%better_bound_Kh) then
+ enddo
+ elseif (CS%bound_Kh) then
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
Kh(I,J) = min(Kh(I,J), hrat_min(I,J) * CS%Kh_Max_xy(I,J))
- endif
- enddo ; enddo
+ enddo
+ endif
if (CS%use_Leithy) then
! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points
do J=js-1,Jeq ; do I=is-1,Ieq
Kh(I,J) = 0.25 * ((Kh_h(i,j,k) + Kh_h(i+1,j+1,k)) + (Kh_h(i,j+1,k) + Kh_h(i+1,j,k)))
enddo ; enddo
- end if
+ !$omp target update to(Kh)
+ endif
if (CS%id_Kh_q > 0 .or. CS%debug) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ !$omp target update from (Kh)
+ do J=js-1,Jeq; do I=is-1,Ieq
Kh_q(I,J,k) = Kh(I,J)
enddo ; enddo
endif
@@ -1706,101 +1796,107 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif
if (CS%id_sh_xy_q > 0) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
sh_xy_q(I,J,k) = sh_xy(I,J)
- enddo ; enddo
+ enddo
endif
if (.not. CS%use_Leithy) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
str_xy(I,J) = -Kh(I,J) * sh_xy(I,J)
- enddo ; enddo
+ enddo
else
+ !$omp target update from(Kh)
do J=js-1,Jeq ; do I=is-1,Ieq
str_xy(I,J) = -Kh(I,J) * sh_xy_smooth(I,J)
enddo ; enddo
+ !$omp target update to(str_xy)
endif
else
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
str_xy(I,J) = 0.
- enddo ; enddo
+ enddo
endif ! get harmonic coefficient Kh at q points and harmonic part of str_xy
if (CS%anisotropic) then
+ !$omp target update from(sh_xx, str_xy)
do J=js-1,Jeq ; do I=is-1,Ieq
! Horizontal-tension averaged to q-points
local_strain = 0.25 * ( (sh_xx(i,j) + sh_xx(i+1,j+1)) + (sh_xx(i+1,j) + sh_xx(i,j+1)) )
! *Add* the tension contribution to the xy-component of stress
str_xy(I,J) = str_xy(I,J) - CS%Kh_aniso * CS%n1n2_q(I,J) * CS%n1n1_m_n2n2_q(I,J) * local_strain
enddo ; enddo
+ !$omp target update to(str_xy)
endif
if (CS%biharmonic) then
! Determine the biharmonic viscosity at q points, using the
! largest value from several parameterizations. Also get the
! biharmonic component of str_xy.
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
Ah(I,J) = CS%Ah_bg_xy(I,J)
- enddo ; enddo
+ enddo
if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then
if (CS%Smagorinsky_Ah) then
if (CS%bound_Coriolis) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
AhSm = Shear_mag(I,J) * (CS%Biharm_const_xy(I,J) &
+ CS%Biharm_const2_xy(I,J) * Shear_mag(I,J))
Ah(I,J) = max(Ah(I,J), AhSm)
- enddo ; enddo
+ enddo
else
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
AhSm = CS%Biharm_const_xy(I,J) * Shear_mag(I,J)
Ah(I,J) = max(Ah(I,J), AhSm)
- enddo ; enddo
+ enddo
endif
endif
if (CS%Leith_Ah) then
+ !$omp target update from(Ah)
do J=js-1,Jeq ; do I=is-1,Ieq
AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J)) * inv_PI6
Ah(I,J) = max(Ah(I,J), AhLth)
enddo ; enddo
- endif
-
- if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then
- do J=js-1,Jeq ; do I=is-1,Ieq
- Ah(I,J) = min(Ah(I,J), CS%Ah_Max_xy(I,J))
- enddo ; enddo
+ !$omp target update to(Ah)
endif
endif ! Smagorinsky_Ah or Leith_Ah
if (use_MEKE_Au) then
+ !$omp target update from(Ah)
! *Add* the MEKE contribution
do J=js-1,Jeq ; do I=is-1,Ieq
Ah(I,J) = Ah(I,J) + 0.25 * ( &
(MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) )
enddo ; enddo
+ !$omp target update to(Ah)
endif
+ ! XXX: It is just overwrites the values!
if (CS%Re_Ah > 0.0) then
do J=js-1,Jeq ; do I=is-1,Ieq
KE = 0.125 * (((u(I,j,k) + u(I,j+1,k))**2) + ((v(i,J,k) + v(i+1,J,k))**2))
Ah(I,J) = sqrt(KE) * CS%Re_Ah_const_xy(I,J)
enddo ; enddo
+ !$omp target update to(Ah)
endif
- if (CS%better_bound_Ah) then
- if (CS%better_bound_Kh) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ if (CS%bound_Ah) then
+ if (CS%bound_Kh) then
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
Ah(I,J) = min(Ah(I,J), visc_bound_rem(I,J) * hrat_min(I,J) * CS%Ah_Max_xy(I,J))
- enddo ; enddo
+ enddo
else
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
Ah(I,J) = min(Ah(I,J), hrat_min(I,J) * CS%Ah_Max_xy(I,J))
- enddo ; enddo
+ enddo
endif
endif
if (CS%EY24_EBT_BS) then
+ ! TODO: Fix indent!
+ !$omp target update from(Ah, hrat_min)
do J=js-1,Jeq ; do I=is-1,Ieq
tmp = CS%KS_coef *hrat_min(I,J) * CS%Ah_Max_xy_KS(I,J)
visc_limit_q(I,J,k) = tmp
@@ -1816,27 +1912,31 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
do J=js-1,Jeq ; do I=is-1,Ieq
Ah(I,J) = 0.25 * ((Ah_h(i,j,k) + Ah_h(i+1,j+1,k)) + (Ah_h(i,j+1,k) + Ah_h(i+1,j,k)))
enddo ; enddo
- end if
+ !$omp target update to(Ah)
+ endif
if (CS%id_Ah_q>0 .or. CS%debug) then
+ !$omp target update from(Ah)
do J=js-1,Jeq ; do I=is-1,Ieq
Ah_q(I,J,k) = Ah(I,J)
enddo ; enddo
endif
! Again, need to initialize str_xy as if its biharmonic
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
d_str = Ah(I,J) * (dDel2vdx(I,J) + dDel2udy(I,J))
str_xy(I,J) = str_xy(I,J) + d_str
! Keep a copy of the biharmonic contribution for backscatter parameterization
+ ! NOTE: computing this ought to be conditional! But it uses d_str...
bhstr_xy(I,J) = d_str * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J))
- enddo ; enddo
+ enddo
endif ! Get Ah at q points and biharmonic part of str_xy
! Backscatter using MEKE
if (CS%EY24_EBT_BS) then
+ !$omp target update from(sh_xy, str_xy)
do J=js-1,Jeq ; do I=is-1,Ieq
if (visc_limit_q_flag(I,J,k) > 0) then
Kh_BS(I,J) = 0.
@@ -1866,9 +1966,13 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
do J=js-1,Jeq ; do I=is-1,Ieq
str_xy(I,J) = str_xy(I,J) + str_xy_BS(I,J)
enddo ; enddo
+ !$omp target update to(str_xy)
endif ! Backscatter
if (CS%use_GME) then
+ !$omp target update from(str_xx, str_xy)
+ !$omp target update from(hq) if (CS%no_slip)
+
! The wider halo here is to permit one pass of smoothing without a halo update.
do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2
GME_coeff = GME_effic_h(i,j) * 0.25 * &
@@ -1908,33 +2012,34 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J))
enddo ; enddo
endif
-
+ !$omp target update to(str_xx, str_xy)
else ! .not. use_GME
! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2].
- do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
str_xx(i,j) = str_xx(i,j) * (h(i,j,k) * CS%reduction_xx(i,j))
- enddo ; enddo
+ enddo
! This changes the units of str_xy from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2].
if (CS%no_slip) then
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
str_xy(I,J) = str_xy(I,J) * (hq(I,J) * CS%reduction_xy(I,J))
- enddo ; enddo
+ enddo
else
- do J=js-1,Jeq ; do I=is-1,Ieq
+ do concurrent (J=js-1:Jeq, I=is-1:Ieq)
str_xy(I,J) = str_xy(I,J) * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J))
- enddo ; enddo
+ enddo
endif
endif ! use_GME
! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent.
- do j=js,je ; do I=Isq,Ieq
+ do concurrent (j=js:je, I=Isq:Ieq)
diffu(I,j,k) = ((G%IdxCu(I,j)*((CS%dx2q(I,J-1)*str_xy(I,J-1)) - (CS%dx2q(I,J)*str_xy(I,J))) + &
G%IdyCu(I,j)*((CS%dy2h(i,j)*str_xx(i,j)) - (CS%dy2h(i+1,j)*str_xx(i+1,j)))) * &
G%IareaCu(I,j)) / (h_u(I,j) + h_neglect)
- enddo ; enddo
+ enddo
if (apply_OBC) then
+ !$omp target update from(diffu)
! This is not the right boundary condition. If all the masking of tendencies are done
! correctly later then eliminating this block should not change answers.
do n=1,OBC%number_of_segments
@@ -1945,16 +2050,18 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
enddo
endif
enddo
+ !$omp target update to(diffu)
endif
! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent.
- do J=Jsq,Jeq ; do i=is,ie
+ do concurrent (J=Jsq:Jeq, i=is:ie)
diffv(i,J,k) = ((G%IdyCv(i,J)*((CS%dy2q(I-1,J)*str_xy(I-1,J)) - (CS%dy2q(I,J)*str_xy(I,J))) - &
G%IdxCv(i,J)*((CS%dx2h(i,j)*str_xx(i,j)) - (CS%dx2h(i,j+1)*str_xx(i,j+1)))) * &
G%IareaCv(i,J)) / (h_v(i,J) + h_neglect)
- enddo ; enddo
+ enddo
if (apply_OBC) then
+ !$omp target update from(diffv)
! This is not the right boundary condition. If all the masking of tendencies are done
! correctly later then eliminating this block should not change answers.
do n=1,OBC%number_of_segments
@@ -1965,9 +2072,15 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
enddo
endif
enddo
+ !$omp target update to(diffv)
endif
+ !$omp target update from(h_u, h_v) &
+ !$omp if ((find_Frictwork .or. find_FrictWork_bh) .and. .not. CS%FrictWork_bug)
+
if (find_FrictWork) then
+ !$omp target update from(str_xx, str_xy)
+
if (CS%FrictWork_bug) then
! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v)
! This is the old formulation that includes energy diffusion
@@ -2028,7 +2141,8 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif
endif
- if (CS%id_FrictWork_bh>0 .or. CS%id_FrictWorkIntz_bh > 0 .or. allocated(MEKE%mom_src_bh)) then
+ if (find_FrictWork_bh) then
+ !$omp target update from(bhstr_xx, bhstr_xy)
if (CS%FrictWork_bug) then
! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v)
! This is the old formulation that includes energy diffusion !cyc
@@ -2168,6 +2282,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif
endif
if (MEKE%backscatter_Ro_c /= 0.) then
+ !$omp target update from(sh_xx, sh_xy)
do j=js,je ; do i=is,ie
FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + &
(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) )
@@ -2218,6 +2333,21 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif ! find_FrictWork and associated(mom_src)
enddo ! end of k loop
+ !$omp target exit data map(delete: dudx, dudy, dvdx, dvdy, sh_xx, sh_xy)
+ !$omp target exit data map(delete: h_u, h_v, hq)
+ !$omp target exit data map(delete: str_xx, str_xy)
+ !$omp target exit data map(delete: Del2u, Del2v) if (CS%biharmonic)
+ !$omp target exit data map(delete: dDel2vdx, dDel2udy) if (CS%biharmonic)
+ !$omp target exit data map(delete: Shear_mag) if (use_Smag)
+ !$omp target exit data map(delete: Kh) if (CS%Laplacian)
+ !$omp target exit data map(delete: Ah) if (CS%biharmonic)
+ !$omp target exit data map(delete: bhstr_xx, bhstr_xy) if (CS%biharmonic)
+
+ !$omp target exit data map(delete: hrat_min) &
+ !$omp if (CS%bound_Kh .or. CS%bound_Ah)
+ !$omp target exit data map(delete: visc_bound_rem) &
+ !$omp if (CS%bound_Kh .or. CS%bound_Ah)
+
! Offer fields for diagnostic averaging.
if (CS%id_normstress > 0) call post_data(CS%id_normstress, NoSt, CS%diag)
if (CS%id_shearstress > 0) call post_data(CS%id_shearstress, ShSt, CS%diag)
@@ -2266,6 +2396,9 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G,
endif
endif
+ !$omp target exit data map(delete: sh_xy_q) &
+ !$omp if (CS%id_sh_xy_q > 0)
+
if (CS%id_FrictWorkIntz > 0) then
do j=js,je
do i=is,ie ; FrictWorkIntz(i,j) = FrictWork(i,j,1) ; enddo
@@ -2370,6 +2503,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
@@ -2398,6 +2533,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
! Read parameters and write them to the model log.
call log_version(param_file, mdl, version, "")
+ call get_param(param_file, mdl, "USE_CIRCULATION_IN_HORVISC", CS%use_circulation, &
+ "Use circulation theorem to compute vorticity in horvisc module (for ZB20 or Leith)", &
+ default=.False.)
+
! All parameters are read in all cases to enable parameter spelling checks.
call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
"This sets the default value for the various _ANSWER_DATE parameters.", &
@@ -2483,16 +2622,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
call get_param(param_file, mdl, "BOUND_KH", CS%bound_Kh, &
"If true, the Laplacian coefficient is locally limited "//&
"to be stable.", default=.true., do_not_log=.not.CS%Laplacian)
- call get_param(param_file, mdl, "BETTER_BOUND_KH", CS%better_bound_Kh, &
- "If true, the Laplacian coefficient is locally limited "//&
- "to be stable with a better bounding than just BOUND_KH.", &
- default=CS%bound_Kh, do_not_log=.not.CS%Laplacian)
call get_param(param_file, mdl, "EY24_EBT_BS", CS%EY24_EBT_BS, &
- "If true, use the the backscatter scheme (EBT mode with kill switch)"//&
+ "If true, use the backscatter scheme (EBT mode with kill switch) "//&
"developed by Yankovsky et al. (2024). ", &
default=.false., do_not_log=.not.CS%Laplacian)
if (.not.CS%Laplacian) CS%bound_Kh = .false.
- if (.not.CS%Laplacian) CS%better_bound_Kh = .false.
if (.not.(CS%Laplacian.and.use_MEKE)) CS%EY24_EBT_BS = .false.
call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, &
"If true, allow anistropic viscosity in the Laplacian "//&
@@ -2565,12 +2699,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, &
"If true, the biharmonic coefficient is locally limited "//&
"to be stable.", default=.true., do_not_log=.not.CS%biharmonic)
- call get_param(param_file, mdl, "BETTER_BOUND_AH", CS%better_bound_Ah, &
- "If true, the biharmonic coefficient is locally limited "//&
- "to be stable with a better bounding than just BOUND_AH.", &
- default=CS%bound_Ah, do_not_log=.not.CS%biharmonic)
if (.not.CS%biharmonic) CS%bound_Ah = .false.
- if (.not.CS%biharmonic) CS%better_bound_Ah = .false.
call get_param(param_file, mdl, "RE_AH", CS%Re_Ah, &
"If nonzero, the biharmonic coefficient is scaled "//&
"so that the biharmonic Reynolds number is equal to this.", &
@@ -2583,8 +2712,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
"biharmonic viscosity when no Laplacian viscosity is applied. The default "//&
"is true for historical reasons, but this option probably should not be used "//&
"because it can contribute to numerical instabilities.", &
- default=.true., do_not_log=.not.((CS%better_bound_Kh).and.(CS%better_bound_Ah)))
- !### The default for BACKSCATTER_UNDERBOUND should be false.
+ default=.false., do_not_log=.not.((CS%bound_Kh).and.(CS%bound_Ah)))
call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, &
"The nondimensional biharmonic Smagorinsky constant, "//&
@@ -2608,7 +2736,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
! "set or allocated. See github.com/mom-ocean/MOM6/issues/1590 for a discussion.")
! endif
if (CS%use_QG_Leith_visc .and. .not. (CS%Leith_Kh .or. CS%Leith_Ah) ) then
- call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//&
+ call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init: "//&
"LEITH_KH or LEITH_AH must be True when USE_QG_LEITH_VISC=True.")
endif
@@ -2643,7 +2771,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
"The nondimensional coefficient of the ratio of the "//&
"viscosity bounds to the theoretical maximum for "//&
"stability without considering other terms.", units="nondim", &
- default=0.8, do_not_log=.not.(CS%better_bound_Ah .or. CS%better_bound_Kh))
+ default=0.8, do_not_log=.not.(CS%bound_Ah .or. CS%bound_Kh))
call get_param(param_file, mdl, "KILL_SWITCH_COEF", CS%KS_coef, &
"A nondimensional coefficient on the biharmonic viscosity that "// &
"sets the kill switch for backscatter. Default is 1.0.", units="nondim", &
@@ -2664,11 +2792,15 @@ 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=.false.)
+ call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN_BUG", CS%OBC_strain_bug, &
+ "If true, recover a bug that specified shear strain option at open boundaries "//&
+ "cannot be applied.", default=.true.)
call get_param(param_file, mdl, "USE_GME", CS%use_GME, &
"If true, use the GM+E backscatter scheme in association \n"//&
"with the Gent and McWilliams parameterization.", default=.false.)
@@ -2728,6 +2860,9 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
"LAPLACIAN or BIHARMONIC viscosity.")
return ! We are not using either Laplacian or Bi-harmonic lateral viscosity
endif
+
+ !$omp target update to(CS)
+
deg2rad = atan(1.0) / 45.
ALLOC_(CS%dx2h(isd:ied,jsd:jed)) ; CS%dx2h(:,:) = 0.0
ALLOC_(CS%dy2h(isd:ied,jsd:jed)) ; CS%dy2h(:,:) = 0.0
@@ -2737,21 +2872,24 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
ALLOC_(CS%dy_dxT(isd:ied,jsd:jed)) ; CS%dy_dxT(:,:) = 0.0
ALLOC_(CS%dx_dyBu(IsdB:IedB,JsdB:JedB)) ; CS%dx_dyBu(:,:) = 0.0
ALLOC_(CS%dy_dxBu(IsdB:IedB,JsdB:JedB)) ; CS%dy_dxBu(:,:) = 0.0
+ !$omp target enter data map(alloc: CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q)
+ !$omp target enter data map(alloc: CS%dx_dyT, CS%dy_dxT, CS%dx_dyBu, CS%dy_dxBu)
+
if (CS%Laplacian) then
ALLOC_(CS%grid_sp_h2(isd:ied,jsd:jed)) ; CS%grid_sp_h2(:,:) = 0.0
ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0
ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0
- if (CS%bound_Kh .or. CS%better_bound_Kh .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
+ if (CS%bound_Kh .or. CS%EY24_EBT_BS) then
+ allocate(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed), source=0.0)
+ allocate(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB), source=0.0)
endif
if (CS%Smagorinsky_Kh .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 +2897,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 +2924,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)
@@ -2799,60 +2937,66 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0
ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0
ALLOC_(CS%grid_sp_h3(isd:ied,jsd:jed)) ; CS%grid_sp_h3(:,:) = 0.0
- if (CS%bound_Ah .or. CS%better_bound_Ah) then
- ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0
- ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0
+ if (CS%bound_Ah) then
+ allocate(CS%Ah_Max_xx(isd:ied,jsd:jed), source=0.0)
+ allocate(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB), source=0.0)
endif
if (CS%EY24_EBT_BS) then
- 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
+
+ do concurrent (J=js-2:Jeq+1, I=is-2:Ieq+1)
CS%dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; CS%dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J)
- enddo ; enddo
+ enddo
if (((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) .and. &
((G%isc-G%isd < 3) .or. (G%isc-G%isd < 3))) call MOM_error(FATAL, &
"The minimum halo size is 3 when a Leith viscosity is being used.")
if (CS%use_Leithy) then
- do J=js-3,Jeq+2 ; do I=is-3,Ieq+2
+ do concurrent (J=js-3:Jeq+2, I=is-3:Ieq+2)
CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J)
- enddo ; enddo
+ enddo
elseif ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then
- do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2
+ do concurrent (J=Jsq-2:Jeq+2, I=Isq-2:Ieq+2)
CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J)
- enddo ; enddo
+ enddo
else
- do J=js-2,Jeq+1 ; do I=is-2,Ieq+1
+ do concurrent (J=js-2:Jeq+1, I=is-2:Ieq+1)
CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J)
- enddo ; enddo
+ enddo
endif
- do j=js-2,Jeq+2 ; do i=is-2,Ieq+2
+ do concurrent (j=js-2:Jeq+2, i=is-2:Ieq+2)
CS%dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; CS%dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j)
CS%DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; CS%DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j)
- enddo ; enddo
+ enddo
+
+ ! TODO: Remove this after every instance has been moved to GPU
+ !$omp target update from(CS%dx2q, CS%dy2q, CS%dx_dyBu, CS%dy_dxBu)
+ !$omp target update from(CS%dx2h, CS%dy2h, CS%dx_dyT, CS%dy_dxT)
+
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
CS%reduction_xx(i,j) = 1.0
if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. &
@@ -2868,6 +3012,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
(G%dx_Cv(i,J-1) < G%dxCv(i,J-1) * CS%reduction_xx(i,j))) &
CS%reduction_xx(i,j) = G%dx_Cv(i,J-1) / (G%dxCv(i,J-1))
enddo ; enddo
+
do J=js-1,Jeq ; do I=is-1,Ieq
CS%reduction_xy(I,J) = 1.0
if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. &
@@ -2906,11 +3051,6 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
slat_fn = abs( sin( deg2rad * G%geoLatT(i,j) ) ) ** Kh_pwr_of_sine
CS%Kh_bg_xx(i,j) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xx(i,j))
endif
- if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then
- ! Limit the background viscosity to be numerically stable
- CS%Kh_Max_xx(i,j) = Kh_Limit * grid_sp_h2
- CS%Kh_bg_xx(i,j) = MIN(CS%Kh_bg_xx(i,j), CS%Kh_Max_xx(i,j))
- endif
min_grid_sp_h2 = min(grid_sp_h2, min_grid_sp_h2)
enddo ; enddo
call min_across_PEs(min_grid_sp_h2)
@@ -2941,11 +3081,6 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
slat_fn = abs( sin( deg2rad * G%geoLatBu(I,J) ) ) ** Kh_pwr_of_sine
CS%Kh_bg_xy(I,J) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xy(I,J))
endif
- if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then
- ! Limit the background viscosity to be numerically stable
- CS%Kh_Max_xy(I,J) = Kh_Limit * grid_sp_q2
- CS%Kh_bg_xy(I,J) = MIN(CS%Kh_bg_xy(I,J), CS%Kh_Max_xy(I,J))
- endif
enddo ; enddo
endif
if (CS%biharmonic) then
@@ -2960,7 +3095,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
CS%Ah_bg_xy(:,:) = 0.0
! The 0.3 below was 0.4 in HIM 1.10. The change in hq requires
! this to be less than 1/3, rather than 1/2 as before.
- if (CS%better_bound_Ah .or. CS%bound_Ah) Ah_Limit = 0.3 / (dt*64.0)
+ if (CS%bound_Ah) Ah_Limit = 0.3 / (dt*64.0)
if (CS%Smagorinsky_Ah .and. CS%bound_Coriolis) &
BoundCorConst = 1.0 / (5.0*(bound_Cor_vel*bound_Cor_vel))
@@ -2990,10 +3125,6 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xx(i,j) = grid_sp_h3 / CS%Re_Ah
if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = &
MAX(CS%Ah_bg_xx(i,j), (grid_sp_h2 * grid_sp_h2) / Ah_time_scale)
- if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then
- CS%Ah_Max_xx(i,j) = Ah_Limit * (grid_sp_h2 * grid_sp_h2)
- CS%Ah_bg_xx(i,j) = MIN(CS%Ah_bg_xx(i,j), CS%Ah_Max_xx(i,j))
- endif
min_grid_sp_h4 = min(grid_sp_h2**2, min_grid_sp_h4)
enddo ; enddo
call min_across_PEs(min_grid_sp_h4)
@@ -3015,14 +3146,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah
if (Ah_time_scale > 0.) CS%Ah_bg_xy(i,j) = &
MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale)
- if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then
- CS%Ah_Max_xy(I,J) = Ah_Limit * (grid_sp_q2 * grid_sp_q2)
- CS%Ah_bg_xy(I,J) = MIN(CS%Ah_bg_xy(I,J), CS%Ah_Max_xy(I,J))
- endif
enddo ; enddo
endif
! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1.
- if (CS%Laplacian .and. CS%better_bound_Kh) then
+ if (CS%Laplacian .and. CS%bound_Kh) then
do j=js-1,Jeq+1 ; do i=is-1,Ieq+1
denom = max( &
(CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) * &
@@ -3050,7 +3177,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
endif
! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but
! empirically work for CS%bound_coef <~ 1.0
- if (CS%biharmonic .and. CS%better_bound_Ah) then
+ if (CS%biharmonic .and. CS%bound_Ah) then
do j=js-1,Jeq+1 ; do I=is-2,Ieq+1
u0u(I,j) = ((CS%Idxdy2u(I,j)*((CS%dy2h(i+1,j)*CS%DY_dxT(i+1,j)*(G%IdyCu(I+1,j) + G%IdyCu(I,j))) + &
(CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j))) )) + &
@@ -3296,6 +3423,30 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
'Depth integrated work done by the biharmonic lateral friction', &
'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2)
+
+ ! TODO: Position these after their respective loops (and run loops on device)
+ !$omp target enter data map(to: CS%Idxdy2u, CS%Idxdy2v) if (CS%biharmonic)
+ !$omp target enter data map(to: CS%Idx2dyCu, CS%Idx2dyCv) if (CS%biharmonic)
+
+ !$omp target enter data map(to: CS%Kh_bg_xx, CS%Kh_bg_xy) if (CS%Laplacian)
+ !$omp target enter data map(to: CS%Kh_max_xx) if (CS%Laplacian)
+ !$omp target enter data map(to: CS%Kh_max_xy) &
+ !$omp if (CS%Laplacian .and. CS%bound_Kh)
+ !$omp target enter data map(to: CS%Laplac2_const_xx) if (CS%Laplacian)
+ !$omp target enter data map(to: CS%Laplac3_const_xx) if (CS%Laplacian)
+ !$omp target enter data map(to: CS%Laplac2_const_xy) if (CS%Smagorinsky_Kh)
+
+ !$omp target enter data map(to: CS%Ah_bg_xx, CS%Ah_bg_xy) if (CS%biharmonic)
+ !$omp target enter data map(to: CS%reduction_xx, CS%reduction_xy)
+ !$omp target enter data map(to: CS%Biharm_const_xx, CS%Biharm_const2_xx) &
+ !$omp if (CS%Smagorinsky_Ah .or. CS%Leith_Ah .or. CS%use_Leithy)
+ !$omp target enter data map(to: CS%Biharm_const_xy) &
+ !$omp if (CS%Smagorinsky_Ah .or. CS%Leith_Ah)
+ !$omp target enter data map(to: CS%Biharm_const2_xy) &
+ !$omp if (CS%bound_Coriolis .and. (CS%Smagorinsky_Ah .or. CS%Leith_Ah))
+ !$omp target enter data map(to: CS%Ah_max_xx) if (CS%bound_Ah)
+ !$omp target enter data map(to: CS%Ah_max_xy) if (CS%bound_Ah)
+
end subroutine hor_visc_init
!> hor_visc_vel_stencil returns the horizontal viscosity input velocity stencil size
@@ -3511,6 +3662,34 @@ end subroutine smooth_x9_uv
!> Deallocates any variables allocated in hor_visc_init.
subroutine hor_visc_end(CS)
type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure
+
+ !$omp target exit data map(delete: CS%DX_dyT, CS%DY_dxT)
+ !$omp target exit data map(delete: CS%Dx_dyBu, CS%DY_dxBu)
+
+ !$omp target exit data map(delete: CS%Idxdy2u, CS%Idxdy2v) if (CS%biharmonic)
+ !$omp target exit data map(delete: CS%Idx2dyCu, CS%Idx2dyCv) if (CS%biharmonic)
+ !$omp target exit data map(delete: CS%dx2q, CS%dy2q)
+ !$omp target exit data map(delete: CS%dx2h, CS%dy2h)
+
+ !$omp target exit data map(delete: CS%Kh_bg_xx, CS%Kh_bg_xy) if (CS%Laplacian)
+ !$omp target exit data map(delete: CS%Kh_Max_xx) if (CS%Laplacian)
+ !$omp target exit data map(delete: CS%Kh_max_xy) &
+ !$omp if (CS%Laplacian .and. CS%bound_Kh)
+ !$omp target exit data map(delete: CS%Laplac2_const_xx) if (CS%Laplacian)
+ !$omp target exit data map(delete: CS%Laplac3_const_xx) if (CS%Laplacian)
+ !$omp target exit data map(delete: CS%Laplac2_const_xy) if (CS%Smagorinsky_Kh)
+
+ !$omp target exit data map(delete: CS%Ah_bg_xx, CS%Ah_bg_xy) if (CS%biharmonic)
+ !$omp target exit data map(delete: CS%reduction_xx, CS%reduction_xy)
+ !$omp target exit data map(delete: CS%Biharm_const_xx, CS%Biharm_const2_xx) &
+ !$omp if (CS%Smagorinsky_Ah .or. CS%Leith_Ah .or. CS%use_Leithy)
+ !$omp target exit data map(delete: CS%Biharm_const_xy) &
+ !$omp if (CS%Smagorinsky_Ah .or. CS%Leith_Ah)
+ !$omp target exit data map(delete: CS%Biharm_const2_xy) &
+ !$omp if (CS%bound_Coriolis .and. (CS%Smagorinsky_Ah .or. CS%Leith_Ah))
+ !$omp target exit data map(delete: CS%Ah_max_xx) if (CS%bound_Ah)
+ !$omp target exit data map(delete: CS%Ah_max_xy) if (CS%bound_Ah)
+
if (CS%Laplacian .or. CS%biharmonic) then
DEALLOC_(CS%dx2h) ; DEALLOC_(CS%dx2q) ; DEALLOC_(CS%dy2h) ; DEALLOC_(CS%dy2q)
DEALLOC_(CS%dx_dyT) ; DEALLOC_(CS%dy_dxT) ; DEALLOC_(CS%dx_dyBu) ; DEALLOC_(CS%dy_dxBu)
@@ -3519,48 +3698,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_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90
index 12bda8c020..4cc67791d1 100644
--- a/src/parameterizations/lateral/MOM_interface_filter.F90
+++ b/src/parameterizations/lateral/MOM_interface_filter.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interface height filtering module
module MOM_interface_filter
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum, uvchksum
use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl
use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type
@@ -109,7 +111,10 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS)
"order specified by INTERFACE_FILTER_ORDER.")
! Calculates interface heights, e, in [Z ~> m].
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: e)
call find_eta(h, tv, G, GV, US, e, halo_size=filter_itts)
+ !$omp target exit data map(from: e)
! Set the smoothing length scales to apply at each iteration.
if (filter_itts == 1) then
@@ -296,7 +301,7 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_
do I=is-1,ie ; uhtot(I,j) = 0.0 ; enddo
do K=nz,2,-1
do I=is-1,ie
- Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j)
+ Slope = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu_OBCmask(I,j)
if (allocated(tv%SpV_avg)) then
! This is the fully non-Boussinesq version.
@@ -336,7 +341,7 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_
do i=is,ie ; vhtot(i,J) = 0.0 ; enddo
do K=nz,2,-1
do i=is,ie
- Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J)
+ Slope = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv_OBCmask(i,J)
if (allocated(tv%SpV_avg)) then
! This is the fully non-Boussinesq version.
@@ -383,9 +388,7 @@ subroutine interface_filter_init(Time, G, GV, US, param_file, diag, CDp, CS)
character(len=40) :: mdl = "MOM_interface_filter" ! This module's name.
! This include declares and sets the variable "version".
# include "version_variable.h"
- real :: grid_sp ! The local grid spacing [L ~> m]
real :: interface_filter_time ! The grid-scale interface height filtering timescale [T ~> s]
- integer :: i, j
CS%initialized = .true.
CS%diag => diag
diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90
index 794de22636..0803a70841 100644
--- a/src/parameterizations/lateral/MOM_internal_tides.F90
+++ b/src/parameterizations/lateral/MOM_internal_tides.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Subroutines that use the ray-tracing equations to propagate the internal tide energy density.
!!
!! \author Benjamin Mater & Robert Hallberg, 2015
module MOM_internal_tides
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_checksums, only : hchksum
use MOM_debugging, only : is_NaN
use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_axis_init
@@ -12,7 +14,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
@@ -24,12 +26,13 @@ module MOM_internal_tides
use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart
use MOM_restart, only : lock_check, restart_registry_lock
use MOM_spatial_means, only : global_area_integral
-use MOM_string_functions, only: extract_real
+use MOM_string_functions, only: extract_real, uppercase
use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-)
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : surface, thermo_var_ptrs, vertvisc_type
use MOM_verticalGrid, only : verticalGrid_type
use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init
+use mpp_domains_mod, only : NORTH_FACE => NORTH, EAST_FACE => EAST
implicit none ; private
@@ -47,6 +50,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 [T ~> s]
real :: uniform_test_cg !< Uniform group velocity of internal tide
!! for testing internal tides [L T-1 ~> m s-1]
logical :: corner_adv !< If true, use a corner advection rather than PPM.
@@ -60,6 +64,10 @@ module MOM_internal_tides
logical :: update_Kd !< If true, the scheme will modify the diffusivities seen by the dynamics
logical :: apply_refraction !< If false, skip refraction (for debugging)
logical :: apply_propagation !< If False, do not propagate energy (for debugging)
+ logical :: turn_critical_lat !< If True, rays change direction at critical latitude instead
+ !! of being trapped
+ logical :: reflect_critical_lat !< If True, rays reflect at the critical latitude instead
+ !! of turning parallel to it
logical :: debug !< If true, use debugging prints
logical :: init_forcing_only !< if True, add TKE forcing only at first step (for debugging)
logical :: force_posit_En !< if True, remove subroundoff negative values (needs enhancement)
@@ -95,7 +103,7 @@ module MOM_internal_tides
real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss
!< energy lost due to wave breaking [H Z2 T-3 ~> m3 s-3 or W m-2]
real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed
- !< Fixed part of the energy lost due to small-scale drag [H Z2 L-2 ~> kg m-2] here;
+ !< Fixed part of the energy lost due to small-scale drag [H Z2 L-2 ~> kg m-2] here.
!! This will be multiplied by N and the squared near-bottom velocity (and by
!! the near-bottom density in non-Boussinesq mode) to get the energy losses
!! in [R Z4 H-1 L-2 ~> kg m-2 or m]
@@ -124,7 +132,7 @@ module MOM_internal_tides
real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag,
!! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2]
real, allocatable, dimension(:,:) :: tot_itidal_loss !< Energy loss rates due to small-scale drag,
- !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2]
+ !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2]
real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking,
!! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2]
real, allocatable, dimension(:,:) :: tot_residual_loss !< Energy loss rates due to residual on slopes,
@@ -151,7 +159,9 @@ 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
+ integer :: itides_adv_limiter !< The type of limiter to use for the energy advection scheme
real, allocatable, dimension(:,:,:,:) :: decay_rate_2d !< rate at which internal tide energy is
!! lost to the interior ocean internal wave field
!! as a function of longitude, latitude, frequency
@@ -258,6 +268,13 @@ module MOM_internal_tides
!>@}
end type loop_bounds_type
+!>@{ Enumeration values for numerical schemes
+integer, parameter :: LIMITER_ADV_MINMOD = 1
+integer, parameter :: LIMITER_ADV_POSITIVE = 2
+character*(20), parameter :: LIMITER_ADV_MINMOD_STRING = "MINMOD"
+character*(20), parameter :: LIMITER_ADV_POSITIVE_STRING = "POSITIVE"
+!>@}
+
contains
!> Calls subroutines in this file that are needed to refract, propagate,
@@ -314,6 +331,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]
@@ -322,24 +340,22 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C
real :: U_mag ! rescaled magnitude of horizontal profile [L Z T-1 ~> m2 s-1]
real :: W0 ! rescaled magnitude of vertical profile [Z T-1 ~> m s-1]
real :: c_phase ! The phase speed [L T-1 ~> m s-1]
- real :: loss_rate ! An energy loss rate [T-1 ~> s-1]
+ ! real :: loss_rate ! An energy loss rate [T-1 ~> s-1]
real :: Fr2_max ! The column maximum internal wave Froude number squared [nondim]
real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1]
real :: en_subRO ! A tiny energy to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2]
real :: En_a, En_b ! Energies for time stepping [H Z2 T-2 ~> m3 s-2 or J m-2]
- real :: En_new, En_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2]
real :: En_sumtmp ! Energies for debugging [H Z2 L2 T-2 ~> m5 s-2 or J]
- real :: En_initial, Delta_E_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2]
- real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [H Z2 T-3 ~> m3 s-3 or W m-2]
real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal units
! to mks [T2 kg H-1 Z-2 s-2 ~> kg m-3 or 1]
real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal
! units [H Z2 s2 T-2 kg-1 ~> m3 kg-1 or 1]
character(len=160) :: mesg ! The text of an error message
integer :: 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 +372,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.
@@ -501,7 +524,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C
endif
! Pass a test vector to check for grid rotation in the halo updates.
- do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo
+ do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 0.0 ; test(i,j,2) = 1.0 ; enddo ; enddo
call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID)
call start_group_pass(pass_test, G%domain)
@@ -513,147 +536,162 @@ 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 do_group_pass(CS%pass_En, G%domain)
+ 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
+
+ if (CS%apply_propagation) then
+ call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt_sub, &
+ G, GV, US, CS, CS%NAngle, test(:,:,:), En_halo_ij_stencil, CS%TKE_slope_loss(:,:,:,fr,m))
+ endif
enddo ; enddo
- endif
- ! Propagate the waves.
- do m=1,CS%nMode ; do fr=1,CS%Nfreq
+ ! Rotate points in the halos as necessary.
+ call do_group_pass(CS%pass_En, G%domain)
+ call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil)
- ! initialize residual loss, will be computed in propagate
- CS%TKE_residual_loss(:,:,:,fr,m) = 0.
- CS%TKE_slope_loss(:,:,:,fr,m) = 0.
- 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%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%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%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
- enddo ; enddo ; enddo
- endif
-
- if (CS%debug) then
- call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2)
- do m=1,CS%nMode ; do fr=1,CS%Nfreq
- call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after propagate')
- if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after propagate', CS%En_sum
- enddo ; enddo
- ! Check for En<0 - for debugging, delete later
- do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle
- do j=js,je ; do i=is,ie
- if (CS%En(i,j,a,fr,m)<0.0) then
- id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset
- if (abs(CS%En(i,j,a,fr,m))>CS%En_check_tol) then ! only print if large
- write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, &
- 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m)
- call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg))
- ! RD propagate produces very little negative energy (diff 2 large numbers), needs fix
- !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.")
+ ! 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
- endif
+ enddo ; enddo
+ enddo ; enddo ; enddo
+ endif
+
+ if (CS%apply_refraction) then
+ ! Apply the other half of the refraction.
+ do m=1,CS%nMode ; do fr=1,CS%Nfreq
+ call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt_sub, &
+ G, US, CS%NAngle, CS%use_PPMang)
enddo ; enddo
- enddo ; enddo ; enddo
- endif
+ ! A this point, CS%En is only valid on the computational domain.
+ 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
+ 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%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%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
- 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 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
- if (CS%debug) then
- call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2)
- do m=1,CS%nMode ; do fr=1,CS%Nfreq
- call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 2/2 refraction')
- if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 2/2 refraction', CS%En_sum
- enddo ; enddo
- ! Check for En<0 - for debugging, delete later
- do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle
- do j=js,je ; do i=is,ie
- if (CS%En(i,j,a,fr,m)<0.0) then
- id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging
- write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, &
- 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m)
- call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg))
- !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.")
- endif
- enddo ; enddo
- enddo ; enddo ; enddo
- endif
+ call do_group_pass(CS%pass_En, G%domain)
+ call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil)
+
+ enddo ! end subcycling
! Apply various dissipation mechanisms.
if (CS%apply_background_drag .or. CS%apply_bottom_drag &
@@ -1324,7 +1362,7 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe
if (En_tot > 0.0) then
do a=1,CS%nAngle
frac_per_sector = En(i,j,a,fr,m)/En_tot
- TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [H Z2 T-3 ~> m3 s-3 or W m-2]
+ TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [H Z2 T-3 ~> m3 s-3 or W m-2]
loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1]
En_b = En(i,j,a,fr,m)
En_a = En(i,j,a,fr,m) / (1.0 + (dt*loss_rate))
@@ -1387,7 +1425,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2
!! dissipated within a layer and the
!! diapycnal diffusivity within that layer,
!! usually (~Rho_0 / (G_Earth * dRho_lay))
- !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1]
+ !! [T2 Z-1 ~> s2 m-1]
real, intent(in) :: Kd_max !< The maximum increment for diapycnal
!! diffusivity due to TKE-based processes
!! [H Z T-1 ~> m2 s-1 or kg m-1 s-1].
@@ -1421,7 +1459,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2
!! [H-1 ~> m-1 or m2 kg-1]
! local variables
- real :: TKE_loss ! temp variable to pass value of internal tides TKE loss [R Z-3 T-3 ~> W m-2]
+ real :: TKE_loss ! temp variable to pass value of internal tides TKE loss [H Z2 T-3 ~> m3 s-3 or W m-2]
real :: renorm_N ! renormalization for N profile [H T-1 ~> m s-1 or kg m-2 s-1]
real :: renorm_N2 ! renormalization for N2 profile [H T-2 ~> m s-2 or kg m-2 s-2]
real :: tmp_StLau ! tmp var for renormalization for StLaurent profile [nondim]
@@ -1453,6 +1491,8 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2
real :: hmin ! A minimum allowable thickness [H ~> m or kg m-2]
real :: h_rmn ! Remaining thickness in k-loop [H ~> m or kg m-2]
real :: frac ! A fraction of thicknesses [nondim]
+ real :: I_h_bot ! inverse of Bottom boundary layer thickness [H-1 ~> m-1 or m2 kg-1]
+
real :: verif_N, & ! profile verification [nondim]
verif_N2, & ! profile verification [nondim]
verif_bbl, & ! profile verification [nondim]
@@ -1500,7 +1540,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2
do i=is,ie
- ! create vertical profiles for diffusivites in layers
+ ! create vertical profiles for diffusivities in layers
renorm_N = 0.0
renorm_N2 = 0.0
renorm_StLau = 0.0
@@ -1509,6 +1549,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2
tmp_StLau_slope = 0.0
htot = 0.0
htmp = 0.0
+ I_h_bot = 1.0 / h_bot(i)
do k=1,nz
! N-profile
@@ -1532,12 +1573,12 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2
if (G%mask2dT(i,j) > 0.0) then
profile_BBL(k) = 0.0
if (h(i,j,k) <= h_rmn) then
- profile_BBL(k) = 1.0 / h_bot(i)
+ profile_BBL(k) = 1.0 * I_h_bot
h_rmn = h_rmn - h(i,j,k)
else
if (h_rmn > 0.0) then
frac = h_rmn / h(i,j,k)
- profile_BBL(k) = frac / h_bot(i)
+ profile_BBL(k) = frac * I_h_bot
h_rmn = h_rmn - frac*h(i,j,k)
endif
endif
@@ -1613,23 +1654,23 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2
enddo
if (abs(verif_N -1.0) > threshold_verif) then
- write(stdout,'(I5,I5,F18.10)') i, j, verif_N
+ write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_N
call MOM_error(FATAL, "mismatch integral for N profile")
endif
if (abs(verif_N2 -1.0) > threshold_verif) then
- write(stdout,'(I5,I5,F18.10)') i, j, verif_N2
+ write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_N2
call MOM_error(FATAL, "mismatch integral for N2 profile")
endif
if (abs(verif_bbl -1.0) > threshold_verif) then
- write(stdout,'(I5,I5,F18.10)') i, j, verif_bbl
+ write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_bbl
call MOM_error(FATAL, "mismatch integral for bbl profile")
endif
if (abs(verif_stl1 -1.0) > threshold_verif) then
- write(stdout,'(I5,I5,F18.10)') i, j, verif_stl1
+ write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_stl1
call MOM_error(FATAL, "mismatch integral for stl1 profile")
endif
if (abs(verif_stl2 -1.0) > threshold_verif) then
- write(stdout,'(I5,I5,F18.10)') i, j, verif_stl2
+ write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_stl2
call MOM_error(FATAL, "mismatch integral for stl2 profile")
endif
@@ -1639,7 +1680,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2
! note on units: TKE_to_Kd = 1 / ((g/rho0) * drho) Z-1 T2
! mult by dz gives -1/N2 in T2
- ! get TKE loss value and compute diffusivites in layers
+ ! get TKE loss value and compute diffusivities in layers
if (CS%apply_background_drag) then
call get_lowmode_loss(i, j, G, CS, "LeakDrag", TKE_loss)
! insert logic to switch between profiles here
@@ -1757,7 +1798,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 Propagates internal waves at a single frequency.
-subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss)
+subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, test, halo_size, residual_loss)
type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
integer, intent(in) :: NAngle !< The number of wave orientations in the
@@ -2056,13 +2097,13 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss)
real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1].
real, intent(in) :: dt !< Time step [T ~> s].
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ real, dimension(G%isd:G%ied,G%jsd:G%jed,2), intent(in) :: test !< test rotation vector
type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure
+ integer, intent(in) :: halo_size !< halo size for correct rotation
real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), &
intent(inout) :: residual_loss !< internal tide energy loss due
!! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2].
! Local variables
- real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: &
- speed ! The magnitude of the group velocity at the q points for corner adv [L T-1 ~> m s-1].
integer, parameter :: stencil = 2
real, dimension(SZIB_(G),SZJ_(G)) :: &
speed_x ! The magnitude of the group velocity at the Cu points [L T-1 ~> m s-1].
@@ -2149,15 +2190,17 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss)
sqrt(max(freq2 - f2, 0.0)) * Ifreq
enddo ; enddo
- call pass_vector(speed_x, speed_y, G%Domain, stagger=CGRID_NE)
+ call pass_var(speed_x, G%Domain, position=EAST_FACE)
+ call pass_var(speed_y, G%Domain, position=NORTH_FACE)
+
call pass_var(En, G%domain)
! Apply propagation in the first direction (reflection included)
LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh
if (x_first) then
- call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss)
+ call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2)
else
- call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss)
+ call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2)
endif
! fix underflows
@@ -2174,7 +2217,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss)
! Update halos
call pass_var(En, G%domain)
- call pass_var(residual_loss, G%domain)
+ call correct_halo_rotation_2d(En, test, G, NAngle, halo=halo_size)
if (CS%debug) then
do m=1,CS%nMode ; do fr=1,CS%Nfreq
@@ -2186,9 +2229,9 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss)
! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport
LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh
if (x_first) then
- call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss)
+ call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2)
else
- call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss)
+ call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2)
endif
! fix underflows
@@ -2197,7 +2240,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss)
enddo ; enddo ; enddo
call pass_var(En, G%domain)
- call pass_var(residual_loss, G%domain)
+ call correct_halo_rotation_2d(En, test, G, NAngle, halo=halo_size)
if (CS%debug) then
do m=1,CS%nMode ; do fr=1,CS%Nfreq
@@ -2210,7 +2253,7 @@ end subroutine propagate
!> Propagates the internal wave energy in the logical x-direction.
-subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, residual_loss)
+subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, residual_loss, freq2)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
integer, intent(in) :: NAngle !< The number of wave orientations in the
!! discretized wave energy spectrum.
@@ -2230,6 +2273,8 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res
real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), &
intent(inout) :: residual_loss !< internal tide energy loss due
!! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2].
+ real, intent(in) :: freq2 !< The square of internal tides frequency [T-2 ~> s-2].
+
! Local variables
real, dimension(SZI_(G),SZJ_(G)) :: &
EnL, EnR ! Left and right face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2].
@@ -2250,7 +2295,8 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res
EnL(i,j) = En(i,j,a) ; EnR(i,j) = En(i,j,a)
enddo ; enddo
else
- call PPM_reconstruction_x(En(:,:,a), EnL, EnR, G, LB, simple_2nd=CS%simple_2nd)
+ call PPM_reconstruction_x(En(:,:,a), EnL, EnR, G, LB, &
+ simple_2nd=CS%simple_2nd, adv_limiter=CS%itides_adv_limiter)
endif
do j=jsh,jeh
@@ -2260,7 +2306,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res
enddo
call zonal_flux_En(cg_p, En(:,j,a), EnL(:,j), EnR(:,j), flux1, &
dt, G, US, j, ish, ieh, CS%vol_CFL)
- do I=ish-1,ieh ; flux_x(I,j) = flux1(I); enddo
+ do I=ish-1,ieh ; flux_x(I,j) = flux1(I) ; enddo
enddo
do j=jsh,jeh ; do i=ish,ieh
@@ -2289,10 +2335,15 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res
En(i,j,a) = En(i,j,a) + (G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)))
enddo ; enddo ; enddo
+ ! existing energy at turning latitude should reflect away
+ if (CS%turn_critical_lat ) then
+ call turning_latitude(En, NAngle, freq2, CS, G, LB)
+ endif
+
end subroutine propagate_x
!> Propagates the internal wave energy in the logical y-direction.
-subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, residual_loss)
+subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, residual_loss, freq2)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
integer, intent(in) :: NAngle !< The number of wave orientations in the
!! discretized wave energy spectrum.
@@ -2312,6 +2363,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res
real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), &
intent(inout) :: residual_loss !< internal tide energy loss due
!! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2].
+ real, intent(in) :: freq2 !< The square of internal tides frequency [T-2 ~> s-2].
+
! Local variables
real, dimension(SZI_(G),SZJ_(G)) :: &
EnL, EnR ! South and north face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2].
@@ -2332,7 +2385,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res
EnL(i,j) = En(i,j,a) ; EnR(i,j) = En(i,j,a)
enddo ; enddo
else
- call PPM_reconstruction_y(En(:,:,a), EnL, EnR, G, LB, simple_2nd=CS%simple_2nd)
+ call PPM_reconstruction_y(En(:,:,a), EnL, EnR, G, LB, &
+ simple_2nd=CS%simple_2nd, adv_limiter=CS%itides_adv_limiter)
endif
do J=jsh-1,jeh
@@ -2342,7 +2396,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res
enddo
call merid_flux_En(cg_p, En(:,:,a), EnL(:,:), EnR(:,:), flux1, &
dt, G, US, J, ish, ieh, CS%vol_CFL)
- do i=ish,ieh ; flux_y(i,J) = flux1(i); enddo
+ do i=ish,ieh ; flux_y(i,J) = flux1(i) ; enddo
enddo
do j=jsh,jeh ; do i=ish,ieh
@@ -2371,6 +2425,11 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res
En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))
enddo ; enddo ; enddo
+ ! existing energy at turning latitude should reflect away
+ if (CS%turn_critical_lat ) then
+ call turning_latitude(En, NAngle, freq2, CS, G, LB)
+ endif
+
end subroutine propagate_y
!> Evaluates the zonal mass or volume fluxes in a layer.
@@ -2484,6 +2543,7 @@ subroutine reflect(En, NAngle, CS, G, LB)
real :: TwoPi ! 2*pi = 6.2831853... [nondim]
real :: Angle_size ! size of beam wedge [rad]
+ real :: I_Angle_size ! inverse of size of beam wedge [rad-1]
integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator
integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator
integer :: angle_r ! angle-bin of reflected ray wrt equator
@@ -2502,6 +2562,7 @@ subroutine reflect(En, NAngle, CS, G, LB)
TwoPi = 8.0*atan(1.0)
Angle_size = TwoPi / (real(NAngle))
+ I_Angle_size = 1.0 / Angle_size
Nangle_d2 = (Nangle / 2)
! init local arrays
@@ -2523,7 +2584,7 @@ subroutine reflect(En, NAngle, CS, G, LB)
! i.e., if energy is in a reflecting cell
if (angle_c(i,j) /= CS%nullangle) then
! refection angle is given in rad, convert to the discrete angle
- angle_wall = nint(angle_c(i,j)/Angle_size) + 1
+ angle_wall = nint(angle_c(i,j)*I_Angle_size) + 1
do a=1,NAngle ; if (En(i,j,a) > 0.0) then
! reindex to 0 -> Nangle-1 for trig
a0 = a - 1
@@ -2566,6 +2627,145 @@ subroutine reflect(En, NAngle, CS, G, LB)
end subroutine reflect
+subroutine turning_latitude(En, NAngle, freq2, CS, G, LB)
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
+ integer, intent(in) :: NAngle !< The number of wave orientations in the
+ !! discretized wave energy spectrum.
+ real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), &
+ intent(inout) :: En !< The internal gravity wave energy density as a
+ !! function of space and angular resolution
+ !! [H Z2 T-2 ~> m3 s-2 or J m-2].
+ type(int_tide_CS), intent(in) :: CS !< Internal tide control structure
+ type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds.
+ real, intent(in) :: freq2 !< The square of the internal tide frequency [T-2 ~> s-2]
+
+ ! Local variables
+ real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c
+ ! angle of boundary wrt equator [rad]
+ real, dimension(1:Nangle) :: En_reflected ! Energy reflected [H Z2 T-2 ~> m3 s-2 or J m-2].
+
+ real :: TwoPi ! 2*pi = 6.2831853... [nondim]
+ real :: Angle_size ! size of beam wedge [rad]
+ real :: I_Angle_size ! inverse of size of beam wedge [rad-1]
+ real :: f2
+
+ integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator
+ integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator
+ integer :: angle_r ! angle-bin of reflected ray wrt equator
+ integer :: angle_r0 ! angle-bin of reflected ray wrt equator
+ integer :: angle_to_wall ! angle-bin relative to wall
+ integer :: a, a0 ! loop index for angles
+ integer :: i, j
+ integer :: Nangle_d2 ! Nangle / 2
+ integer :: Nangle_d4p1 ! Nangle / 4 + 1
+ integer :: Nangle_3d4p1 ! 3*Nangle / 4 + 1
+ integer :: isc, iec, jsc, jec ! start and end local indices on PE
+ ! (values exclude halos)
+ integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain
+ ! leaving out outdated halo points (march in)
+
+ isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec
+ ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh
+
+ TwoPi = 8.0*atan(1.0)
+ Angle_size = TwoPi / (real(NAngle))
+ I_Angle_size = 1.0 / Angle_size
+ Nangle_d2 = (Nangle / 2)
+ Nangle_d4p1 = (Nangle / 4) + 1
+ Nangle_3d4p1 = (3 * Nangle / 4) + 1
+
+
+ ! init local arrays
+ angle_c(:,:) = CS%nullangle
+ angle_wall = 0
+ angle_wall0 =0
+ angle_r = 0
+ angle_r0 = 0
+ angle_to_wall = 0
+
+ do j=jsh,jeh ; do i=ish,ieh
+ ! init
+ angle_wall = 0
+ angle_wall0 = 0
+ angle_r = 0
+ angle_r0 = 0
+ angle_to_wall = 0
+
+ f2 = max(abs(G%Coriolis2Bu(I-1,J)), abs(G%Coriolis2Bu(I,J)), &
+ abs(G%Coriolis2Bu(I-1,J-1)), abs(G%Coriolis2Bu(I,J-1)))
+
+ if (G%CoriolisBu(I,J) < 0. ) then
+ if (f2 - freq2 >= 0.) then
+ angle_c(i,j) = 0.5 * TwoPi
+ endif
+ else
+ if (f2 - freq2 >= 0.) then
+ angle_c(i,j) = 0.
+ endif
+ endif
+ enddo ; enddo
+
+ En_reflected(:) = 0.0
+
+ do j=jsh,jeh ; do i=ish,ieh
+ ! init
+ angle_wall = 0
+ angle_wall0 = 0
+ angle_r = 0
+ angle_r0 = 0
+ angle_to_wall = 0
+
+ if (angle_c(i,j) /= CS%nullangle) then
+ ! refection angle is given in rad, convert to the discrete angle
+ angle_wall = nint(angle_c(i,j)*I_Angle_size) + 1
+ do a=1,NAngle ; if (En(i,j,a) > 0.0) then
+
+ if (.not. CS%reflect_critical_lat) then
+
+ ! turn parallel to critical lat
+ if ((a > Nangle_d4p1) .and. (a < Nangle_3d4p1)) then
+ angle_r0 = Nangle_d2
+ else
+ angle_r0 = 0
+ endif
+ angle_r = angle_r0 + 1 !re-index to 1 -> Nangle
+
+ if (a /= angle_r) then
+ En_reflected(angle_r) = En(i,j,a)
+ En(i,j,a) = 0.
+ endif
+
+ else
+
+ ! reindex to 0 -> Nangle-1 for trig
+ a0 = a - 1
+ angle_wall0 = angle_wall - 1
+ ! compute relative angle from wall and use cyclic properties
+ ! to ensure it is bounded by 0 -> Nangle-1
+ angle_to_wall = mod((a0 - angle_wall0) + Nangle, Nangle)
+
+ ! do reflection
+ if ((0 < angle_to_wall) .and. (angle_to_wall < Nangle_d2)) then
+ angle_r0 = mod(2*angle_wall0 - a0 + Nangle, Nangle)
+ angle_r = angle_r0 + 1 !re-index to 1 -> Nangle
+
+ if (a /= angle_r) then
+ En_reflected(angle_r) = En(i,j,a)
+ En(i,j,a) = 0.
+ endif
+ endif
+ endif
+ endif ; enddo ! a-loop
+
+ do a=1,NAngle
+ En(i,j,a) = En(i,j,a) + En_reflected(a)
+ En_reflected(a) = 0.0 ! reset values
+ enddo ! a-loop
+ endif
+ enddo ; enddo ! i- and j-loops
+
+end subroutine turning_latitude
+
!> Moves energy across lines of partial reflection to prevent
!! reflection of energy that is supposed to get across.
subroutine teleport(En, NAngle, CS, G, LB)
@@ -2689,13 +2889,12 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo)
i_first = ieh+1 ; i_last = ish-1
do i=ish,ieh
a_shift(i) = 0
- if (test(i,j,1) /= 1.0) then
+ if (test(i,j,2) < 0.5) then
if (ii_last) i_last = i
-
- if (test(i,j,1) == -1.0) then ; a_shift(i) = nAngle/2
- elseif (test(i,j,2) == 1.0) then ; a_shift(i) = -nAngle/4
- elseif (test(i,j,2) == -1.0) then ; a_shift(i) = nAngle/4
+ if (test(i,j,2) < -0.5) then ; a_shift(i) = 0.5*nAngle
+ elseif (test(i,j,1) > 0.5) then ; a_shift(i) = -0.25*nAngle
+ elseif (test(i,j,1) < -0.5) then ; a_shift(i) = 0.25*nAngle
else
write(mesg,'("Unrecognized rotation test vector ",2ES9.2," at ",F7.2," E, ",&
&F7.2," N; i,j=",2i4)') &
@@ -2722,8 +2921,72 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo)
enddo
end subroutine correct_halo_rotation
+
+!> Rotates points in the halos where required to accommodate
+!! changes in grid orientation, such as at the tripolar fold.
+subroutine correct_halo_rotation_2d(En, test, G, NAngle, halo)
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
+ real, dimension(:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a
+ !! function of space, angular orientation, frequency,
+ !! and vertical mode [H Z2 T-2 ~> m3 s-2 or J m-2].
+ real, dimension(SZI_(G),SZJ_(G),2), &
+ intent(in) :: test !< An x-unit vector that has been passed through
+ !! the halo updates, to enable the rotation of the
+ !! wave energies in the halo region to be corrected [nondim].
+ integer, intent(in) :: NAngle !< The number of wave orientations in the
+ !! discretized wave energy spectrum.
+ integer, intent(in) :: halo !< The halo size over which to do the calculations
+ ! Local variables
+ real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density
+ ! in a frequency band and mode [H Z2 T-2 ~> m3 s-2 or J m-2].
+ integer, dimension(G%isd:G%ied) :: a_shift
+ integer :: i_first, i_last, a_new
+ integer :: a, i, j, ish, ieh, jsh, jeh
+ integer :: id_g, jd_g
+ character(len=160) :: mesg ! The text of an error message
+ ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo
+
+ ! top rows
+ do j=jsh,jeh
+ !do j= G%jec+1,jeh
+ i_first = ieh+1 ; i_last = ish-1 ! init
+ do i=ish,ieh
+ id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging
+
+ a_shift(i) = 0
+ if (test(i,j,2) < 0.5) then
+ if (ii_last) i_last = i
+ if (test(i,j,2) < -0.5) then ; a_shift(i) = 0.5*nAngle
+ elseif (test(i,j,1) > 0.5) then ; a_shift(i) = -0.25*nAngle
+ elseif (test(i,j,1) < -0.5) then ; a_shift(i) = 0.25*nAngle
+ else
+ write(mesg,'("Unrecognized rotation test vector ",2ES9.2," at ",F7.2," E, ",&
+ &F7.2," N; i,j=",2i4)') &
+ test(i,j,1), test(i,j,2), G%GeoLonT(i,j), G%GeoLatT(i,j), i, j
+ call MOM_error(FATAL, mesg)
+ endif
+ endif
+ enddo
+
+ if (i_first <= i_last) then
+ ! At least one point in this row needs to be rotated.
+ do a=1,nAngle ; do i=i_first,i_last ; if (a_shift(i) /= 0) then
+ a_new = a + a_shift(i)
+ if (a_new < 1) a_new = a_new + nAngle
+ if (a_new > nAngle) a_new = a_new - nAngle
+ En2d(i,a_new) = En(i,j,a)
+ endif ; enddo ; enddo
+ do a=1,nAngle ; do i=i_first,i_last ; if (a_shift(i) /= 0) then
+ En(i,j,a) = En2d(i,a)
+ endif ; enddo ; enddo
+ endif
+ enddo
+end subroutine correct_halo_rotation_2d
+
+
!> Calculates left/right edge values for PPM reconstruction in x-direction.
-subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd)
+subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd, adv_limiter)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D)
!! [H Z2 T-2 ~> m3 s-2 or J m-2]
@@ -2735,6 +2998,8 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd)
logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean
!! energy densities as default edge values
!! for a simple 2nd order scheme.
+ integer, intent(in) :: adv_limiter !< The type of limiter used
+
! Local variables
real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width
! [H Z2 T-2 ~> m3 s-2 or J m-2]
@@ -2752,13 +3017,13 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd)
if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then
write(mesg,'("In MOM_internal_tides, PPM_reconstruction_x called with a ", &
- & "x-halo that needs to be increased by ",i2,".")') &
+ & "x-halo that needs to be increased by ",I0,".")') &
stencil + max(G%isd-isl,iel-G%ied)
call MOM_error(FATAL,mesg)
endif
if ((jsl < G%jsd) .or. (jel > G%jed)) then
write(mesg,'("In MOM_internal_tides, PPM_reconstruction_x called with a ", &
- & "y-halo that needs to be increased by ",i2,".")') &
+ & "y-halo that needs to be increased by ",I0,".")') &
max(G%jsd-jsl,jel-G%jed)
call MOM_error(FATAL,mesg)
endif
@@ -2798,11 +3063,17 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd)
enddo ; enddo
endif
- call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel)
+ select case(adv_limiter)
+ case (LIMITER_ADV_POSITIVE)
+ call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel)
+ case (LIMITER_ADV_MINMOD)
+ call minmod_limiter(h_in, h_l, h_r, G, isl, iel, jsl, jel)
+ end select
+
end subroutine PPM_reconstruction_x
!> Calculates left/right edge valus for PPM reconstruction in y-direction.
-subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd)
+subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd, adv_limiter)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D)
!! [H Z2 T-2 ~> m3 s-2 or J m-2]
@@ -2814,6 +3085,8 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd)
logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean
!! energy densities as default edge values
!! for a simple 2nd order scheme.
+ integer, intent(in) :: adv_limiter !< The type of limiter used
+
! Local variables
real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width
! [H Z2 T-2 ~> m3 s-2 or J m-2]
@@ -2831,13 +3104,13 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd)
if ((isl < G%isd) .or. (iel > G%ied)) then
write(mesg,'("In MOM_internal_tides, PPM_reconstruction_y called with a ", &
- & "x-halo that needs to be increased by ",i2,".")') &
+ & "x-halo that needs to be increased by ",I0,".")') &
max(G%isd-isl,iel-G%ied)
call MOM_error(FATAL,mesg)
endif
if ((jsl-stencil < G%jsd) .or. (jel+stencil > G%jed)) then
write(mesg,'("In MOM_internal_tides, PPM_reconstruction_y called with a ", &
- & "y-halo that needs to be increased by ",i2,".")') &
+ & "y-halo that needs to be increased by ",I0,".")') &
stencil + max(G%jsd-jsl,jel-G%jed)
call MOM_error(FATAL,mesg)
endif
@@ -2875,7 +3148,13 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd)
enddo ; enddo
endif
- call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel)
+ select case(adv_limiter)
+ case (LIMITER_ADV_POSITIVE)
+ call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel)
+ case (LIMITER_ADV_MINMOD)
+ call minmod_limiter(h_in, h_l, h_r, G, isl, iel, jsl, jel)
+ end select
+
end subroutine PPM_reconstruction_y
!> Limits the left/right edge values of the PPM reconstruction
@@ -2924,6 +3203,42 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie)
enddo ; enddo
end subroutine PPM_limit_pos
+!> Limits the left/right edge values using the simple minmod limiter
+!! written in a way that avoids branching in favor of intrinsics
+subroutine minmod_limiter(h_in, h_L, h_R, G, iis, iie, jis, jie)
+ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
+ real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D)
+ !! [H Z2 T-2 ~> m3 s-2 or J m-2]
+ real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction
+ !! [H Z2 T-2 ~> m3 s-2 or J m-2]
+ real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction
+ !! [H Z2 T-2 ~> m3 s-2 or J m-2]
+ integer, intent(in) :: iis !< Start i-index for computations
+ integer, intent(in) :: iie !< End i-index for computations
+ integer, intent(in) :: jis !< Start j-index for computations
+ integer, intent(in) :: jie !< End j-index for computations
+ ! Local variables
+ real :: sign_h_L, sign_h_R, sign_h_in ! the signs of the edge and center values
+ real :: sign_h_L_in, sign_h_R_in ! products of signs, detect crossing the zero line
+ integer :: i, j
+
+ do j=jis,jie ; do i=iis,iie
+
+ sign_h_L = sign(1.0d0, h_L(i,j))
+ sign_h_R = sign(1.0d0, h_R(i,j))
+ sign_h_in = sign(1.0d0, h_in(i,j))
+
+ sign_h_L_in = sign_h_L * sign_h_in
+ sign_h_R_in = sign_h_R * sign_h_in
+
+ ! if opposite signs, goes to zero else take the min of edge and centers values
+ h_L(i,j) = (0.5 * (sign_h_L_in + 1.0)) * (sign_h_L * min(abs(h_L(i,j)), abs(h_in(i,j))))
+ h_R(i,j) = (0.5 * (sign_h_R_in + 1.0)) * (sign_h_R * min(abs(h_R(i,j)), abs(h_in(i,j))))
+
+ enddo ; enddo
+
+end subroutine minmod_limiter
+
subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_CS)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
type(verticalGrid_type),intent(in):: GV !< The ocean's vertical grid structure.
@@ -2937,10 +3252,9 @@ subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_CS)
logical :: non_Bous ! If true, this run is fully non-Boussinesq
logical :: Boussinesq ! If true, this run is fully Boussinesq
logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq
- logical :: use_int_tides
- integer :: num_freq, num_angle , num_mode, period_1
- integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, i, j, a, fr
- character(64) :: var_name, cfr, units
+ integer :: num_freq, num_angle, num_mode
+ integer :: isd, ied, jsd, jed, i, j, a, fr, m
+ character(64) :: units
type(axis_info) :: axes_inttides(2)
real, dimension(:), allocatable :: angles, freqs ! Lables for angles and frequencies [nondim]
@@ -2988,6 +3302,10 @@ subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_CS)
! full energy array
allocate(CS%En(isd:ied, jsd:jed, num_angle, num_freq, num_mode), source=0.0)
+ do m=1,num_mode ; do fr=1,num_freq
+ call create_group_pass(CS%pass_En, CS%En(:,:,:,fr,m), G%Domain)
+ enddo ; enddo
+
! restart strategy: support for 5d restart is not yet available so we split into
! 4d restarts. Vertical modes >= 6 are dissipated locally and do not propagate
! so we only allow for 5 vertical modes and each has its own variable
@@ -3088,7 +3406,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS)
real :: kappa_h2_factor ! A roughness scaling factor [nondim]
real :: RMS_roughness_frac ! The maximum RMS topographic roughness as a fraction of the
! nominal ocean depth, or a negative value for no limit [nondim]
- real :: period_1 ! The period of the gravest modeled mode [T ~> s]
real :: period ! A tidal period read from namelist [T ~> s]
real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal units
! to mks [T2 kg H-1 Z-2 s-2 ~> kg m-3 or 1]
@@ -3110,6 +3427,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS)
character(len=200) :: refl_pref_file, refl_dbl_file, trans_file
character(len=200) :: h2_file, decay_file
character(len=80) :: rough_var ! Input file variable names
+ character(len=80) :: tmpstr
character(len=240), dimension(:), allocatable :: energy_fractions
character(len=240) :: periods
@@ -3188,6 +3506,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS)
call get_param(param_file, mdl, "INTERNAL_TIDE_ANGLES", num_angle, &
"The number of angular resolution bands for the internal "//&
"tide calculations.", default=24)
+ call get_param(param_file, mdl, "DT_ITIDES", CS%dt_itides, &
+ "The timestep for internal tides ray-tracing scheme. "//&
+ "If set to -1 (default), it uses the same value as DT_THERM.", &
+ units="s", default=-1., scale=US%s_to_T)
if (use_int_tides) then
if ((num_freq <= 0) .and. (num_mode <= 0) .and. (num_angle <= 0)) then
@@ -3227,6 +3549,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS)
call get_param(param_file, mdl, "INTERNAL_TIDES_ONLY_INIT_FORCING", CS%init_forcing_only, &
"If true, internal tides ray tracing only applies forcing at first step (debugging).", &
default=.false.)
+ call get_param(param_file, mdl, "TURN_CRITICAL_LAT", CS%turn_critical_lat, &
+ "If true, internal tides rays turn at the critical latitude.", &
+ default=.true.)
+ call get_param(param_file, mdl, "REFLECT_CRITICAL_LAT", CS%reflect_critical_lat, &
+ "If true, internal tides rays reflect at the critical latitude. "//&
+ "If false, rays turn parallel to the critical latitude", &
+ default=.true.)
call get_param(param_file, mdl, "INTERNAL_TIDES_FORCE_POS_EN", CS%force_posit_En, &
"If true, force energy to be positive by removing subroundoff negative values.", &
default=.true.)
@@ -3266,6 +3595,24 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS)
"1st-order upwind advection. This scheme is highly "//&
"continuity solver. This scheme is highly "//&
"diffusive but may be useful for debugging.", default=.false.)
+ call get_param(param_file, mdl, "INTERNAL_TIDE_ADV_LIMITER", tmpstr, &
+ "Choose the limiter scheme used for the internal tide advection scheme, "//&
+ "available schemes are: \n"//&
+ "\t POSITIVE - a positive definite scheme similar to the continuity solver. \n"//&
+ "\t MINMOD - the simplest limiter.", default=LIMITER_ADV_MINMOD_STRING)
+
+ tmpstr = uppercase(tmpstr)
+ select case (tmpstr)
+ case (LIMITER_ADV_POSITIVE_STRING)
+ CS%itides_adv_limiter = LIMITER_ADV_POSITIVE
+ case (LIMITER_ADV_MINMOD_STRING)
+ CS%itides_adv_limiter = LIMITER_ADV_MINMOD
+ case default
+ call MOM_mesg('internal_tide_init: Advection limiter ="'//trim(tmpstr)//'"', 0)
+ call MOM_error(FATAL, "internal_tide_init: Unrecognized setting "// &
+ "#define INTERNAL_TIDE_ADV_LIMITER "//trim(tmpstr)//" found in input file.")
+ end select
+
call get_param(param_file, mdl, "INTERNAL_TIDE_BACKGROUND_DRAG", CS%apply_background_drag, &
"If true, the internal tide ray-tracing advection uses a background drag "//&
"term as a sink.", default=.false.)
@@ -3420,7 +3767,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS)
do j=G%jsc,G%jec ; do i=G%isc,G%iec
! Restrict RMS topographic roughness to a fraction (10 percent by default) of the column depth.
if (RMS_roughness_frac >= 0.0) then
- h2(i,j) = max(min((RMS_roughness_frac*(G%bathyT(i,j)+G%Z_ref))**2, h2(i,j)), 0.0)
+ h2(i,j) = max(min((RMS_roughness_frac * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0))**2, h2(i,j)), 0.0)
else
h2(i,j) = max(h2(i,j), 0.0)
endif
@@ -3715,9 +4062,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS)
do m=1,CS%nMode
- ! Register 3-D internal tide horizonal velocity profile for each mode
+ ! Register 3-D internal tide horizontal velocity profile for each mode
write(var_name, '("Itide_Ustruct","_mode",i1)') m
- write(var_descript, '("horizonal velocity profile for mode ",i1)') m
+ write(var_descript, '("horizontal velocity profile for mode ",i1)') m
CS%id_Ustruct_mode(m) = register_diag_field('ocean_model', var_name, &
diag%axesTl, Time, var_descript, 'm-1', conversion=US%m_to_L)
call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5)
diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
index f2f476b0c8..aadbf8e059 100644
--- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
+++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90
@@ -1,14 +1,17 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Variable mixing coefficients
module MOM_lateral_mixing_coeffs
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum, uvchksum
use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg
use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data
use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled
use MOM_domains, only : create_group_pass, do_group_pass
use MOM_domains, only : group_pass_type, pass_var, pass_vector
+use MOM_EOS, only : calculate_density_derivs, EOS_domain
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_interface_heights, only : find_eta, thickness_to_dz
use MOM_isopycnal_slopes, only : calc_isoneutral_slopes
@@ -17,10 +20,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
@@ -46,8 +49,8 @@ module MOM_lateral_mixing_coeffs
!! speed and calculate the resolution function
!! independently at each point.
logical :: use_stored_slopes !< If true, stores isopycnal slopes in this structure.
- logical :: Resoln_use_ebt !< If true, uses the equivalent barotropic wave speed instead
- !! of first baroclinic wave for calculating the resolution fn.
+ logical :: Resoln_use_ebt !< If true, use the equivalent barotropic wave speed instead of the
+ !! first baroclinic wave speed for calculating the resolution function.
logical :: khth_use_ebt_struct !< If true, uses the equivalent barotropic structure
!! as the vertical structure of thickness diffusivity.
logical :: kdgl90_use_ebt_struct !< If true, uses the equivalent barotropic structure
@@ -80,10 +83,15 @@ 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.
+ logical :: res_fn_OBC_bug !< If false, use only interior data for calculating the resolution
+ !! functions at open boundary condition faces and vertices.
real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or
!! incropped interfaces for the Eady growth rate calc [Z ~> m]
real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the
- !! 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 +138,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
@@ -204,6 +208,7 @@ subroutine calc_depth_function(G, CS)
integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq
integer :: i, j
real :: H0 ! The depth above which KHTH is linearly scaled away [Z ~> m]
+ real :: h1, h2 ! Temporary total thicknesses [Z ~> m]
real :: expo ! exponent used in the depth dependent scaling [nondim]
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
@@ -222,17 +227,21 @@ subroutine calc_depth_function(G, CS)
expo = CS%depth_scaled_khth_exp
!$OMP do
do j=js,je ; do I=is-1,Ieq
- CS%Depth_fn_u(I,j) = (MIN(1.0, (0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) + G%Z_ref)/H0))**expo
+ h1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)
+ h2 = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0)
+ CS%Depth_fn_u(I,j) = (MIN(1.0, (0.5 * (h1 + h2)) / H0))**expo
enddo ; enddo
!$OMP do
do J=js-1,Jeq ; do i=is,ie
- CS%Depth_fn_v(i,J) = (MIN(1.0, (0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) + G%Z_ref)/H0))**expo
+ h1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)
+ h2 = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0)
+ CS%Depth_fn_v(i,J) = (MIN(1.0, (0.5 * (h1 + h2)) / H0))**expo
enddo ; enddo
end subroutine calc_depth_function
!> Calculates and stores the non-dimensional resolution functions
-subroutine calc_resoln_function(h, tv, G, GV, US, CS, 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,15 +249,17 @@ 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
! Depending on the power-function being used, dimensional rescaling may be limited, so some
! of the following variables have units that depend on that power.
- real :: cg1_q ! The gravity wave speed interpolated to q points [L T-1 ~> m s-1] or [m s-1].
- real :: cg1_u ! The gravity wave speed interpolated to u points [L T-1 ~> m s-1] or [m s-1].
- real :: cg1_v ! The gravity wave speed interpolated to v points [L T-1 ~> m s-1] or [m s-1].
+ real :: cg1_q(SZIB_(G),SZJB_(G)) ! The gravity wave speed interpolated to q points [L T-1 ~> m s-1] or [m s-1].
+ real :: cg1_u(SZIB_(G),SZJ_(G)) ! The gravity wave speed interpolated to u points [L T-1 ~> m s-1] or [m s-1].
+ real :: cg1_v(SZI_(G),SZJB_(G)) ! The gravity wave speed interpolated to v points [L T-1 ~> m s-1] or [m s-1].
real :: dx_term ! A term in the denominator [L2 T-2 ~> m2 s-2] or [m2 s-2]
+ logical :: apply_u_OBC, apply_v_OBC ! If true, OBCs will be used to set the wave speed at some points on this PE.
integer :: power_2
integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
integer :: i, j, k
@@ -259,6 +270,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt)
"Module must be initialized before it is used.")
if (CS%calculate_cg1) then
+ !$omp target update from(h)
if (.not. allocated(CS%cg1)) call MOM_error(FATAL, &
"calc_resoln_function: %cg1 is not associated with Resoln_scaled_Kh.")
if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct &
@@ -282,9 +294,11 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt)
call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain)
call do_group_pass(CS%pass_cg1, G%Domain)
endif
+
if (CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct &
.or. CS%kdgl90_use_sqg_struct .or. CS%id_sqg_struct>0) then
- call calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE)
+ !$omp target update from(h)
+ call calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE, OBC)
call pass_var(CS%sqg_struct, G%Domain)
endif
@@ -370,13 +384,40 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt)
if (.not. allocated(CS%beta_dx2_v)) call MOM_error(FATAL, &
"calc_resoln_function: %beta_dx2_v is not associated with Resoln_scaled_Kh.")
+ apply_u_OBC = .false. ; apply_v_OBC = .false.
+ if (associated(OBC) .and. (.not.CS%res_fn_OBC_bug)) then
+ apply_u_OBC = OBC%u_OBCs_on_PE
+ apply_v_OBC = OBC%v_OBCs_on_PE
+ endif
+
+ !$OMP parallel default(shared) private(dx_term,power_2)
+
+ if (apply_u_OBC .or. apply_v_OBC) then
+ !$OMP do
+ do J=js-1,Jeq ; do I=is-1,Ieq
+ if ((OBC%segnum_u(I,j) /= 0) .or. (OBC%segnum_u(I,j+1) /= 0) .or. &
+ (OBC%segnum_v(i,J) /= 0) .or. (OBC%segnum_u(i+1,J) /= 0)) then
+ ! This is an OBC node, so use the fact that G%mask2dT is zero behind OBCs. The nondimensional
+ ! constant 1e-20 in the denominator makes this a de facto implementation of Adcroft's reciprocal
+ ! rule with a value that works for either 64-bit or 32-bit real numbers.
+ cg1_q(I,J) = ((G%mask2dT(i,j) * CS%cg1(i,j) + G%mask2dT(i+1,j+1) * CS%cg1(i+1,j+1)) + &
+ (G%mask2dT(i+1,j) * CS%cg1(i+1,j) + G%mask2dT(i,j+1) * CS%cg1(i,j+1))) / &
+ ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-20)
+ else
+ cg1_q(I,J) = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1)))
+ endif
+ enddo ; enddo
+ else
+ !$OMP do
+ do J=js-1,Jeq ; do I=is-1,Ieq
+ cg1_q(I,J) = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1)))
+ enddo ; enddo
+ endif
+
! Do this calculation on the extent used in MOM_hor_visc.F90, and
! MOM_tracer.F90 so that no halo update is needed.
-
-!$OMP parallel default(none) shared(is,ie,js,je,Ieq,Jeq,CS,US) &
-!$OMP private(dx_term,cg1_q,power_2,cg1_u,cg1_v)
if (CS%Res_fn_power_visc >= 100) then
-!$OMP do
+ !$OMP do
do j=js-1,je+1 ; do i=is-1,ie+1
dx_term = CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j)
if ((CS%Res_coef_visc * CS%cg1(i,j))**2 > dx_term) then
@@ -385,139 +426,173 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt)
CS%Res_fn_h(i,j) = 1.0
endif
enddo ; enddo
-!$OMP do
+ !$OMP do
do J=js-1,Jeq ; do I=is-1,Ieq
- cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1)))
- dx_term = CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J)
- if ((CS%Res_coef_visc * cg1_q)**2 > dx_term) then
+ dx_term = CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J)
+ if ((CS%Res_coef_visc * cg1_q(I,J))**2 > dx_term) then
CS%Res_fn_q(I,J) = 0.0
else
CS%Res_fn_q(I,J) = 1.0
endif
enddo ; enddo
elseif (CS%Res_fn_power_visc == 2) then
-!$OMP do
+ !$OMP do
do j=js-1,je+1 ; do i=is-1,ie+1
dx_term = CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j)
CS%Res_fn_h(i,j) = dx_term / (dx_term + (CS%Res_coef_visc * CS%cg1(i,j))**2)
enddo ; enddo
-!$OMP do
+ !$OMP do
do J=js-1,Jeq ; do I=is-1,Ieq
- cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1)))
- dx_term = CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J)
- CS%Res_fn_q(I,J) = dx_term / (dx_term + (CS%Res_coef_visc * cg1_q)**2)
+ dx_term = CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J)
+ CS%Res_fn_q(I,J) = dx_term / (dx_term + (CS%Res_coef_visc * cg1_q(I,J))**2)
enddo ; enddo
elseif (mod(CS%Res_fn_power_visc, 2) == 0) then
power_2 = CS%Res_fn_power_visc / 2
-!$OMP do
+ !$OMP do
do j=js-1,je+1 ; do i=is-1,ie+1
dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j)))**power_2
CS%Res_fn_h(i,j) = dx_term / &
(dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*CS%cg1(i,j))**CS%Res_fn_power_visc)
enddo ; enddo
-!$OMP do
+ !$OMP do
do J=js-1,Jeq ; do I=is-1,Ieq
- cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1)))
- dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J)))**power_2
+ dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J)))**power_2
CS%Res_fn_q(I,J) = dx_term / &
- (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q)**CS%Res_fn_power_visc)
+ (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q(I,J))**CS%Res_fn_power_visc)
enddo ; enddo
else
-!$OMP do
+ !$OMP do
do j=js-1,je+1 ; do i=is-1,ie+1
dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_h(i,j) + &
CS%cg1(i,j)*CS%beta_dx2_h(i,j)))**CS%Res_fn_power_visc
CS%Res_fn_h(i,j) = dx_term / &
(dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*CS%cg1(i,j))**CS%Res_fn_power_visc)
enddo ; enddo
-!$OMP do
+ !$OMP do
do J=js-1,Jeq ; do I=is-1,Ieq
- cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1)))
dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_q(I,J) + &
- cg1_q * CS%beta_dx2_q(I,J)))**CS%Res_fn_power_visc
+ cg1_q(I,J) * CS%beta_dx2_q(I,J)))**CS%Res_fn_power_visc
CS%Res_fn_q(I,J) = dx_term / &
- (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q)**CS%Res_fn_power_visc)
+ (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q(I,J))**CS%Res_fn_power_visc)
enddo ; enddo
endif
if (CS%interpolate_Res_fn) then
- do j=js,je ; do I=is-1,Ieq
- CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j))
- enddo ; enddo
- do J=js-1,Jeq ; do i=is,ie
- CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1))
- enddo ; enddo
+ if (apply_u_OBC) then
+ do j=js,je ; do I=is-1,Ieq
+ CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j))
+ if (OBC%segnum_u(I,j) > 0) CS%Res_fn_u(I,j) = CS%Res_fn_h(i,j) ! Eastern OBC
+ if (OBC%segnum_u(I,j) < 0) CS%Res_fn_u(I,j) = CS%Res_fn_h(i+1,j) ! Western OBC
+ enddo ; enddo
+ else
+ do j=js,je ; do I=is-1,Ieq
+ CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j))
+ enddo ; enddo
+ endif
+
+ if (apply_v_OBC) then
+ do J=js-1,Jeq ; do i=is,ie
+ CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1))
+ if (OBC%segnum_v(i,J) > 0) CS%Res_fn_v(i,J) = CS%Res_fn_h(i,j) ! Northern OBC
+ if (OBC%segnum_v(i,J) < 0) CS%Res_fn_v(i,J) = CS%Res_fn_h(i,j+1) ! Southern OBC
+ enddo ; enddo
+ else
+ do J=js-1,Jeq ; do i=is,ie
+ CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1))
+ enddo ; enddo
+ endif
+
else ! .not.CS%interpolate_Res_fn
+ if (apply_u_OBC) then
+ !$OMP do
+ do j=js,je ; do I=is-1,Ieq
+ cg1_u(I,j) = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j))
+ if (OBC%segnum_u(I,j) > 0) cg1_u(I,j) = CS%cg1(i,j) ! Eastern OBC
+ if (OBC%segnum_u(I,j) < 0) cg1_u(I,j) = CS%cg1(i+1,j) ! Western OBC
+ enddo ; enddo
+ else
+ !$OMP do
+ do j=js,je ; do I=is-1,Ieq
+ cg1_u(I,j) = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j))
+ enddo ; enddo
+ endif
+
+ if (apply_v_OBC) then
+ !$OMP do
+ do J=js-1,Jeq ; do i=is,ie
+ cg1_v(i,J) = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1))
+ if (OBC%segnum_v(i,J) > 0) cg1_v(i,J) = CS%cg1(i,j) ! Northern OBC
+ if (OBC%segnum_v(i,J) < 0) cg1_v(i,J) = CS%cg1(i,j+1) ! Southern OBC
+ enddo ; enddo
+ else
+ !$OMP do
+ do J=js-1,Jeq ; do i=is,ie
+ cg1_v(i,J) = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1))
+ enddo ; enddo
+ endif
+
if (CS%Res_fn_power_khth >= 100) then
-!$OMP do
+ !$OMP do
do j=js,je ; do I=is-1,Ieq
- cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j))
- dx_term = CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j)
- if ((CS%Res_coef_khth * cg1_u)**2 > dx_term) then
+ dx_term = CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j)
+ if ((CS%Res_coef_khth * cg1_u(I,j))**2 > dx_term) then
CS%Res_fn_u(I,j) = 0.0
else
CS%Res_fn_u(I,j) = 1.0
endif
enddo ; enddo
-!$OMP do
+ !$OMP do
do J=js-1,Jeq ; do i=is,ie
- cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1))
- dx_term = CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J)
- if ((CS%Res_coef_khth * cg1_v)**2 > dx_term) then
+ dx_term = CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J)
+ if ((CS%Res_coef_khth * cg1_v(i,J))**2 > dx_term) then
CS%Res_fn_v(i,J) = 0.0
else
CS%Res_fn_v(i,J) = 1.0
endif
enddo ; enddo
elseif (CS%Res_fn_power_khth == 2) then
-!$OMP do
+ !$OMP do
do j=js,je ; do I=is-1,Ieq
- cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j))
- dx_term = CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j)
- CS%Res_fn_u(I,j) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_u)**2)
+ dx_term = CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j)
+ CS%Res_fn_u(I,j) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_u(I,j))**2)
enddo ; enddo
-!$OMP do
+ !$OMP do
do J=js-1,Jeq ; do i=is,ie
- cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1))
- dx_term = CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J)
- CS%Res_fn_v(i,J) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_v)**2)
+ dx_term = CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J)
+ CS%Res_fn_v(i,J) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_v(i,J))**2)
enddo ; enddo
elseif (mod(CS%Res_fn_power_khth, 2) == 0) then
power_2 = CS%Res_fn_power_khth / 2
-!$OMP do
+ !$OMP do
do j=js,je ; do I=is-1,Ieq
- cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j))
- dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j)))**power_2
+ dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j)))**power_2
CS%Res_fn_u(I,j) = dx_term / &
- (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u)**CS%Res_fn_power_khth)
+ (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u(I,j))**CS%Res_fn_power_khth)
enddo ; enddo
-!$OMP do
+ !$OMP do
do J=js-1,Jeq ; do i=is,ie
- cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1))
- dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J)))**power_2
+ dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J)))**power_2
CS%Res_fn_v(i,J) = dx_term / &
- (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v)**CS%Res_fn_power_khth)
+ (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v(i,J))**CS%Res_fn_power_khth)
enddo ; enddo
else
-!$OMP do
+ !$OMP do
do j=js,je ; do I=is-1,Ieq
- cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j))
dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_u(I,j) + &
- cg1_u * CS%beta_dx2_u(I,j)))**CS%Res_fn_power_khth
+ cg1_u(I,j) * CS%beta_dx2_u(I,j)))**CS%Res_fn_power_khth
CS%Res_fn_u(I,j) = dx_term / &
- (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u)**CS%Res_fn_power_khth)
+ (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u(I,j))**CS%Res_fn_power_khth)
enddo ; enddo
-!$OMP do
+ !$OMP do
do J=js-1,Jeq ; do i=is,ie
- cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1))
dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_v(i,J) + &
- cg1_v * CS%beta_dx2_v(i,J)))**CS%Res_fn_power_khth
+ cg1_v(i,J) * CS%beta_dx2_v(i,J)))**CS%Res_fn_power_khth
CS%Res_fn_v(i,J) = dx_term / &
- (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v)**CS%Res_fn_power_khth)
+ (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v(i,J))**CS%Res_fn_power_khth)
enddo ; enddo
endif
endif
-!$OMP end parallel
+ !$OMP end parallel
if (query_averaging_enabled(CS%diag)) then
if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag)
@@ -532,34 +607,50 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, dt)
call uvchksum("Res_fn_[uv]", CS%Res_fn_u, CS%Res_fn_v, G%HI, haloshift=0, &
unscale=1.0, scalar_pair=.true.)
endif
-
end subroutine calc_resoln_function
!> Calculates and stores functions of SQG mode
-subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE)
+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(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m]
- real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m]
- real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1]
- real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1]
- real, dimension(SZI_(G), SZJ_(G)) :: f ! Absolute value of the Coriolis parameter at h point [T-1 ~> s-1]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! The interface heights relative to mean sea level [Z ~> m]
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of buoyancy frequency at u-points [L2 Z-2 T-2 ~> s-2]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of buoyancy frequency at v-points [L2 Z-2 T-2 ~> s-2]
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m]
+ real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1]
+ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1]
+ real, dimension(SZI_(G),SZJ_(G)) :: f ! Absolute value of the Coriolis parameter at h point [T-1 ~> s-1]
real :: N2 ! Positive buoyancy frequency square or zero [L2 Z-2 T-2 ~> s-2]
real :: dzc ! Spacing between two adjacent layers in stretched vertical coordinate [Z ~> m]
real :: f_subround ! The minimal resolved value of Coriolis parameter to prevent division by zero [T-1 ~> s-1]
- real, dimension(SZI_(G), SZJ_(G)) :: Le ! Eddy length scale [L ~> m]
+ real, 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 +659,100 @@ 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
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: e)
+ call find_eta(h, tv, G, GV, US, e, halo_size=2) !### Could be halo_size=1?
+ !$omp target exit data map(from: e)
+ 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 +768,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]
@@ -633,16 +782,20 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC)
"Module must be initialized before it is used.")
if (CS%calculate_Eady_growth_rate) then
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: e)
call find_eta(h, tv, G, GV, US, e, halo_size=2)
+ !$omp target exit data map(from: e)
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 +819,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 +832,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,27 +851,82 @@ 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 kg4 m-8]
+ real :: h4_v(SZI_(G),SZJB_(G),SZK_(GV)+1) ! The product of the 4 thicknesses surrounding a v-point
+ ! interface or the inward equivalent with OBCs [H4 ~> m4 or kg4 m-8]
+ integer :: i, j, k, is, ie, js, je, nz
if (.not. CS%initialized) call MOM_error(FATAL, "calc_Visbeck_coeffs_old: "// &
"Module must be initialized before it is used.")
if (.not. CS%calculate_Eady_growth_rate) return
- if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// &
+ if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function: "// &
"%SN_u is not associated with use_variable_mixing.")
- if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:R"// &
+ if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function: "// &
"%SN_v is not associated with use_variable_mixing.")
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
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 +943,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 +986,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 +1027,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, &
@@ -837,7 +1062,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN,
real :: dz_neglect ! A negligibly small distance to avoid division by zero [Z ~> m]
real :: r_crp_dist ! The inverse of the distance over which to scale the cropping [Z-1 ~> m-1]
real :: dB, dT ! Elevation variables used when cropping [Z ~> m]
- integer :: i, j, k, l_seg
+ integer :: i, j, k
logical :: crop
dz_neglect = GV%dZ_subroundoff
@@ -858,7 +1083,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN,
CS%SN_v(i,j) = 0.0
enddo ; enddo
- !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg,vint_SN,sum_dz,dT,dB)
+ !$OMP parallel do default(shared) private(dnew,dz,weight,vint_SN,sum_dz,dT,dB)
do j=G%jsc-1,G%jec+1
do I=G%isc-1,G%iec
vint_SN(I) = 0.
@@ -901,7 +1126,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN,
enddo
enddo
- !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg,vint_SN,sum_dz,dT,dB)
+ !$OMP parallel do default(shared) private(dnew,dz,weight,vint_SN,sum_dz,dT,dB)
do J=G%jsc-1,G%jec
do i=G%isc-1,G%iec+1
vint_SN(i) = 0.
@@ -982,6 +1207,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e)
! real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The vertical distance across each layer [Z ~> m]
real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2]
real :: dZ_cutoff ! A minimum water column depth for masking [H ~> m or kg m-2]
+ real :: h1, h2 ! Temporary total thicknesses [Z ~> m]
real :: h_neglect ! A thickness that is so small it is usually lost
! in roundoff and can be neglected [H ~> m or kg m-2].
real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim]
@@ -996,15 +1222,14 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e)
! bathymetric depth for certain calculations.
integer :: is, ie, js, je, nz
integer :: i, j, k
- integer :: l_seg
if (.not. CS%initialized) call MOM_error(FATAL, "calc_slope_functions_using_just_e: "// &
"Module must be initialized before it is used.")
if (.not. CS%calculate_Eady_growth_rate) return
- if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// &
+ if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function: "// &
"%SN_u is not associated with use_variable_mixing.")
- if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// &
+ if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function: "// &
"%SN_v is not associated with use_variable_mixing.")
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
@@ -1091,9 +1316,10 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e)
enddo
else
do I=is-1,ie
- if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then
- CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / &
- (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) )
+ h1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)
+ h2 = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0)
+ if ( min(h1, h2) > dZ_cutoff ) then
+ CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / max(h1, h2) )
else
CS%SN_u(I,j) = 0.0
endif
@@ -1116,9 +1342,10 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e)
! There is a primordial horizontal indexing bug on the following line from the previous
! versions of the code. This comment should be deleted by the end of 2024.
! if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then
- if ( min(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref > dZ_cutoff ) then
- CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / &
- (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) )
+ h1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)
+ h2 = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0)
+ if ( min(h1, h2) > dZ_cutoff ) then
+ CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / max(h1, h2) )
else
CS%SN_v(i,J) = 0.0
endif
@@ -1147,9 +1374,12 @@ subroutine calc_QG_slopes(h, tv, dt, G, GV, US, slope_x, slope_y, CS, OBC)
if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_QG_slopes: "//&
"Module must be initialized before it is used.")
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: e)
call find_eta(h, tv, G, GV, US, e, halo_size=3)
+ !$omp target exit data map(from: e)
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 +1567,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
@@ -1373,7 +1610,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
"when the first baroclinic deformation radius is well "//&
"resolved.", default=.false.)
call get_param(param_file, mdl, "DEPTH_SCALED_KHTH", CS%Depth_scaled_KhTh, &
- "If true, KHTH is scaled away when the depth is shallower"//&
+ "If true, KHTH is scaled away when the depth is shallower "//&
"than a reference depth: KHTH = MIN(1,H/H0)**N * KHTH, "//&
"where H0 is a reference depth, controlled via DEPTH_SCALED_KHTH_H0, "//&
"and the exponent (N) is controlled via DEPTH_SCALED_KHTH_EXP.",&
@@ -1394,7 +1631,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
if (.not.use_MEKE) Resoln_scaled_MEKE_visc = .false.
call get_param(param_file, mdl, "RESOLN_USE_EBT", CS%Resoln_use_ebt, &
"If true, uses the equivalent barotropic wave speed instead "//&
- "of first baroclinic wave for calculating the resolution fn.",&
+ "of first baroclinic wave for calculating the resolution function.",&
default=.false.)
call get_param(param_file, mdl, "BACKSCAT_EBT_POWER", CS%BS_EBT_power, &
"Power to raise EBT vertical structure to when backscatter "// &
@@ -1403,9 +1640,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 +1705,20 @@ 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
+ call get_param(param_file, mdl, "RESOLN_FUNCTION_OBC_BUG", CS%res_fn_OBC_bug, &
+ "If false, use only interior data for calculating the resolution functions at "//&
+ "open boundary condition faces and vertices.", &
+ default=enable_bugs, do_not_log=(number_of_OBC_segments<=0))
if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct &
.or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) then
@@ -1483,30 +1731,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 +1784,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)
@@ -1560,7 +1808,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
"that avoids division by layer thickness. Recommended.", default=.false.)
if (CS%use_simpler_Eady_growth_rate) then
if (.not. CS%use_stored_slopes) call MOM_error(FATAL, &
- "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//&
+ "MOM_lateral_mixing_coeffs.F90, VarMix_init: "//&
"When USE_SIMPLER_EADY_GROWTH_RATE=True, USE_STORED_SLOPES must also be True.")
call get_param(param_file, mdl, "EADY_GROWTH_RATE_D_SCALE", CS%Eady_GR_D_scale, &
"The depth from surface over which to average SN when calculating "//&
@@ -1725,10 +1973,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
"function independently at each point.", default=.false.)
if (CS%interpolate_Res_fn) then
if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, &
- "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//&
+ "MOM_lateral_mixing_coeffs.F90, VarMix_init: "//&
"When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_SCALE_COEF.")
if (CS%Res_fn_power_visc /= CS%Res_fn_power_khth) call MOM_error(FATAL, &
- "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//&
+ "MOM_lateral_mixing_coeffs.F90, VarMix_init: "//&
"When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.")
endif
call get_param(param_file, mdl, "GILL_EQUATORIAL_LD", Gill_equatorial_Ld, &
@@ -1860,12 +2108,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, &
@@ -1885,7 +2133,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS)
enddo ; enddo
if (.not. CS%use_stored_slopes) call MOM_error(FATAL, &
- "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//&
+ "MOM_lateral_mixing_coeffs.F90, VarMix_init: "//&
"USE_STORED_SLOPES must be True when using QG Leith.")
endif
@@ -1897,61 +2145,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 +2261,7 @@ end subroutine VarMix_end
!! \section section_vertical_structure_khth Vertical structure function for KhTh
!!
!! The thickness diffusivity can be prescribed a vertical distribution with the shape of the equivalent barotropic
-!! velocity mode. The structure function is stored in the control structure for thie module (varmix_cs) but is
+!! velocity mode. The structure function is stored in the control structure for this module (varmix_cs) but is
!! calculated using subroutines in mom_wave_speed.
!!
!! | Symbol | Module parameter |
diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_Love_numbers.F90
similarity index 99%
rename from src/parameterizations/lateral/MOM_load_love_numbers.F90
rename to src/parameterizations/lateral/MOM_load_Love_numbers.F90
index 8faf3aafab..8ca2951cc4 100644
--- a/src/parameterizations/lateral/MOM_load_love_numbers.F90
+++ b/src/parameterizations/lateral/MOM_load_Love_numbers.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Load Love Numbers for degree range [0, 1440]
module MOM_load_love_numbers
diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90
index 00b3e0e616..c078dbd944 100644
--- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90
+++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> \brief Parameterization of mixed layer restratification by unresolved mixed-layer eddies.
module MOM_mixed_layer_restrat
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum
use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl
use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type
@@ -230,8 +232,8 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor
! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]
real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3]
- real :: rml_int_fast(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3]
- real :: rml_int_slow(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3]
+ real :: rml_int_fast(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-5]
+ real :: rml_int_slow(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-5]
real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1]
real :: SpV_int_fast(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m]
real :: SpV_int_slow(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m]
@@ -246,7 +248,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0.
real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2]
real :: I4dt ! 1/(4 dt) [T-1 ~> s-1]
- real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1]
+ real :: Ihtot, Ihtot_slow ! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1]
real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux
! magnitudes (uDml & vDml) to the realized flux in a
! layer [nondim]. The vertical sum of a() through the pieces of
@@ -294,7 +296,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// &
"The resolution argument, Rd/dx, was not associated.")
if (CS%use_Stanley_ML .and. .not.GV%Boussinesq) call MOM_error(FATAL, &
- "MOM_mixedlayer_restrat: The Stanley parameterization is not"//&
+ "MOM_mixedlayer_restrat: The Stanley parameterization is not "//&
"available without the Boussinesq approximation.")
! Extract the friction velocity from the forcing type.
@@ -367,7 +369,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
do j=js,je ; do i=is,ie
if ((G%mask2dT(i,j) > 0.0) .and. (mle_fl_2d(i,j) < 0.0)) then
write(mesg,'(" Time_interp negative MLE frontal-length scale of ",(1pe12.4)," at i,j = ",&
- & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') &
+ & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') &
mle_fl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j)
call MOM_error(FATAL, "MOM_mixed_layer_restrat mixedlayer_restrat_OM4: "//trim(mesg))
endif
@@ -491,7 +493,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j)))
absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J)))
- ! Compute I_LFront = 1 / (frontal length scale) [m-1]
+ ! Compute I_LFront = 1 / (frontal length scale) [L-1 ~> m-1]
lfront = 0.5 * (mle_fl_2d(i,j) + mle_fl_2d(i+1,j))
! Adcroft reciprocal
I_LFront = 0.0 ; if (lfront /= 0.0) I_LFront = 1.0/lfront
@@ -513,7 +515,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
timescale = timescale * CS%ml_restrat_coef
if (res_upscale) timescale = timescale * res_scaling_fac
- uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * &
+ uDml(I) = timescale * G%dyCu(I,j)*G%IdxCu_OBCmask(I,j) * &
(Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2)
! As above but using the slow filtered MLD
@@ -528,7 +530,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
timescale = timescale * CS%ml_restrat_coef2
if (res_upscale) timescale = timescale * res_scaling_fac
- uDml_slow(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * &
+ uDml_slow(I) = timescale * G%dyCu(I,j)*G%IdxCu_OBCmask(I,j) * &
(Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2)
if (uDml(I) + uDml_slow(I) == 0.) then
@@ -580,7 +582,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
!$OMP do
do J=js-1,je ; do i=is,ie
u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1)))
- ! Compute I_LFront = 1 / (frontal length scale) [m-1]
+ ! Compute I_LFront = 1 / (frontal length scale) [L-1 ~> m-1]
lfront = 0.5 * (mle_fl_2d(i,j) + mle_fl_2d(i,j+1))
! Adcroft reciprocal
I_LFront = 0.0 ; if (lfront /= 0.0) I_LFront = 1.0/lfront
@@ -603,7 +605,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
timescale = timescale * CS%ml_restrat_coef
if (res_upscale) timescale = timescale * res_scaling_fac
- vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * &
+ vDml(i) = timescale * G%dxCv(i,J)*G%IdyCv_OBCmask(i,J) * &
(Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2)
! As above but using the slow filtered MLD
@@ -618,7 +620,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix,
timescale = timescale * CS%ml_restrat_coef2
if (res_upscale) timescale = timescale * res_scaling_fac
- vDml_slow(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * &
+ vDml_slow(i) = timescale * G%dxCv(i,J)*G%IdyCv_OBCmask(i,J) * &
(Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2)
if (vDml(i) + vDml_slow(i) == 0.) then
@@ -818,17 +820,16 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d
real :: grid_dsd ! combination of grid scales [L2 ~> m2]
real :: h_sml ! "Little h", the active mixing depth with diurnal cycle removed [H ~> m or kg m-2]
real :: h_big ! "Big H", the mixed layer depth based on a time filtered "little h" [H ~> m or kg m-2]
- real :: grd_b ! The vertically average gradient of buoyancy [L H-1 T-2 ~> s-2 or m-3 kg-1 s-2]
+ real :: grd_b ! The vertically average gradient of buoyancy [L H-1 T-2 ~> s-2 or m3 kg-1 s-2]
real :: psi_mag ! Magnitude of stream function [L2 H T-1 ~> m3 s-1 or kg s-1]
real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2]
real :: I4dt ! 1/(4 dt) [T-1 ~> s-1]
- real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1]
+ real :: Ihtot ! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1]
real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2]
real :: sigint ! Fractional position within the mixed layer of the interface above a layer [nondim]
real :: muzb ! mu(z) at bottom of the layer [nondim]
real :: muza ! mu(z) at top of the layer [nondim]
real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2]
- real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim]
real :: Z3_T3_to_m3_s3 ! Conversion factors to undo scaling and permit terms to be raised to a
! fractional power [T3 m3 Z-3 s-3 ~> 1]
real :: m2_s2_to_Z2_T2 ! Conversion factors to restore scaling after a term is raised to a
@@ -1199,7 +1200,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d
end subroutine mixedlayer_restrat_Bodner
-!> Two time-scale running mean [units of "signal" and "filtered"]
+!> Two time-scale running mean in the same arbitrary units as "signal" and "filtered"
!!
!! If signal > filtered, returns running-mean with time scale "tau_growing".
!! If signal <= filtered, returns running-mean with time scale "tau_decaying".
@@ -1213,8 +1214,8 @@ end subroutine mixedlayer_restrat_Bodner
!! rmean2ts with tau_growing=0 recovers the "resetting running mean" used in OM4.
real elemental function rmean2ts(signal, filtered, tau_growing, tau_decaying, dt)
! Arguments
- real, intent(in) :: signal ! Unfiltered signal [arbitrary units]
- real, intent(in) :: filtered ! Current value of running mean [arbitrary units]
+ real, intent(in) :: signal ! Unfiltered signal in arbitrary units [A]
+ real, intent(in) :: filtered ! Current value of running mean in the same arbitrary units [A]
real, intent(in) :: tau_growing ! Time scale for growing signal [T ~> s]
real, intent(in) :: tau_decaying ! Time scale for decaying signal [T ~> s]
real, intent(in) :: dt ! Time step [T ~> s]
@@ -1267,7 +1268,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS)
real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor
! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]
real :: Rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3]
- real :: rho_int(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3]
+ real :: rho_int(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-5]
real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1]
real :: SpV_int(SZI_(G)) ! Specific volume integrated through the surface layer [H R-1 ~> m4 kg-1 or m]
real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa]
@@ -1399,7 +1400,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS)
timescale = timescale * CS%ml_restrat_coef
! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2)
- uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * &
+ uDml(I) = timescale * G%dyCu(I,j)*G%IdxCu_OBCmask(I,j) * &
(Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2)
if (uDml(I) == 0) then
@@ -1450,7 +1451,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS)
timescale = timescale * CS%ml_restrat_coef
! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2)
- vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * &
+ vDml(i) = timescale * G%dxCv(i,J)*G%IdyCv_OBCmask(i,J) * &
(Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2)
if (vDml(i) == 0) then
do k=1,nkml ; vhml(i,J,k) = 0.0 ; enddo
@@ -1655,7 +1656,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS,
character(len=32) :: fl_varname ! Name of front-length scale variable in mle_fl_file.
# include "version_variable.h"
- integer :: i, j
character(len=200) :: filename, varname
! Read all relevant parameters and write them to the model log.
@@ -1858,7 +1858,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS,
endif
if (CS%fl_from_file .and. CS%front_length>0.0) call MOM_error(FATAL, "mixedlayer_restrat_init: "// &
"MLE_FRONT_LENGTH_FROM_FILE cannot be true when MLE_FRONT_LENGTH > 0.0. "// &
- "If you want to use MLE_FRONT_LENGTH, set MLE_FRONT_LENGTH_FROM_FILE to false." // &
+ "If you want to use MLE_FRONT_LENGTH, set MLE_FRONT_LENGTH_FROM_FILE to false. " // &
"If you want to use MLE_FRONT_LENGTH_FROM_FILE, set MLE_FRONT_LENGTH to 0.0.")
call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, &
"If true, the MLE parameterization will use the mixed-layer "//&
@@ -2032,8 +2032,8 @@ end subroutine mixedlayer_restrat_register_restarts
!! Returns false otherwise.
logical function mixedlayer_restrat_unit_tests(verbose)
logical, intent(in) :: verbose !< If true, write results to stdout
+
! Local variables
- type(mixedlayer_restrat_CS) :: CS ! Control structure
logical :: this_test
print *,'===== mixedlayer_restrat: mixedlayer_restrat_unit_tests =================='
@@ -2085,7 +2085,6 @@ logical function test_answer(verbose, u, u_true, label, tol)
real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A]
! Local variables
real :: tolerance ! The tolerance for differences between u and u_true [A]
- integer :: k
tolerance = 0.0 ; if (present(tol)) tolerance = tol
test_answer = .false.
diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90
index 5b2ba9bad1..7f6e35008c 100644
--- a/src/parameterizations/lateral/MOM_self_attr_load.F90
+++ b/src/parameterizations/lateral/MOM_self_attr_load.F90
@@ -1,18 +1,26 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
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
@@ -34,13 +42,13 @@ module MOM_self_attr_load
real :: eta_prop
!< The partial derivative of eta_sal with the local value of eta [nondim].
real :: linear_scaling
- !< Dimensional coefficients for scalar SAL [nondim or Z T2 L-2 R-1 ~> m Pa-1]
+ !< Dimensional coefficients for scalar SAL [nondim] or [Z T2 L-2 R-1 ~> m Pa-1]
type(sht_CS), allocatable :: sht
!< Spherical harmonic transforms (SHT) control structure
integer :: sal_sht_Nd
!< Maximum degree for spherical harmonic transforms [nondim]
- real, allocatable :: ebot_ref(:,:)
- !< Reference bottom pressure scaled by Rho_0 and G_Earth[Z ~> m]
+ real, allocatable :: 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 +87,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,22 +184,32 @@ 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
+ integer :: default_answer_date, tides_answer_date ! Recover old answers with tides
real :: sal_scalar_value ! Scaling SAL factors [nondim]
integer :: isd, ied, jsd, jed
@@ -204,40 +222,66 @@ 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, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
+ "This sets the default value for the various _ANSWER_DATE parameters.", &
+ default=99991231, do_not_log=.True.) ! used to check SAL_USE_BPA
+ call get_param(param_file, '', "TIDES_ANSWER_DATE", tides_answer_date, &
+ default=default_answer_date, do_not_log=.True.) ! used to check SAL_USE_BPA
if (tides_answer_date<=20250131 .and. CS%use_bpa) &
call MOM_error(FATAL, trim(mdl) // ", SAL_init: SAL_USE_BPA needs to be false to recover "//&
"tide answers before 20250131.")
+ call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", use_tidal_sal_file, default=.false., &
+ do_not_log=.True.) ! used to set default of SAL_SCALAR_APPROX
call get_param(param_file, mdl, "SAL_SCALAR_APPROX", CS%use_sal_scalar, &
"If true, use the scalar approximation to calculate self-attraction and "//&
"loading.", default=tides .and. (.not. use_tidal_sal_file))
@@ -250,6 +294,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 +346,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_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90
index 7606ac3ce1..d948583a42 100644
--- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90
+++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Laplace's spherical harmonic transforms (SHT)
module MOM_spherical_harmonics
use MOM_coms_infra, only : sum_across_PEs
@@ -227,7 +231,7 @@ subroutine spherical_harmonics_init(G, param_file, CS)
! local variables
real, parameter :: PI = 4.0*atan(1.0) ! 3.1415926... calculated as 4*atan(1) [nondim]
- real, parameter :: RADIAN = PI / 180.0 ! Degree to Radian constant [rad/degree]
+ real, parameter :: RADIAN = PI / 180.0 ! Degree to Radian constant [radian degree-1]
real, dimension(SZI_(G),SZJ_(G)) :: sin_clatT ! sine of colatitude at the t-cells [nondim].
real :: Pmm_coef ! = sqrt{ 1.0/(4.0*PI) * prod[(2k+1)/2k)] } [nondim].
integer :: is, ie, js, je
diff --git a/src/parameterizations/lateral/MOM_streaming_filter.F90 b/src/parameterizations/lateral/MOM_streaming_filter.F90
index 7a8bc1b774..701d0848a0 100644
--- a/src/parameterizations/lateral/MOM_streaming_filter.F90
+++ b/src/parameterizations/lateral/MOM_streaming_filter.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Streaming band-pass filter for detecting the instantaneous tidal signals in the simulation
module MOM_streaming_filter
@@ -8,7 +12,7 @@ module MOM_streaming_filter
use MOM_io, only : axis_info, set_axis_info
use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS
use MOM_tidal_forcing, only : tidal_frequency
-use MOM_time_manager, only : time_type, time_type_to_real
+use MOM_time_manager, only : time_type, time_to_real
use MOM_unit_scaling, only : unit_scale_type
implicit none ; private
@@ -157,7 +161,7 @@ subroutine Filt_accum(u, u1, Time, US, CS)
c1, c2 !< Coefficients for the filter equations [nondim]
integer :: i, j, k
- now = US%s_to_T * time_type_to_real(Time)
+ now = time_to_real(Time, scale=US%s_to_T)
! Initialize CS%old_time at the first time step
if (CS%old_time<0.0) CS%old_time = now
@@ -174,7 +178,7 @@ subroutine Filt_accum(u, u1, Time, US, CS)
do j=CS%js,CS%je ; do i=CS%is,CS%ie
CS%s1(i,j,k) = c1 * CS%u1(i,j,k) + CS%s1(i,j,k)
CS%u1(i,j,k) = -c1 * (CS%s1(i,j,k) - CS%filter_alpha(k) * u(i,j)) + c2 * CS%u1(i,j,k)
- enddo; enddo
+ enddo ; enddo
enddo ! k=1,CS%nf
endif ! (CS%old_time Isopycnal height diffusion (or Gent McWilliams diffusion)
module MOM_thickness_diffuse
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum, uvchksum
use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl
use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type
@@ -233,7 +235,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp
enddo ; enddo
! Calculates interface heights, e, in [Z ~> m].
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: e)
call find_eta(h, tv, G, GV, US, e, halo_size=1)
+ !$omp target exit data map(from: e)
! Set the diffusivities.
!$OMP parallel default(shared)
@@ -783,14 +788,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
! times unit conversion factors [L2 Z-2 T-2 ~> s-2]
real :: N2_unlim ! An unlimited estimate of the buoyancy frequency
! times unit conversion factors [L2 Z-2 T-2 ~> s-2]
- real :: Tl(5) ! copy of T in local stencil [C ~> degC]
- real :: mn_T ! mean of T in local stencil [C ~> degC]
- real :: mn_T2 ! mean of T**2 in local stencil [C2 ~> degC2]
- real :: hl(5) ! Copy of local stencil of H [H ~> m]
- real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1]
real :: Z_to_H ! A conversion factor from heights to thicknesses, perhaps based on
! a spatially variable local density [H Z-1 ~> nondim or kg m-3]
- real :: Tsgs2(SZI_(G),SZJ_(G),SZK_(GV)) ! Sub-grid temperature variance [C2 ~> degC2]
real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction
! [H L2 T-1 ~> m3 s-1 or kg s-1]
real :: diag_sfn_unlim_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction before
@@ -858,7 +857,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, &
"cg1 must be associated when using FGNV streamfunction.")
- !$OMP parallel default(shared) private(hl,r_sm_H,Tl,mn_T,mn_T2)
+ !$OMP parallel default(shared)
! Find the maximum and minimum permitted streamfunction.
!$OMP do
do j=js-1,je+1 ; do i=is-1,ie+1
@@ -904,7 +903,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
!$OMP h_neglect2,hn_2,I_slope_max2,int_slope_u,KH_u,uhtot, &
!$OMP h_frac,h_avail_rsum,uhD,h_avail,Work_u,CS,slope_x,cg1, &
!$OMP diag_sfn_x,diag_sfn_unlim_x,N2_floor,EOSdom_u,EOSdom_h1, &
- !$OMP use_stanley,Tsgs2,present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) &
+ !$OMP use_stanley,present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) &
!$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u,G_scale, &
!$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, &
!$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,N2_unlim, &
@@ -1086,7 +1085,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
if (present_slope_x) then
Slope = slope_x(I,j,k)
else
- Slope = ((e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j)
+ Slope = (e(i+1,j,K)-e(i,j,K)) * G%IdxCu_OBCmask(I,j)
endif
if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope
Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope
@@ -1219,7 +1218,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
!$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, &
!$OMP I_slope_max2,vhD,h_avail,Work_v,CS,slope_y,cg1,hn_2,&
!$OMP diag_sfn_y,diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,&
- !$OMP Tsgs2, present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) &
+ !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) &
!$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v,S_h,S_hr, &
!$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA,G_scale, &
!$OMP drho_dT_dT_h,drho_dT_dT_hr,scrap,pres_h,T_h,T_hr, &
@@ -1406,7 +1405,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV
if (present_slope_y) then
Slope = slope_y(i,J,k)
else
- Slope = ((e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J)
+ Slope = (e(i,j+1,K)-e(i,j,K)) * G%IdyCv_OBCmask(i,J)
endif
if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope
Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope)
@@ -2353,12 +2352,12 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS)
"MEKE_GM_SRC_ALT is true. Values below 20240601 recover the answers from the "//&
"original implementation, while higher values use expressions that satisfy "//&
"rotational symmetry.", &
- default=20240101, do_not_log=.not.CS%GM_src_alt) ! ### Change default to default_answer_date.
+ default=default_answer_date, do_not_log=.not.CS%GM_src_alt)
call get_param(param_file, mdl, "MEKE_GM_SRC_ALT_SLOPE_BUG", CS%MEKE_src_slope_bug, &
"If true, use a bug that limits the positive values, but not the negative values, "//&
"of the slopes used when MEKE_GM_SRC_ALT is true. When this is true, it breaks "//&
"all of the symmetry rules that MOM6 is supposed to obey.", &
- default=.true., do_not_log=.not.CS%GM_src_alt) ! ### Change default to False.
+ default=.false., do_not_log=.not.CS%GM_src_alt)
call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, &
"If true, uses the GM coefficient formulation from the GEOMETRIC "//&
diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90
index c19b7252f2..473a1eaf63 100644
--- a/src/parameterizations/lateral/MOM_tidal_forcing.F90
+++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90
@@ -1,18 +1,18 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Tidal contributions to geopotential
module MOM_tidal_forcing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, &
CLOCK_MODULE, CLOCK_ROUTINE
use MOM_domains, only : pass_var
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_grid, only : ocean_grid_type
-use MOM_harmonic_analysis, &
- only : HA_init, HA_register, harmonic_analysis_CS
use MOM_io, only : field_exists, file_exists, MOM_read_data
-use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-)
+use MOM_time_manager, only : set_date, time_type, time_minus_signed
use MOM_unit_scaling, only : unit_scale_type
implicit none ; private
@@ -98,7 +98,7 @@ subroutine astro_longitudes_init(time_ref, longitudes)
real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... [nondim]
! Find date at time_ref in days since midnight at the start of 1900-01-01
- D = time_type_to_real(time_ref - set_date(1900, 1, 1, 0, 0, 0)) / (24.0 * 3600.0)
+ D = time_minus_signed(time_ref, set_date(1900, 1, 1, 0, 0, 0)) / (24.0 * 3600.0)
! Time since 1900-01-01 in Julian centuries
! Kowalik and Luick use 36526, but Schureman uses 36525 which I think is correct.
T = D / 36525.0
@@ -235,13 +235,12 @@ end subroutine nodal_fu
!! while fields like the background viscosities are 2-D arrays.
!! ALLOC is a macro defined in MOM_memory.h for allocate or nothing with
!! static memory.
-subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS)
+subroutine tidal_forcing_init(Time, G, US, param_file, CS)
type(time_type), intent(in) :: Time !< The current model time.
type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters.
type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure
- type(harmonic_analysis_CS), optional, intent(out) :: HA_CS !< Control structure for harmonic analysis
! Local variables
real, dimension(SZI_(G), SZJ_(G)) :: &
@@ -261,7 +260,6 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS)
!! calculating tidal forcing.
type(time_type) :: nodal_time !< Model time to calculate nodal modulation for.
type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing
- logical :: HA_ssh, HA_ubt, HA_vbt
! This include declares and sets the variable "version".
# include "version_variable.h"
character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name.
@@ -270,7 +268,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS)
integer :: i, j, c, is, ie, js, je, isd, ied, jsd, jed, nc
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
- isd = G%isd ; ied = G%ied ; jsd = G%jsd; jed = G%jed
+ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
! Read all relevant parameters and write them to the model log.
call log_version(param_file, mdl, version, "")
@@ -370,8 +368,8 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS)
old_name='TIDE_SAL_SCALAR_VALUE')
if (nc > MAX_CONSTITUENTS) then
- write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, &
- &"to accommodate all the registered tidal constituents.")') nc
+ write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least ",I0, &
+ &" to accommodate all the registered tidal constituents.")') nc
call MOM_error(FATAL, "MOM_tidal_forcing"//mesg)
endif
@@ -566,20 +564,6 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS)
endif
enddo
- if (present(HA_CS)) then
- call HA_init(Time, US, param_file, CS%time_ref, CS%nc, CS%freq, CS%phase0, CS%const_name, &
- CS%tide_fn, CS%tide_un, HA_CS)
- call get_param(param_file, mdl, "HA_SSH", HA_ssh, &
- "If true, perform harmonic analysis of sea serface height.", default=.false.)
- if (HA_ssh) call HA_register('ssh', 'h', HA_CS)
- call get_param(param_file, mdl, "HA_UBT", HA_ubt, &
- "If true, perform harmonic analysis of zonal barotropic velocity.", default=.false.)
- if (HA_ubt) call HA_register('ubt', 'u', HA_CS)
- call get_param(param_file, mdl, "HA_VBT", HA_vbt, &
- "If true, perform harmonic analysis of meridional barotropic velocity.", default=.false.)
- if (HA_vbt) call HA_register('vbt', 'v', HA_CS)
- endif
-
id_clock_tides = cpu_clock_id('(Ocean tides)', grain=CLOCK_MODULE)
end subroutine tidal_forcing_init
@@ -649,7 +633,7 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS)
return
endif
- now = US%s_to_T * time_type_to_real(Time - cs%time_ref)
+ now = time_minus_signed(Time, cs%time_ref, scale=US%s_to_T)
do c=1,CS%nc
m = CS%struct(c)
@@ -723,7 +707,7 @@ subroutine calc_tidal_forcing_legacy(Time, e_sal, e_sal_tide, e_tide_eq, e_tide_
return
endif
- now = US%s_to_T * time_type_to_real(Time - cs%time_ref)
+ now = time_minus_signed(Time, cs%time_ref, scale=US%s_to_T)
do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
e_sal_tide(i,j) = e_sal(i,j)
diff --git a/src/parameterizations/lateral/MOM_wave_drag.F90 b/src/parameterizations/lateral/MOM_wave_drag.F90
index a507c762c1..eb3062769d 100644
--- a/src/parameterizations/lateral/MOM_wave_drag.F90
+++ b/src/parameterizations/lateral/MOM_wave_drag.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Frequency-dependent linear wave drag
module MOM_wave_drag
@@ -21,6 +25,10 @@ module MOM_wave_drag
integer :: nf !< Number of filters to be used in the simulation
real, allocatable, dimension(:,:,:) :: coef_u !< frequency-dependent drag coefficients [H T-1 ~> m s-1]
real, allocatable, dimension(:,:,:) :: coef_v !< frequency-dependent drag coefficients [H T-1 ~> m s-1]
+ real, allocatable, dimension(:,:,:) :: coef_uv !< frequency-dependent drag coefficients [H T-1 ~> m s-1]
+ real, allocatable, dimension(:,:,:) :: coef_vu !< frequency-dependent drag coefficients [H T-1 ~> m s-1]
+ logical :: tensor_drag !< If true, include the off-diagonal components of the
+ !! wave drag tensor for computing the wave drag
end type wave_drag_CS
contains
@@ -38,7 +46,7 @@ subroutine wave_drag_init(param_file, wave_drag_file, G, GV, US, CS)
character(len=40) :: mdl = "MOM_wave_drag" !< This module's name
character(len=50) :: filter_name_str !< List of drag coefficients to be used
character(len=2), allocatable, dimension(:) :: filter_names !< Names of drag coefficients
- character(len=80) :: var_names(2) !< Names of variables in wave_drag_file
+ character(len=80) :: var_names(4) !< Names of variables in wave_drag_file
character(len=200) :: mesg
real :: var_scale !< Scaling factors of drag coefficients [nondim]
integer :: c
@@ -53,8 +61,12 @@ subroutine wave_drag_init(param_file, wave_drag_file, G, GV, US, CS)
allocate(CS%coef_u(G%IsdB:G%IedB,G%jsd:G%jed,CS%nf)) ; CS%coef_u(:,:,:) = 0.0
allocate(CS%coef_v(G%isd:G%ied,G%JsdB:G%JedB,CS%nf)) ; CS%coef_v(:,:,:) = 0.0
+ allocate(CS%coef_uv(G%IsdB:G%IedB,G%jsd:G%jed,CS%nf)) ; CS%coef_uv(:,:,:) = 0.0
+ allocate(CS%coef_vu(G%isd:G%ied,G%JsdB:G%JedB,CS%nf)) ; CS%coef_vu(:,:,:) = 0.0
allocate(filter_names(CS%nf)) ; read(filter_name_str, *) filter_names
+ CS%tensor_drag = .false.
+
if (len_trim(wave_drag_file) > 0) then
do c=1,CS%nf
call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_U", &
@@ -65,11 +77,21 @@ subroutine wave_drag_init(param_file, wave_drag_file, G, GV, US, CS)
var_names(2), "The name of the variable in BT_WAVE_DRAG_FILE "//&
"for the drag coefficient of the "//trim(filter_names(c))//&
" frequency at v points.", default="")
+ call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_UV", &
+ var_names(3), "The name of the variable in BT_WAVE_DRAG_FILE "//&
+ "for the drag coefficient of the "//trim(filter_names(c))//&
+ " frequency at u points, corresponding to the off-diagonal "//&
+ "component of the wave drag tensor.", default="")
+ call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_VU", &
+ var_names(4), "The name of the variable in BT_WAVE_DRAG_FILE "//&
+ "for the drag coefficient of the "//trim(filter_names(c))//&
+ " frequency at v points, corresponding to the off-diagonal "//&
+ "component of the wave drag tensor.", default="")
call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_SCALE", &
var_scale, "A scaling factor for the drag coefficient of the "//&
trim(filter_names(c))//" frequency.", default=1.0, units="nondim")
- if (len_trim(var_names(1))+len_trim(var_names(2))>0 .and. var_scale>0.0) then
+ if (len_trim(var_names(1))>0 .and. len_trim(var_names(2))>0 .and. var_scale>0.0) then
call MOM_read_data(wave_drag_file, trim(var_names(1)), CS%coef_u(:,:,c), G%Domain, &
position=EAST_FACE, scale=var_scale*GV%m_to_H*US%T_to_s)
call MOM_read_data(wave_drag_file, trim(var_names(2)), CS%coef_v(:,:,c), G%Domain, &
@@ -77,6 +99,17 @@ subroutine wave_drag_init(param_file, wave_drag_file, G, GV, US, CS)
call pass_vector(CS%coef_u(:,:,c), CS%coef_v(:,:,c), G%domain, &
direction=To_All+SCALAR_PAIR)
+ if (len_trim(var_names(3))>0 .and. len_trim(var_names(4))>0) then
+ CS%tensor_drag = .true.
+
+ call MOM_read_data(wave_drag_file, trim(var_names(3)), CS%coef_uv(:,:,c), G%Domain, &
+ position=EAST_FACE, scale=var_scale*GV%m_to_H*US%T_to_s)
+ call MOM_read_data(wave_drag_file, trim(var_names(4)), CS%coef_vu(:,:,c), G%Domain, &
+ position=NORTH_FACE, scale=var_scale*GV%m_to_H*US%T_to_s)
+ call pass_vector(CS%coef_uv(:,:,c), CS%coef_vu(:,:,c), G%domain, &
+ direction=To_All+SCALAR_PAIR)
+ endif
+
write(mesg, *) "MOM_wave_drag: ", trim(filter_names(c)), &
" coefficients read from file, scaling factor = ", var_scale
call MOM_error(NOTE, trim(mesg))
@@ -101,27 +134,40 @@ subroutine wave_drag_calc(u, v, drag_u, drag_v, G, CS)
!! and scaled frequency-dependent drag [L2 T-2 ~> m2 s-2]
! Local variables
- integer :: is, ie, js, je, i, j, k
+ integer :: is, ie, js, je, i, j, c
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
- Drag_u(:,:) = 0.0 ; Drag_v(:,:) = 0.0
-
- !$OMP do
- do k=1,CS%nf ; do j=js,je ; do I=is-1,ie
- Drag_u(I,j) = Drag_u(I,j) + u(I,j,k) * CS%coef_u(I,j,k)
- enddo ; enddo ; enddo
-
- !$OMP do
- do k=1,CS%nf ; do J=js-1,je ; do i=is,ie
- Drag_v(i,J) = Drag_v(i,J) + v(i,J,k) * CS%coef_v(i,J,k)
- enddo ; enddo ; enddo
+ drag_u(:,:) = 0.0 ; drag_v(:,:) = 0.0
+
+ if (CS%tensor_drag) then
+ call pass_vector(u(:,:,1:CS%nf), v(:,:,1:CS%nf), G%domain, direction=To_All+SCALAR_PAIR)
+ !$OMP do
+ do j=js,je ; do I=is-1,ie ; do c=1,CS%nf ; if (G%mask2dCu(I,j) * CS%coef_u(I,j,c) > 0.0) then
+ drag_u(I,j) = drag_u(I,j) + (u(I,j,c) * CS%coef_u(I,j,c) + &
+ 0.25 * ((v(i+1,J,c) + v(i,J-1,c)) + (v(i,J,c) + v(i+1,J-1,c))) * CS%coef_uv(I,j,c))
+ endif ; enddo ; enddo ; enddo
+ !$OMP do
+ do J=js-1,je ; do i=is,ie ; do c=1,CS%nf ; if (G%mask2dCv(i,J) * CS%coef_v(i,J,c) > 0.0) then
+ drag_v(i,J) = drag_v(i,J) + (v(i,J,c) * CS%coef_v(i,J,c) + &
+ 0.25 * ((u(I-1,j,c) + u(I,j+1,c)) + (u(I,j,c) + u(I-1,j+1,c))) * CS%coef_vu(i,J,c))
+ endif ; enddo ; enddo ; enddo
+ else ! (.not.CS%tensor_drag)
+ !$OMP do
+ do j=js,je ; do I=is-1,ie ; do c=1,CS%nf ; if (G%mask2dCu(I,j) * CS%coef_u(I,j,c) > 0.0) then
+ drag_u(I,j) = drag_u(I,j) + u(I,j,c) * CS%coef_u(I,j,c)
+ endif ; enddo ; enddo ; enddo
+ !$OMP do
+ do J=js-1,je ; do i=is,ie ; do c=1,CS%nf ; if (G%mask2dCv(i,J) * CS%coef_v(i,J,c) > 0.0) then
+ drag_v(i,J) = drag_v(i,J) + v(i,J,c) * CS%coef_v(i,J,c)
+ endif ; enddo ; enddo ; enddo
+ endif ! (CS%tensor_drag)
end subroutine wave_drag_calc
!> \namespace mom_wave_drag
!!
-!! By Chengzhu Xu (chengzhu.xu@oregonstate.edu) and Edward D. Zaron, December 2024
+!! By Chengzhu Xu (chengzhu.xu@oregonstate.edu) and Edward D. Zaron
!!
!! This module calculates the net effects of the frequency-dependent internal wave drag applied to
!! the tidal velocities, and returns the sum of products of frequency-dependent drag coefficients
@@ -130,6 +176,9 @@ end subroutine wave_drag_calc
!! the number of drag coefficients cannot exceed that of the streaming filters, and the names of
!! drag coefficients should match those of the streaming filters. The frequency-dependent drag
!! coefficients are read from the same file for the linear drag coefficients in MOM_barotropic.
+!!
+!! Reference: Xu, C., & Zaron, E. D. (2025). Parameterization of frequency-dependent internal wave drag.
+!! Journal of Advances in Modeling Earth Systems, 17, e2025MS005126. https://doi.org/10.1029/2025MS005126
end module MOM_wave_drag
diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90
index ddc34fdbaa..20144839b8 100644
--- a/src/parameterizations/stochastic/MOM_stochastics.F90
+++ b/src/parameterizations/stochastic/MOM_stochastics.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Top-level module for the MOM6 ocean model in coupled mode.
module MOM_stochastics
-! This file is part of MOM6. See LICENSE.md for the license.
-
! This is the top level module for the MOM6 ocean model. It contains routines
! for initialization, update, and writing restart of stochastic physics. This
! particular version wraps all of the calls for MOM6 in the calls that had
@@ -53,24 +55,22 @@ module MOM_stochastics
!! dissipation rate used to set the amplitude of SKEBS [nondim]
real :: skeb_frict_coef !< If skeb_use_frict is true, then skeb_gm_coef * GM_work is added to the
!! dissipation rate used to set the amplitude of SKEBS [nondim]
- real, allocatable :: skeb_diss(:,:,:) !< Dissipation rate used to set amplitude of SKEBS [L2 T-3 ~> m2 s-2]
+ real, allocatable :: skeb_diss(:,:,:) !< Dissipation rate used to set amplitude of SKEBS [L2 T-3 ~> m2 s-3]
!! Index into this at h points.
! stochastic patterns
real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT
- !! tendencies with a number between 0 and 2
- real, allocatable :: skeb_wts(:,:) !< Random pattern for ocean SKEB
- real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation
- real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation
+ !! tendencies with a number between 0 and 2 [nondim]
+ real, allocatable :: skeb_wts(:,:) !< Random pattern for ocean SKEB [nondim]
+ real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation [nondim]
+ real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation [nondim]
type(time_type), pointer :: Time !< Pointer to model time (needed for sponges)
type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the
! Taper array to smoothly zero out the SKEBS velocity increment near land
- real 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
@@ -119,7 +119,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time)
! get number of processors and PE list for stochastic physics initialization
call get_param(param_file, mdl, "DO_SPPT", CS%do_sppt, &
"If true, then stochastically perturb the thermodynamic "//&
- "tendencies of T,S, amd h. Amplitude and correlations are "//&
+ "tendencies of T,S, and h. Amplitude and correlations are "//&
"controlled by the nam_stoch namelist in the UFS model only.", &
default=.false.)
call get_param(param_file, mdl, "DO_SKEB", CS%do_skeb, &
@@ -204,8 +204,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_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90
index f0362ee0e7..0d3a148458 100644
--- a/src/parameterizations/vertical/MOM_ALE_sponge.F90
+++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the routines used to apply sponge layers when using
!! the ALE mode.
!!
@@ -11,7 +15,6 @@
module MOM_ALE_sponge
-! This file is part of MOM6. See LICENSE.md for the license.
use MOM_array_transform, only: rotate_array
use MOM_coms, only : sum_across_PEs
use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field
@@ -142,8 +145,9 @@ module MOM_ALE_sponge
!! It is not clear why this needs to be greater than 0.
!>@{ Diagnostic IDs
- integer, dimension(MAX_FIELDS_) :: id_sp_tendency !< Diagnostic ids for tracer
- !! tendencies due to sponges
+ integer, dimension(MAX_FIELDS_) :: id_sp_tendency = reshape([-1], [MAX_FIELDS_], [-1]) !< Diagnostic ids for tracer
+ !! tendencies due to sponges.
+ !! Init all to -1.
integer :: id_sp_u_tendency !< Diagnostic id for zonal momentum tendency due to
!! Rayleigh damping
integer :: id_sp_v_tendency !< Diagnostic id for meridional momentum tendency due to
@@ -188,7 +192,6 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h,
# include "version_variable.h"
character(len=64) :: remapScheme
logical :: use_sponge
- logical :: data_h_to_Z
logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries
integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags.
logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm
@@ -671,7 +674,6 @@ subroutine init_ALE_sponge_diags(Time, G, diag, CS, US)
CS%diag => diag
do m=1,CS%fldno
- CS%id_sp_tendency(m) = -1
if ((trim(CS%Ref_val(m)%unit) == 'none') .or. (len_trim(CS%Ref_val(m)%unit) == 0)) then
tend_unit = "s-1"
else
@@ -729,7 +731,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS, &
CS%fldno = CS%fldno + 1
if (CS%fldno > MAX_FIELDS_) then
- write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease &
+ write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease &
&the number of fields to be damped in the call to &
&initialize_ALE_sponge." )') CS%fldno
call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg)
@@ -795,7 +797,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US,
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
CS%fldno = CS%fldno + 1
if (CS%fldno > MAX_FIELDS_) then
- write(mesg, '("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease "//&
+ write(mesg, '("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease "//&
&"the number of fields to be damped in the call to initialize_ALE_sponge." )') CS%fldno
call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg)
endif
diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90
index 8e42694b36..5e6c05dd42 100644
--- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90
+++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides the K-Profile Parameterization (KPP) of Large et al., 1994, via CVMix.
module MOM_CVMix_KPP
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : max_across_PEs
use MOM_debugging, only : hchksum, is_NaN
use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data
@@ -419,10 +421,10 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive)
!/BGR: New options for including Langmuir effects
!/ 1. Options related to enhancing the mixing coefficient
call get_param(paramFile, mdl, "USE_KPP_LT_K", CS%LT_K_Enhancement, &
- 'Flag for Langmuir turbulence enhancement of turbulent'//&
+ 'Flag for Langmuir turbulence enhancement of turbulent '//&
'mixing coefficient.', Default=.false.)
call get_param(paramFile, mdl, "STOKES_MIXING", CS%Stokes_Mixing, &
- 'Flag for Langmuir turbulence enhancement of turbulent'//&
+ 'Flag for Langmuir turbulence enhancement of turbulent '//&
'mixing coefficient.', Default=.false.)
if (CS%LT_K_Enhancement) then
call get_param(paramFile, mdl, 'KPP_LT_K_SHAPE', string, &
@@ -469,7 +471,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive)
endif
!/ 2. Options related to enhancing the unresolved Vt2/entrainment in Rib
call get_param(paramFile, mdl, "USE_KPP_LT_VT2", CS%LT_Vt2_Enhancement, &
- 'Flag for Langmuir turbulence enhancement of Vt2'//&
+ 'Flag for Langmuir turbulence enhancement of Vt2 '//&
'in Bulk Richardson Number.', Default=.false.)
if (CS%LT_Vt2_Enhancement) then
call get_param(paramFile, mdl, "KPP_LT_VT2_METHOD",string , &
@@ -523,7 +525,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive)
"The vintage of the order of arithmetic in the CVMix KPP calculations. Values "//&
"below 20240501 recover the answers from early in 2024, while higher values "//&
"use expressions that have been refactored for rotational symmetry.", &
- default=20240101) !### Change to: default=default_answer_date)
+ default=default_answer_date)
call closeParameterBlock(paramFile)
@@ -565,11 +567,11 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive)
cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', &
cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme')
endif
- if( CS%StokesMOST ) then
- CS%id_StokesXI = register_diag_field('ocean_model', 'StokesXI', diag%axesT1, Time, &
- 'Stokes Similarity Parameter', 'nondim')
- CS%id_Lam2 = register_diag_field('ocean_model', 'Lam2', diag%axesT1, Time, &
- 'Ustk0_ustar', 'nondim')
+ if ( CS%StokesMOST ) then
+ CS%id_StokesXI = register_diag_field('ocean_model', 'StokesXI', diag%axesT1, Time, &
+ 'Stokes Similarity Parameter', 'nondim')
+ CS%id_Lam2 = register_diag_field('ocean_model', 'Lam2', diag%axesT1, Time, &
+ 'Ustk0_ustar', 'nondim')
endif
CS%id_BulkDrho = register_diag_field('ocean_model', 'KPP_BulkDrho', diag%axesTL, Time, &
'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', &
@@ -876,7 +878,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, &
call MOM_error(FATAL,"KPP_calculate, after CVMix_coeffs_kpp: "// &
"Negative vertical viscosity or diffusivity has been detected. " // &
- "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2." //&
+ "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2. " //&
"You might consider using the default options for these parameters." )
endif
enddo
@@ -1076,7 +1078,6 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl
! [L T-1 ~> m s-1]
real :: StokesXI ! Stokes similarity parameter [nondim]
real, dimension( GV%ke ) :: StokesXI_1d , StokesVt_1d ! Parameters of TKE production ratio [nondim]
- real :: Llimit ! Stable boundary Layer Limit = vonk Lstar [Z ~> m]
integer :: kbl ! index of cell containing boundary layer depth
if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, &
diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90
index 74a0305ce1..4a3cb49824 100644
--- a/src/parameterizations/vertical/MOM_CVMix_conv.F90
+++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interface to CVMix convection scheme.
module MOM_CVMix_conv
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum
use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field
use MOM_diag_mediator, only : post_data
@@ -85,7 +87,7 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS)
! be aplied in the boundary layer
if (useEPBL) then
call MOM_error(WARNING, 'MOM_CVMix_conv_init: '// &
- 'CVMix convection may not be properly applied when ENERGETICS_SFC_PBL = True'//&
+ 'CVMix convection may not be properly applied when ENERGETICS_SFC_PBL = True '//&
'as convective mixing might occur in the boundary layer.')
endif
diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90
index 173ab7a36d..0c3ecaee3f 100644
--- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90
+++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interface to CVMix double diffusion scheme.
module MOM_CVMix_ddiff
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field
use MOM_diag_mediator, only : post_data
use MOM_EOS, only : calculate_density_derivs
@@ -181,16 +183,16 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho)
integer :: i, k
! initialize dummy variables
- pres_int(:) = 0.0; temp_int(:) = 0.0; salt_int(:) = 0.0
- alpha_dT(:) = 0.0; beta_dS(:) = 0.0; dRho_dT(:) = 0.0
- dRho_dS(:) = 0.0; dT(:) = 0.0; dS(:) = 0.0
+ pres_int(:) = 0.0 ; temp_int(:) = 0.0 ; salt_int(:) = 0.0
+ alpha_dT(:) = 0.0 ; beta_dS(:) = 0.0 ; dRho_dT(:) = 0.0
+ dRho_dS(:) = 0.0 ; dT(:) = 0.0 ; dS(:) = 0.0
! GMM, I am leaving some code commented below. We need to pass BLD to
! this subroutine to avoid adding diffusivity above that. This needs
! to be done once we re-structure the order of the calls.
!if (.not. associated(hbl)) then
- ! allocate(hbl(SZI_(G), SZJ_(G)));
+ ! allocate(hbl(SZI_(G), SZJ_(G)))
! hbl(:,:) = 0.0
!endif
@@ -201,7 +203,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho)
pres_int(1) = 0. ; if (associated(tv%p_surf)) pres_int(1) = tv%p_surf(i,j)
! we don't have SST and SSS, so let's use values at top-most layer
- temp_int(1) = tv%T(i,j,1); salt_int(1) = tv%S(i,j,1)
+ temp_int(1) = tv%T(i,j,1) ; salt_int(1) = tv%S(i,j,1)
do K=2,GV%ke
! pressure at interface
pres_int(K) = pres_int(K-1) + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k-1)
diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90
index 36d92616b3..bd6dd287bd 100644
--- a/src/parameterizations/vertical/MOM_CVMix_shear.F90
+++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interface to CVMix interior shear schemes
module MOM_CVMix_shear
-! This file is part of MOM6. See LICENSE.md for the license.
-
!> \author Brandon Reichl
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
@@ -266,8 +268,8 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS)
! Otherwise, warn user and kill job.
if ((NumberTrue) > 1) then
call MOM_error(FATAL, 'MOM_CVMix_shear_init: '// &
- 'Multiple shear driven internal mixing schemes selected,'//&
- ' please disable all but one scheme to proceed.')
+ 'Multiple shear driven internal mixing schemes selected, '//&
+ 'please disable all but one scheme to proceed.')
endif
CVMix_shear_init = use_PP81 .or. use_LMD94
diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90
index b42bd3a8ad..5b41cef038 100644
--- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90
+++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interface to background mixing schemes, including the Bryan and Lewis (1979)
!! which is applied via CVMix.
module MOM_bkgnd_mixing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : hchksum
use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field
use MOM_diag_mediator, only : post_data
@@ -85,9 +87,6 @@ module MOM_bkgnd_mixing
!! here is to assume that the in-situ stratification is the same as the reference stratificaiton.
logical :: physical_OBL_scheme !< If true, a physically-based scheme is used to determine mixing in the
!! ocean's surface boundary layer, such as ePBL, KPP, or a refined bulk mixed layer scheme.
- logical :: Kd_via_Kdml_bug !< If true and KDML /= KD and a number of other higher precedence
- !! options are not used, the background diffusivity is set incorrectly using a
- !! bug that was introduced in March, 2018.
logical :: debug !< If true, turn on debugging in this module
! Diagnostic handles and pointers
type(diag_ctrl), pointer :: diag => NULL() !< A structure that regulates diagnostic output
@@ -305,16 +304,6 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL
if (CS%Henyey_IGW_background .and. CS%Kd_tanh_lat_fn) call MOM_error(FATAL, &
"MOM_bkgnd_mixing: KD_TANH_LAT_FN can not be used with HENYEY_IGW_BACKGROUND.")
- CS%Kd_via_Kdml_bug = .false.
- if ((CS%Kd /= CS%Kd_tot_ml) .and. .not.(CS%Kd_tanh_lat_fn .or. CS%physical_OBL_scheme .or. &
- CS%Henyey_IGW_background .or. &
- CS%horiz_varying_background .or. CS%Bryan_Lewis_diffusivity)) then
- call get_param(param_file, mdl, "KD_BACKGROUND_VIA_KDML_BUG", CS%Kd_via_Kdml_bug, &
- "If true and KDML /= KD and several other conditions apply, the background "//&
- "diffusivity is set incorrectly using a bug that was introduced in March, 2018.", &
- default=.false.) ! This parameter should be obsoleted.
- endif
-
! call closeParameterBlock(param_file)
end subroutine bkgnd_mixing_init
@@ -348,9 +337,6 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G,
real, dimension(SZI_(G),SZK_(GV)) :: dz !< Height change across layers [Z ~> m]
real :: depth_c !< depth of the center of a layer [H ~> m or kg m-2]
real :: I_Hmix !< inverse of fixed mixed layer thickness [H-1 ~> m-1 or m2 kg-1]
- real :: I_2Omega !< 1/(2 Omega) [T ~> s]
- real :: N_2Omega ! The ratio of the stratification to the Earth's rotation rate [nondim]
- real :: N02_N2 ! The ratio a reference stratification to the actual stratification [nondim]
real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) [nondim]
real :: deg_to_rad !< factor converting degrees to radians [radians degree-1], pi/180.
real :: abs_sinlat !< absolute value of sine of latitude [nondim]
@@ -479,20 +465,10 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G,
do i=is,ie ; depth(i) = 0.0 ; enddo
do k=1,nz ; do i=is,ie
depth_c = depth(i) + 0.5*h(i,j,k)
- if (CS%Kd_via_Kdml_bug) then
- ! These two lines should update Kd_lay, not Kd_int. They were correctly working on the
- ! same variables until MOM6 commit 7a818716 (PR#750), which was added on March 26, 2018.
- if (depth_c <= CS%Hmix) then ; Kd_int(i,K) = CS%Kd_tot_ml
- elseif (depth_c >= 2.0*CS%Hmix) then ; Kd_int(i,K) = Kd_sfc(i)
- else
- Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kd_tot_ml) * I_Hmix) * depth_c + (2.0*CS%Kd_tot_ml - Kd_sfc(i))
- endif
+ if (depth_c <= CS%Hmix) then ; Kd_lay(i,k) = CS%Kd_tot_ml
+ elseif (depth_c >= 2.0*CS%Hmix) then ; Kd_lay(i,k) = Kd_sfc(i)
else
- if (depth_c <= CS%Hmix) then ; Kd_lay(i,k) = CS%Kd_tot_ml
- elseif (depth_c >= 2.0*CS%Hmix) then ; Kd_lay(i,k) = Kd_sfc(i)
- else
- Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kd_tot_ml) * I_Hmix) * depth_c + (2.0*CS%Kd_tot_ml - Kd_sfc(i))
- endif
+ Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kd_tot_ml) * I_Hmix) * depth_c + (2.0*CS%Kd_tot_ml - Kd_sfc(i))
endif
depth(i) = depth(i) + h(i,j,k)
@@ -506,8 +482,8 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G,
! Update Kd_int and Kv_bkgnd, based on Kd_lay. These might be just used for diagnostic purposes.
do i=is,ie
- Kd_int(i,1) = 0.0; Kv_bkgnd(i,1) = 0.0
- Kd_int(i,nz+1) = 0.0; Kv_bkgnd(i,nz+1) = 0.0
+ Kd_int(i,1) = 0.0 ; Kv_bkgnd(i,1) = 0.0
+ Kd_int(i,nz+1) = 0.0 ; Kv_bkgnd(i,nz+1) = 0.0
enddo
do K=2,nz ; do i=is,ie
Kd_int(i,K) = 0.5*(Kd_lay(i,k-1) + Kd_lay(i,k))
diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90
index 690688dc1e..16fbc24b1f 100644
--- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90
+++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Build mixed layer parameterization
module MOM_bulk_mixed_layer
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc
use MOM_diag_mediator, only : time_type, diag_ctrl, diag_update_remap_grids
@@ -278,7 +280,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C
! over a time step from evaporating fresh water [H ~> m or kg m-2]
Net_heat, & ! The net heating at the surface over a time step [C H ~> degC m or degC kg m-2]
! Any penetrating shortwave radiation is not included in Net_heat.
- Net_salt, & ! The surface salt flux into the ocean over a time step [S H ~> ppt m or ppt kg m-2]
+ Net_salt, & ! The surface salt flux into the ocean over a time step [S H ~> ppt m or ppt kg m-2]
Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1].
p_ref, & ! Reference pressure for the potential density governing mixed
! layer dynamics, almost always 0 (or 1e5) [R L2 T-2 ~> Pa].
@@ -773,7 +775,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C
! Copy the interior thicknesses and other fields back to the 3-d arrays.
do k=CS%nkml+1,nz ; do i=is,ie
- h_3d(i,j,k) = h(i,k); tv%T(i,j,k) = T(i,k) ; tv%S(i,j,k) = S(i,k)
+ h_3d(i,j,k) = h(i,k) ; tv%T(i,j,k) = T(i,k) ; tv%S(i,j,k) = S(i,k)
enddo ; enddo
do k=1,nz ; do i=is,ie
@@ -1118,7 +1120,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, &
real :: T_precip ! The temperature of the precipitation [C ~> degC].
real :: C1_3, C1_6 ! 1/3 and 1/6 [nondim]
real :: En_fn, Frac, x1 ! Nondimensional temporary variables [nondim].
- real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5] or [R-1 H ~> m4 kg-1 or m].
+ real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5] or [H R-1 ~> m4 kg-1 or m].
real :: dr_ent, dr_comp ! Temporary variables [R H ~> kg m-2 or kg2 m-5].
real :: dr_dh ! The partial derivative of dr_ent with h_ent [R ~> kg m-3].
real :: h_min, h_max ! The minimum and maximum estimates for h_ent [H ~> m or kg m-2]
@@ -2640,7 +2642,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_e
integer :: i, k, k0, k1, is, ie, nz, kb1, kb2, nkmb
is = G%isc ; ie = G%iec ; nz = GV%ke
- kb1 = CS%nkml+1; kb2 = CS%nkml+2
+ kb1 = CS%nkml+1 ; kb2 = CS%nkml+2
nkmb = CS%nkml+CS%nkbl
h_neglect = GV%H_subroundoff
g_2 = 0.5 * GV%g_Earth_Z_T2
@@ -2654,7 +2656,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_e
dT_dS_gauge = CS%dT_dS_wt ; dS_dT_gauge = 1.0 / dT_dS_gauge
num_events = 10.0
- if (CS%nkbl /= 2) call MOM_error(FATAL, "MOM_mixed_layer"// &
+ if (CS%nkbl /= 2) call MOM_error(FATAL, "MOM_mixed_layer: "// &
"CS%nkbl must be 2 in mixedlayer_detrain_2.")
if (dt < CS%BL_detrain_time) then ; dPE_time_ratio = CS%BL_detrain_time / (dt)
@@ -3326,7 +3328,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_e
h1_to_h2 = stays_merge - stays
Ihk0 = 1.0 / ((h1_to_k0 + h2) + h(i,k0))
- Ih1f = 1.0 / (h_to_bl + stays); Ih2f = 1.0 / h1_to_h2
+ Ih1f = 1.0 / (h_to_bl + stays) ; Ih2f = 1.0 / h1_to_h2
Ih12 = 1.0 / (h1 + h2)
dRcv_2dz = (Rcv(i,kb1) - Rcv(i,kb2)) * Ih12
diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90
index b6d4dfa489..f5bfe342ad 100644
--- a/src/parameterizations/vertical/MOM_diabatic_aux.F90
+++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90
@@ -1,9 +1,11 @@
-!> Provides functions for some diabatic processes such as fraxil, brine rejection,
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+!> Provides functions for some diabatic processes such as frazil, brine rejection,
!! tendency due to surface flux divergence.
module MOM_diabatic_aux
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
@@ -120,7 +122,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 +224,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
@@ -538,11 +542,11 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix)
"in call to find_uv_at_h.")
zero_mixing = .false. ; if (present(zero_mix)) zero_mixing = zero_mix
if (zero_mixing) mix_vertically = .false.
- !$OMP parallel do default(none) shared(is,ie,js,je,G,GV,mix_vertically,zero_mixing,h, &
- !$OMP h_neglect,ea,eb,u_h,u,v_h,v,nz) &
- !$OMP private(sum_area,Idenom,a_w,a_e,a_s,a_n,b_denom_1,b1,d1,c1)
+ !$omp target enter data map(alloc: a_w,a_e,a_s,a_n,b1,d1,c1)
+ !$omp target teams loop private(sum_area,Idenom,a_w,a_e,a_s,a_n,b_denom_1,b1,d1,c1) &
+ !$omp map(to: ea, eb, h) map(from: u_h, v_h)
do j=js,je
- do i=is,ie
+ do concurrent (i=is:ie)
sum_area = G%areaCu(I-1,j) + G%areaCu(I,j)
if (sum_area > 0.0) then
! If this were a simple area weighted average, this would just be I_denom = 1.0 / sum_area.
@@ -569,14 +573,14 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix)
enddo
if (mix_vertically) then
- do i=is,ie
+ do concurrent (i=is:ie)
b_denom_1 = h(i,j,1) + h_neglect
b1(i) = 1.0 / (b_denom_1 + eb(i,j,1))
d1(i) = b_denom_1 * b1(i)
u_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_e(i)*u(I,j,1)) + (a_w(i)*u(I-1,j,1)))
v_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_n(i)*v(i,J,1)) + (a_s(i)*v(i,J-1,1)))
enddo
- do k=2,nz ; do i=is,ie
+ do k=2,nz ; do concurrent (i=is:ie)
c1(i,k) = eb(i,j,k-1) * b1(i)
b_denom_1 = h(i,j,k) + d1(i)*ea(i,j,k) + h_neglect
b1(i) = 1.0 / (b_denom_1 + eb(i,j,k))
@@ -586,28 +590,29 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix)
v_h(i,j,k) = (h(i,j,k) * ((a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k))) + &
ea(i,j,k)*v_h(i,j,k-1))*b1(i)
enddo ; enddo
- do k=nz-1,1,-1 ; do i=is,ie
+ do k=nz-1,1,-1 ; do concurrent (i=is:ie)
u_h(i,j,k) = u_h(i,j,k) + c1(i,k+1)*u_h(i,j,k+1)
v_h(i,j,k) = v_h(i,j,k) + c1(i,k+1)*v_h(i,j,k+1)
enddo ; enddo
elseif (zero_mixing) then
- do i=is,ie
+ do concurrent (i=is:ie)
b1(i) = 1.0 / (h(i,j,1) + h_neglect)
u_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_e(i)*u(I,j,1)) + (a_w(i)*u(I-1,j,1)))
v_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_n(i)*v(i,J,1)) + (a_s(i)*v(i,J-1,1)))
enddo
- do k=2,nz ; do i=is,ie
+ do concurrent (k=2:nz, i=is:ie)
b1(i) = 1.0 / (h(i,j,k) + h_neglect)
u_h(i,j,k) = (h(i,j,k) * ((a_e(i)*u(I,j,k)) + (a_w(i)*u(I-1,j,k)))) * b1(i)
v_h(i,j,k) = (h(i,j,k) * ((a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k)))) * b1(i)
- enddo ; enddo
+ enddo
else
- do k=1,nz ; do i=is,ie
+ do concurrent (k=1:nz, i=is:ie)
u_h(i,j,k) = (a_e(i)*u(I,j,k)) + (a_w(i)*u(I-1,j,k))
v_h(i,j,k) = (a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k))
- enddo ; enddo
+ enddo
endif
enddo
+ !$omp target exit data map(release: a_w,a_e,a_s,a_n,b1,d1,c1)
call cpu_clock_end(id_clock_uv_at_h)
end subroutine find_uv_at_h
@@ -646,7 +651,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow
do j=js,je ; do i=is,ie
if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then
write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",&
- & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') &
+ & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') &
chl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j)
call MOM_error(FATAL, "MOM_diabatic_aux set_pen_shortwave: "//trim(mesg))
endif
@@ -1335,7 +1340,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t
enddo
if (numberOfGroundings - maxGroundings > 0) then
- write(mesg, '(i4)') numberOfGroundings - maxGroundings
+ write(mesg, '(I0)') numberOfGroundings - maxGroundings
call MOM_error(WARNING, "MOM_diabatic_aux:F90, applyBoundaryFluxesInOut(): "//&
trim(mesg) // " groundings remaining")
endif
diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90
index 4051f9e706..9165d08ed1 100644
--- a/src/parameterizations/vertical/MOM_diabatic_driver.F90
+++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This routine drives the diabatic/dianeutral physics for MOM
module MOM_diabatic_driver
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_bulk_mixed_layer, only : bulkmixedlayer, bulkmixedlayer_init, bulkmixedlayer_CS
use MOM_debugging, only : hchksum
use MOM_checksum_packages, only : MOM_state_chksum, MOM_state_stats
@@ -178,6 +180,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 +198,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
@@ -305,7 +311,7 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, &
real, dimension(SZI_(G),SZK_(GV)) :: &
pressure ! The pressure at the middle of each layer [R L2 T-2 ~> Pa].
real :: H_to_RL2_T2 ! A conversion factor from thicknesses in H to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]
- integer :: i, j, k, m, is, ie, js, je, nz
+ integer :: i, j, k, is, ie, js, je, nz
logical :: showCallTree ! If true, show the call tree
real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics [H ~> m or kg m-2]
@@ -337,7 +343,10 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, &
if (CS%id_T_predia > 0) call post_data(CS%id_T_predia, tv%T, CS%diag)
if (CS%id_S_predia > 0) call post_data(CS%id_S_predia, tv%S, CS%diag)
if (CS%id_e_predia > 0) then
+ !$omp target update to(h)
+ !$omp target enter data map(alloc: eta)
call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref)
+ !$omp target exit data map(from: eta)
call post_data(CS%id_e_predia, eta, CS%diag)
endif
@@ -366,7 +375,7 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, &
! the end of the diabatic processes.
if (associated(tv%T) .AND. associated(tv%frazil)) then
! For frazil diagnostic, the first call covers the first half of the time step
- call enable_averages(0.5*dt, Time_end - real_to_time(0.5*US%T_to_s*dt), CS%diag)
+ call enable_averages(0.5*dt, Time_end - real_to_time(0.5*dt, unscale=US%T_to_s), CS%diag)
if (CS%frazil_tendency_diag) then
do k=1,nz ; do j=js,je ; do i=is,ie
temp_diag(i,j,k) = tv%T(i,j,k)
@@ -453,10 +462,10 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, &
if (stoch_CS%do_sppt) then
! perturb diabatic tendencies.
! These stochastic perturbations do not conserve heat, salt or mass.
- do k=1,nz; do j=js,je; do i=is,ie
+ do k=1,nz ; do j=js,je ; do i=is,ie
h(i,j,k) = max(h_in(i,j,k) + (h(i,j,k)-h_in(i,j,k)) * stoch_CS%sppt_wts(i,j), GV%Angstrom_H)
tv%S(i,j,k) = max(s_in(i,j,k) + (tv%S(i,j,k)-s_in(i,j,k)) * stoch_CS%sppt_wts(i,j), 0.0)
- enddo; enddo; enddo
+ enddo ; enddo ; enddo
! now that we have updated thickness and salinity, calculate freeing point
H_to_RL2_T2 = GV%H_to_RZ * GV%g_Earth
do j=js,je
@@ -502,10 +511,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,11 +594,11 @@ 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]
- d_pres, & ! pressure change across a layer [R L2 T-2 ~> Pa]
T_i, & ! Temperature at the interface [C ~> degC]
S_i, & ! Salinity at the interface [S ~> ppt]
drhodS, & ! Local change in density w.r.t. salinity using model EOS & state [R C-1 ~> kg m-3 ppt-1]
@@ -644,7 +658,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 +910,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 +1306,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
@@ -1301,7 +1316,6 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end,
real, dimension(SZI_(G)) :: &
p_i ,& ! Pressure at the interface [R L2 T-2 ~> Pa]
- d_pres, & ! pressure change across a layer [R L2 T-2 ~> Pa]
T_i, & ! Temperature at the interface [C ~> degC]
S_i, & ! Salinity at the interface [S ~> ppt]
drhodS, & ! Local change in density w.r.t. salinity using model EOS & state [R C-1 ~> kg m-3 ppt-1]
@@ -1359,7 +1373,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 +1561,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 +2942,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 +2991,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 +3035,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 +3085,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)
@@ -3234,10 +3244,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di
# include "version_variable.h"
character(len=40) :: mdl = "MOM_diabatic_driver" ! This module's name.
character(len=48) :: thickness_units
- character(len=40) :: var_name
- character(len=160) :: var_descript
logical :: physical_OBL_scheme
- integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands, m
+ integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
@@ -3478,6 +3486,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 +3618,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 +3646,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 +3694,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 +3714,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_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90
index d197a7a8f1..a7d4bd71d8 100644
--- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90
+++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Calculates the energy requirements of mixing.
module MOM_diapyc_energy_req
-! This file is part of MOM6. See LICENSE.md for the license.
-
!! \author By Robert Hallberg, May 2015
use MOM_diag_mediator, only : diag_ctrl, Time_type, post_data, register_diag_field
diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90
index c94e1032fe..6930007bd1 100644
--- a/src/parameterizations/vertical/MOM_energetic_PBL.F90
+++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90
@@ -1,12 +1,15 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Energetically consistent planetary boundary layer parameterization
module MOM_energetic_PBL
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE
use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs
use MOM_debugging, only : hchksum
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc
+use MOM_diag_mediator, only : post_data_3d_by_column, post_data_3d_final
use MOM_diag_mediator, only : time_type, diag_ctrl
use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type
use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg
@@ -105,8 +108,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 +118,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 +151,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 +225,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
@@ -238,28 +264,30 @@ module MOM_energetic_PBL
type(EFP_type), dimension(2) :: sum_its_BBL !< The total number of iterations and columns worked on
!>@{ Diagnostic IDs
+ integer :: id_Kd_ePBL_col_by_col = -1
integer :: id_ML_depth = -1, id_hML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1
+ integer :: id_ustar_ePBL = -1, id_bflx_ePBL = -1
integer :: id_TKE_MKE = -1, id_TKE_conv = -1, id_TKE_forcing = -1
integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1
integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1
integer :: id_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 +315,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 +328,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 +366,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 +385,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 +439,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]
@@ -430,7 +462,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV,
BBL_Vel_Scale, & ! The velocity scale used in getting the BBL part of Kd [Z T-1 ~> m s-1]
BBL_Mix_Length ! The length scale used in getting the BBL part of Kd [Z ~> m]
real, dimension(SZI_(G),SZJ_(G)) :: &
- ! The next 7 diagnostics are terms in the mixed layer TKE budget, all in [R Z3 T-3 ~> W m-2 = kg s-3].
+ ! The next 7 diagnostics are terms in the mixed layer TKE budget, all in [R Z3 T-3 ~> W m-2].
diag_TKE_wind, & ! The wind source of TKE [R Z3 T-3 ~> W m-2]
diag_TKE_MKE, & ! The resolved KE source of TKE [R Z3 T-3 ~> W m-2]
diag_TKE_conv, & ! The convective source of TKE [R Z3 T-3 ~> W m-2]
@@ -444,11 +476,12 @@ 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]
! The following variables are only used for diagnosing sensitivities to ePBL settings
real, dimension(SZK_(GV)+1) :: &
@@ -495,7 +528,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 +645,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
@@ -660,25 +694,37 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV,
u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, &
US, CS, eCD, Waves, G, i, j)
endif
+ if (CS%id_Kd_ePBL_col_by_col > 0) &
+ call post_data_3d_by_column(CS%id_Kd_ePBL_col_by_col, Kd, CS%diag, i, j)
! Add the diffusivity due to bottom boundary layer mixing, if there is energy to drive this mixing.
if (BBL_mixing) then
if (CS%MLD_iteration_guess .and. (CS%BBL_depth(i,j) > 0.0)) BBLD_io = CS%BBL_depth(i,j)
BBLD_in = BBLD_io
- 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 +769,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 +802,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
@@ -781,6 +831,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV,
do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = Kd_2d(i,K) ; enddo ; enddo
enddo ! j-loop
+ if (CS%id_Kd_ePBL_col_by_col > 0) call post_data_3d_final(CS%id_Kd_ePBL_col_by_col, CS%diag)
if (CS%debug .and. BBL_mixing) then
call hchksum(visc%BBL_meanKE_loss, "ePBL visc%BBL_meanKE_loss", G%HI, &
@@ -794,6 +845,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 +859,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 +870,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)
@@ -980,7 +1034,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing,
real :: dz_neglect ! A vertical distance that is so small it is usually lost
! in roundoff and can be neglected [Z ~> m].
real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2].
- real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa = J m-3].
+ real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa] or
+ ! equivalently [R Z2 T-2 ~> J m-3].
real :: dMKE_max ! The maximum amount of mean kinetic energy that could be
! converted to turbulent kinetic energy if the velocity in
! the layer below an interface were homogenized with all of
@@ -1104,12 +1159,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 +1249,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 +1314,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 +1554,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 +1629,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 +1897,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 +1960,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 +1991,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].
@@ -1998,8 +2075,6 @@ subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, &
c1, & ! c1 is used by the tridiagonal solver [nondim].
Te, & ! Estimated final values of T in the column [C ~> degC].
Se, & ! Estimated final values of S in the column [S ~> ppt].
- dTe, & ! Running (1-way) estimates of temperature change [C ~> degC].
- dSe, & ! Running (1-way) estimates of salinity change [S ~> ppt].
hp_a, & ! An effective pivot thickness of the layer including the effects
! of coupling with layers above [H ~> m or kg m-2]. This is the first term
! in the denominator of b1 in a downward-oriented tridiagonal solver.
@@ -2028,8 +2103,8 @@ subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, &
real :: dz_neglect ! A vertical distance that is so small it is usually lost
! in roundoff and can be neglected [Z ~> m].
real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2].
- real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa = J m-3].
-
+ real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa] or
+ ! equivalently [R Z2 T-2 ~> J m-3].
real :: dt_h ! The timestep divided by the averages of the vertical distances around
! a layer [T Z-1 ~> s m-1].
real :: dz_top ! The distance from the surface [Z ~> m].
@@ -2086,12 +2161,12 @@ subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, &
real :: min_BBLD, max_BBLD ! Iteration bounds on BBLD [Z ~> m], which are adjusted at each step
real :: dBBLD_min ! The change in diagnosed mixed layer depth when the guess is min_BLD [Z ~> m]
real :: dBBLD_max ! The change in diagnosed mixed layer depth when the guess is max_BLD [Z ~> m]
- logical :: BBL_converged ! Flag for convergence of BBLD
integer :: BBL_it ! Iteration counter
real :: Surface_Scale ! Surface decay scale for vstar [nondim]
logical :: debug ! This is used as a hard-coded value for debugging.
logical :: no_MKE_conversion ! If true, there is conversion of MKE to TKE in this routine.
+ 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 +2190,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 +2308,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 +2749,255 @@ 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 :: hz_n ! z depth to avoid calling hz multiple times [Z ~> m]
+ real :: z_minus_sm_h ! depth z minus \sigma_m * MLD_Guess [Z ~> m]
+ real :: z_minus_sm_h2 ! (depth z minus \sigma_m * MLD_Guess)^2 [Z2 ~> m2]
+ real :: z_minus_sm_h3 ! (depth z minus \sigma_m * MLD_Guess)^3 [Z3 ~> m3]
+ real :: h_minus_smh_I ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) [Z-1 ~> m-1]
+ real :: h_minus_smh_I2 ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) ^ 2 [Z-2 ~> m-2]
+ real :: h_minus_smh_I3 ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) ^ 3 [Z-3 ~> m-3]
+ real :: z_sm_h_I ! depth divided by (\sigma_m * MLD_Guess) [nondim]
+ real :: coef_c2 ! = 2.98 * h_minus_smh_I2 ! [Z-2 ~> m-2]
+ real :: coef_c3 ! = 2.98 * h_minus_smh_I2 ! [Z-3 ~> m-3]
+
+ nz = SZK_(GV)+1
+ hz(1) = 0.0
+ do K=2,nz
+ hz(K) = hz(K-1) + dz(K-1)
+ enddo
+ hbl = MLD_Guess ! hbl is boundary layer depth.
+
+ u_star_I = 1.0/u_star
+ Lh = (-B_flux * hbl) * ((u_star_I * u_star_I) * u_star_I) ! Boundary layer depth divided by Monin-Obukhov depth
+ Eh = (hbl * absf) * u_star_I ! Boundary layer depth divided by Ekman depth
+
+ ! B_flux given negative sign to follow convention used in Sane et al. 2023
+ ! Lh < 0 --> surface stabilizing i.e. heating, and Lh > 0 --> surface destabilizing i.e. cooling
+ ! This capping does not matter because these equations have asymptotes. Not sensitive beyond the caps.
+ Eh = min(Eh, CS%Eh_upper_cap) ! capping p1 to less than 2.0. It is always >0.0.
+ Lh = min(max(Lh, -CS%Lh_cap), CS%Lh_cap) ! capping Lh between -8 and 8
+
+ ! Empirical model to predict sm:
+ ! F is Equation (6) in Sane et al. 2025, and needs to be computed before sigma_m:
+ ! \mathcal{F} = \frac{1}{c_3 + c_4 \cdot e^{-\left( \text{sgn}(B) \cdot {c_5} \cdot {{L_h}^3} \right)}} + c_6
+ ! Equation (5) in Sane et al. 2025:
+ ! \sigma_{m} = \frac{1}{c_1 + \frac{c_2}{\mathcal{F} \cdot E_h}}
+ ! Note: Lh over here is ((Bh)/ustar^3), whereas in Sane et al. 2025, L_h = (((Bh)^{1/3})/(ustar))
+
+ F = (1.0/ ( CS%ML_c(3) + CS%ML_c(4) * exp(-CS%ML_c(5) * Lh) ) ) + CS%ML_c(6)
+ F_Eh = F * Eh
+ sm = F_Eh / (CS%ML_c(1)*F_Eh +CS%ML_c(2))
+ sm = min(max(sm, CS%sigma_max_lower_cap), CS%sigma_max_upper_cap) ! makes sure 0.1 hbl) then
+ shape_func(n) = CS%shape_function_epsilon ! set an arbitrary low constant value below hbl, default 0.01
+ endif
+ enddo
+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 +3518,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 +3652,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 +3686,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 +3743,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 +3829,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 +3839,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 +3988,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 +4161,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 +4198,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 "//&
@@ -3888,12 +4337,18 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS)
!/ Checking output flags
+ CS%id_Kd_ePBL_col_by_col = register_diag_field('ocean_model', 'Kd_ePBL_col_by_col', diag%axesTi, Time, &
+ 'ePBL diapycnal diffusivity at interfaces posted column by column', 'm2 s-1', conversion=GV%HZ_T_to_m2_s)
CS%id_ML_depth = register_diag_field('ocean_model', 'ePBL_h_ML', diag%axesT1, &
Time, 'Surface boundary layer depth', units='m', conversion=US%Z_to_m, &
cmor_long_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme')
! This is an alias for the same variable as ePBL_h_ML
CS%id_hML_depth = register_diag_field('ocean_model', 'h_ML', diag%axesT1, &
Time, 'Surface mixed layer depth based on active turbulence', 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 +4368,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 +4391,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 +4423,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 +4449,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_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90
index 5141176d08..4f5ae31f0c 100644
--- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90
+++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Diapycnal mixing and advection in isopycnal mode
module MOM_entrain_diffusive
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
use MOM_diag_mediator, only : diag_ctrl, time_type
use MOM_EOS, only : calculate_density, calculate_density_derivs
diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90
index a5fba3adc6..bcf715a204 100644
--- a/src/parameterizations/vertical/MOM_full_convection.F90
+++ b/src/parameterizations/vertical/MOM_full_convection.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Does full convective adjustment of unstable regions via a strong diffusivity.
module MOM_full_convection
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_grid, only : ocean_grid_type
use MOM_interface_heights, only : thickness_to_dz
use MOM_unit_scaling, only : unit_scale_type
diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90
index 3769721da1..93c429198d 100644
--- a/src/parameterizations/vertical/MOM_geothermal.F90
+++ b/src/parameterizations/vertical/MOM_geothermal.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Implemented geothermal heating at the ocean bottom.
module MOM_geothermal
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc
use MOM_diag_mediator, only : register_static_field, time_type, diag_ctrl
use MOM_domains, only : pass_var
@@ -13,7 +15,8 @@ module MOM_geothermal
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : thermo_var_ptrs
use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units
-use MOM_EOS, only : calculate_density, calculate_density_derivs
+use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain
+use MOM_EOS, only : calculate_specific_vol_derivs
implicit none ; private
@@ -39,7 +42,7 @@ module MOM_geothermal
integer :: id_internal_heat_heat_tendency = -1 !< ID for diagnostic of heat tendency
integer :: id_internal_heat_temp_tendency = -1 !< ID for diagnostic of temperature tendency
integer :: id_internal_heat_h_tendency = -1 !< ID for diagnostic of thickness tendency
-
+ integer :: id_geothermal_buoyancy_flux = -1 !< ID for diagnostic of bottom buoyancy flux
end type geothermal_CS
contains
@@ -360,7 +363,7 @@ end subroutine geothermal_entraining
!> Applies geothermal heating to the bottommost layers that occur within GEOTHERMAL_THICKNESS of
!! the bottom, by simply heating the water in place. Any heat that can not be applied to the ocean
!! is returned (WHERE)?
-subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo)
+subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, BFlx_geothermal, halo)
type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]
@@ -369,12 +372,20 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo)
real, intent(in) :: dt !< Time increment [T ~> s].
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(geothermal_CS), intent(in) :: CS !< Geothermal heating control struct
+ real, dimension(SZI_(G), SZJ_(G)), intent(out) :: BFlx_geothermal !< Geothermal buoyancy flux
+ !! in [Z2 T-3 ~> m2 s-3]
integer, optional, intent(in) :: halo !< Halo width over which to work
+
! Local variables
real, dimension(SZI_(G)) :: &
heat_rem, & ! remaining heat [H 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 +397,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 ~> m6 kg-2]
logical :: do_any ! True if there is more to be done on the current j-row.
logical :: calc_diags ! True if diagnostic tendencies are needed.
+ 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 +415,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 +434,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 +527,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 +621,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_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90
index 2384844f6e..f8ed9f111c 100644
--- a/src/parameterizations/vertical/MOM_internal_tide_input.F90
+++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Calculates energy input to the internal tides
module MOM_int_tide_input
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE
use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled
@@ -551,13 +553,13 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide)
do fr=1,num_freq ; do j=js,je ; do i=is,ie
mask_itidal = 1.0
- if (G%bathyT(i,j) + G%Z_ref < min_zbot_itides) mask_itidal = 0.0
+ if (G%meanSL(i,j) + G%bathyT(i,j) < min_zbot_itides) mask_itidal = 0.0
CS%tideamp(i,j,fr) = CS%tideamp(i,j,fr) * mask_itidal * G%mask2dT(i,j)
! Restrict rms topo to a fraction (often 10 percent) of the column depth.
if (max_frac_rough >= 0.0) &
- itide%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, itide%h2(i,j))
+ itide%h2(i,j) = min((max_frac_rough * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0))**2, itide%h2(i,j))
! Compute the fixed part of internal tidal forcing; units are [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] here.
CS%TKE_itidal_coef(i,j,fr) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * &
diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90
index 53d6b36e4a..0dbd34c88c 100644
--- a/src/parameterizations/vertical/MOM_kappa_shear.F90
+++ b/src/parameterizations/vertical/MOM_kappa_shear.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Shear-dependent mixing following Jackson et al. 2008.
module MOM_kappa_shear
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
@@ -57,12 +59,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 +79,7 @@ module MOM_kappa_shear
!! to estimate the time-averaged diffusivity.
logical :: dKdQ_iteration_bug !< If true. use an older, dimensionally inconsistent estimate of
!! the derivative of diffusivity with energy in the Newton's method
- !! iteration. The bug causes undercorrections when dz > 1m.
+ !! iteration. The bug causes under-corrections when dz > 1m.
logical :: KS_at_vertex !< If true, do the calculations of the shear-driven mixing
!! at the cell vertices (i.e., the vorticity points).
logical :: eliminate_massless !< If true, massless layers are merged with neighboring
@@ -103,6 +105,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
@@ -179,7 +185,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, &
u0xdz, & ! The initial zonal velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1]
v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1]
T0xdz, & ! The initial temperature times thickness [C H ~> degC m or degC kg m-2] or if
- ! temperature is not a state variable, the density times thickness [R H ~> kg m-2 or kg2 m-3]
+ ! temperature is not a state variable, the density times thickness [R H ~> kg m-2 or kg2 m-5]
S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2].
real, dimension(SZK_(GV)+1) :: &
kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s]
@@ -207,15 +213,15 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, &
! interpolating back to the original index space [nondim].
integer :: is, ie, js, je, i, j, k, nz, nzc
- is = G%isc ; ie = G%iec; js = G%jsc ; je = G%jec ; nz = GV%ke
+ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
use_temperature = associated(tv%T)
k0dt = dt*CS%kappa_0
dz_massless = 0.1*sqrt((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 +346,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 +366,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 +397,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 +461,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 +512,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 +533,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 +573,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 +708,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 +739,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 +789,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 +845,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
@@ -962,7 +1009,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_la
g_R0 = GV%g_Earth_Z_T2 / GV%Rho0
k0dt = dt*CS%kappa_0
- I_lz_rescale_sqr = 1.0; if (CS%lz_rescale > 0) I_lz_rescale_sqr = 1/(CS%lz_rescale*CS%lz_rescale)
+ I_lz_rescale_sqr = 1.0 ; if (CS%lz_rescale > 0) I_lz_rescale_sqr = 1/(CS%lz_rescale*CS%lz_rescale)
tol_dksrc = CS%kappa_src_max_chg
if (tol_dksrc == 10.0) then
@@ -1341,7 +1388,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 +2087,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 +2125,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 +2154,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.", &
@@ -2152,7 +2214,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS)
call get_param(param_file, mdl, "LZ_RESCALE", CS%lz_rescale, &
"A coefficient to rescale the distance to the nearest solid boundary. "//&
"This adjustment is to account for regions where 3 dimensional turbulence "//&
- "prevents the growth of shear instabilies [nondim].", &
+ "prevents the growth of shear instabilities [nondim].", &
units="nondim", default=1.0)
call get_param(param_file, mdl, "KAPPA_SHEAR_TOL_ERR", CS%kappa_tol_err, &
"The fractional error in kappa that is tolerated. "//&
diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90
index b62f67feee..02c9958e6e 100644
--- a/src/parameterizations/vertical/MOM_opacity.F90
+++ b/src/parameterizations/vertical/MOM_opacity.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Routines used to calculate the opacity of the ocean.
module MOM_opacity
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data
use MOM_diag_mediator, only : query_averaging_enabled, register_diag_field
use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING
@@ -327,7 +329,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir
do k=1,nz ; do j=js,je ; do i=is,ie
if ((G%mask2dT(i,j) > 0.0) .and. (chl_3d(i,j,k) < 0.0)) then
write(mesg,'(" Negative chl_3d of ",(1pe12.4)," found at i,j,k = ", &
- & 3(1x,i3), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') &
+ & 3(1x,I0), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') &
chl_3d(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j)
call MOM_error(FATAL, "MOM_opacity opacity_from_chl: "//trim(mesg))
endif
@@ -337,7 +339,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir
do j=js,je ; do i=is,ie
if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then
write(mesg,'(" Negative chl_2d of ",(1pe12.4)," at i,j = ", &
- & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') &
+ & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') &
chl_data(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j)
call MOM_error(FATAL, "MOM_opacity opacity_from_chl: "//trim(mesg))
endif
@@ -390,7 +392,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir
do n=1,nbands
optics%sw_pen_band(n,i,j) = Inv_nbands*sw_pen_tot
enddo
- enddo; enddo
+ enddo ; enddo
case (OHLMANN_03)
! want exactly two penetrating bands. If not, throw an error.
if ( nbands /= 2 ) then
@@ -413,7 +415,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir
! Bands 1-2 (Ohlmann factors A with coefficients for Table 1a)
optics%sw_pen_band(1:2,i,j) = lookup_ohlmann_swpen(chl_data(i,j),optics)*SW_vis_tot
endif
- enddo; enddo
+ enddo ; enddo
case default
call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.")
end select
@@ -458,7 +460,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir
do n=2,optics%nbands
optics%opacity_band(n,i,j,k) = optics%opacity_band(1,i,j,k)
enddo
- enddo; enddo
+ enddo ; enddo
case (OHLMANN_03)
!! not testing for 2 bands since we did it above
do j=js,je ; do i=is,ie
@@ -468,7 +470,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir
! Bands 1-2 (Ohlmann factors B with coefficients for Table 1a
optics%opacity_band(1:2,i,j,k) = lookup_ohlmann_opacity(chl_data(i,j),optics) * US%Z_to_m
endif
- enddo; enddo
+ enddo ; enddo
case default
call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.")
end select
@@ -1299,12 +1301,12 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics)
CS%id_sw_vis_pen = register_diag_field('ocean_model', 'SW_vis_pen', diag%axesT1, Time, &
'Visible penetrating shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2)
do n=1,optics%nbands
- write(bandnum,'(i3)') n
- shortname = 'opac_'//trim(adjustl(bandnum))
- longname = 'Opacity for shortwave radiation in band '//trim(adjustl(bandnum)) &
- // ', saved as L^-1 tanh(Opacity * L) for L = 10^-10 m'
+ write(bandnum,'(I0)') n
+ shortname = 'opac_'//trim(bandnum)
+ longname = 'Opacity for shortwave radiation in band '//trim(bandnum)// &
+ ', saved as L^-1 tanh(Opacity * L) for L = 10^-10 m'
CS%id_opacity(n) = register_diag_field('ocean_model', shortname, diag%axesTL, Time, &
- longname, 'm-1', conversion=US%m_to_Z)
+ longname, 'm-1', conversion=US%m_to_Z)
enddo
if (CS%opacity_scheme == OHLMANN_03) then
diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90
index b00238f60c..a8dd0cb1e6 100644
--- a/src/parameterizations/vertical/MOM_regularize_layers.F90
+++ b/src/parameterizations/vertical/MOM_regularize_layers.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides regularization of layers in isopycnal mode
module MOM_regularize_layers
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
use MOM_diag_mediator, only : time_type, diag_ctrl
@@ -572,21 +574,21 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS)
if (abs(h_tot1(i) - h_tot2(i)) > 1e-12*h_tot1(i)) then
write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4)') &
h_tot1(i), h_tot2(i), (h_tot1(i) - h_tot2(i))
- call MOM_error(WARNING, "regularize_surface: Mass non-conservation."//&
+ call MOM_error(WARNING, "regularize_surface: Mass non-conservation. "//&
trim(mesg), .true.)
fatal_error = .true.
endif
if (abs(Th_tot1(i) - Th_tot2(i)) > 1e-12*abs(Th_tot1(i) + 10.0*US%degC_to_C*h_tot1(i))) then
write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') &
Th_tot1(i), Th_tot2(i), (Th_tot1(i) - Th_tot2(i)), (Th_tot1(i) - Th_tot3(i))
- call MOM_error(WARNING, "regularize_surface: Heat non-conservation."//&
+ call MOM_error(WARNING, "regularize_surface: Heat non-conservation. "//&
trim(mesg), .true.)
fatal_error = .true.
endif
if (abs(Sh_tot1(i) - Sh_tot2(i)) > 1e-12*abs(Sh_tot1(i) + 10.0*US%ppt_to_S*h_tot1(i))) then
write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') &
Sh_tot1(i), Sh_tot2(i), (Sh_tot1(i) - Sh_tot2(i)), (Sh_tot1(i) - Sh_tot3(i))
- call MOM_error(WARNING, "regularize_surface: Salinity non-conservation."//&
+ call MOM_error(WARNING, "regularize_surface: Salinity non-conservation. "//&
trim(mesg), .true.)
fatal_error = .true.
endif
diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90
index 67e57c7cdf..971e5f6226 100644
--- a/src/parameterizations/vertical/MOM_set_diffusivity.F90
+++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Calculate vertical diffusivity from all mixing processes
module MOM_set_diffusivity
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs
use MOM_bkgnd_mixing, only : bkgnd_mixing_end
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
@@ -82,6 +84,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]
@@ -227,8 +231,7 @@ module MOM_set_diffusivity
real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL()
!< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE
- !! dissipated within a layer and Kd in that layer
- !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1]
+ !! dissipated within a layer and Kd in that layer [T2 Z-1 ~> s2 m-1]
end type diffusivity_diags
@@ -305,8 +308,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i
prof_Froude_2d, & !< vertical profile for Froude drag [Z-1 ~> m-1]
prof_slope_2d, & !< vertical profile for critical slopes [Z-1 ~> m-1]
TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between
- !< TKE dissipated within a layer and Kd in that layer
- !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1]
+ !< TKE dissipated within a layer and Kd in that layer [T2 Z-1 ~> s2 m-1]
real, dimension(SZI_(G),SZK_(GV)+1) :: &
N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2]
@@ -532,7 +534,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i
enddo ; enddo ; endif
if (associated(VBF%Kd_ddiff_S)) then ; do K=1,nz+1 ; do i=is,ie
VBF%Kd_ddiff_S(i,j,K) = KS_extra(i,K)
- enddo ; enddo ; endif ;
+ enddo ; enddo ; endif
endif
! Apply double diffusion via CVMix
@@ -550,7 +552,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i
enddo ; enddo ; endif
if (associated(VBF%Kd_ddiff_S)) then ; do K=1,nz+1 ; do i=is,ie
VBF%Kd_ddiff_S(i,j,K) = KS_extra(i,K)
- enddo ; enddo ; endif ;
+ enddo ; enddo ; endif
call cpu_clock_end(id_clock_CVMix_ddiff)
endif
@@ -631,34 +633,34 @@ 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
+ if (CS%id_prof_leak > 0) then ; do k=1,nz ; do i=is,ie
dd%prof_leak(i,j,k) = prof_leak_2d(i,k)
enddo ; enddo ; endif
- if (CS%id_prof_quad > 0) then ; do k=1,nz; do i=is,ie
+ if (CS%id_prof_quad > 0) then ; do k=1,nz ; do i=is,ie
dd%prof_quad(i,j,k) = prof_quad_2d(i,k)
enddo ; enddo ; endif
- if (CS%id_prof_itidal > 0) then ; do k=1,nz; do i=is,ie
+ if (CS%id_prof_itidal > 0) then ; do k=1,nz ; do i=is,ie
dd%prof_itidal(i,j,k) = prof_itidal_2d(i,k)
enddo ; enddo ; endif
- if (CS%id_prof_Froude > 0) then ; do k=1,nz; do i=is,ie
+ if (CS%id_prof_Froude > 0) then ; do k=1,nz ; do i=is,ie
dd%prof_Froude(i,j,k) = prof_Froude_2d(i,k)
enddo ; enddo ; endif
- if (CS%id_prof_slope > 0) then ; do k=1,nz; do i=is,ie
+ if (CS%id_prof_slope > 0) then ; do k=1,nz ; do i=is,ie
dd%prof_slope(i,j,k) = prof_slope_2d(i,k)
enddo ; enddo ; endif
endif
@@ -696,7 +698,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i
if (CS%Kd_add > 0.0) then
do K=1,nz+1 ; do i=is,ie
Kd_int_2d(i,K) = Kd_int_2d(i,K) + CS%Kd_add
- enddo; enddo
+ enddo ; enddo
VBF%Kd_add = CS%Kd_add
endif
@@ -886,7 +888,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, &
!! TKE dissipated within a layer and the
!! diapycnal diffusivity within that layer,
!! usually (~Rho_0 / (G_Earth * dRho_lay))
- !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1]
+ !! [T2 Z-1 ~> s2 m-1]
real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain to its
!! maximum realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2]
integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer
@@ -1380,7 +1382,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE,
!! TKE dissipated within a layer and the
!! diapycnal diffusivity within that layer,
!! usually (~Rho_0 / (G_Earth * dRho_lay))
- !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1]
+ !! [T2 Z-1 ~> s2 m-1]
real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain to its
!! maximum-realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2]
integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer
@@ -1803,7 +1805,7 @@ subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_t
!! TKE dissipated within a layer and the
!! diapycnal diffusivity witin that layer,
!! usually (~Rho_0 / (G_Earth * dRho_lay))
- !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1]
+ !! [T2 Z-1 ~> s2 m-1]
real, dimension(SZI_(G),SZK_(GV)), &
optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers
!! [H Z T-1 ~> m2 s-1 or kg m-1 s-1].
@@ -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 "//&
@@ -2467,14 +2468,12 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_
"calculations. Values below 20240630 recover the original answers, while "//&
"higher values use more accurate expressions. This only applies when "//&
"USE_LOTW_BBL_DIFFUSIVITY is true.", &
- default=20190101, do_not_log=.not.CS%use_LOTW_BBL_diffusivity)
- !### Set default as default=default_answer_date, or use SET_DIFF_ANSWER_DATE.
+ default=default_answer_date, do_not_log=.not.CS%use_LOTW_BBL_diffusivity)
call get_param(param_file, mdl, "DRAG_DIFFUSIVITY_ANSWER_DATE", CS%drag_diff_answer_date, &
"The vintage of the order of arithmetic in the drag diffusivity calculations. "//&
"Values above 20250301 use less confusing expressions to set the bottom-drag "//&
"generated diffusivity when USE_LOTW_BBL_DIFFUSIVITY is false. ", &
- default=20250101, do_not_log=CS%use_LOTW_BBL_diffusivity.or.(CS%BBL_effic<=0.0))
- !### Set default as default=default_answer_date, or use SET_DIFF_ANSWER_DATE.
+ default=CS%answer_date, do_not_log=CS%use_LOTW_BBL_diffusivity.or.(CS%BBL_effic<=0.0))
CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, &
'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s)
@@ -2623,7 +2622,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_
'User-specified Extra Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s)
call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, &
- "If true, increase diffusivites for temperature or salinity based on the "//&
+ "If true, increase diffusivities for temperature or salinity based on the "//&
"double-diffusive parameterization described in Large et al. (1994).", &
default=.false.)
@@ -2668,7 +2667,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_
if (CS%double_diffusion .and. CS%use_CVMix_ddiff) then
call MOM_error(FATAL, 'set_diffusivity_init: '// &
- 'Multiple double-diffusion options selected (DOUBLE_DIFFUSION and'//&
+ 'Multiple double-diffusion options selected (DOUBLE_DIFFUSION and '//&
'USE_CVMIX_DDIFF), please disable all but one option to proceed.')
endif
diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90
index 4739b626c9..b6228eed50 100644
--- a/src/parameterizations/vertical/MOM_set_viscosity.F90
+++ b/src/parameterizations/vertical/MOM_set_viscosity.F90
@@ -1,9 +1,13 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+#include "do_concurrent_compat.h"
+
!> Calculates various values related to the bottom boundary layer, such as the viscosity and
!! thickness of the BBL (set_viscous_BBL).
module MOM_set_visc
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_ALE, only : ALE_CS, ALE_remap_velocities, ALE_remap_interface_vals, ALE_remap_vertex_vals
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE
use MOM_cvmix_conv, only : cvmix_conv_is_used
@@ -75,6 +79,8 @@ module MOM_set_visc
!! actual velocity in the bottommost `HBBL`, depending
!! on whether linear_drag is true.
!! Runtime parameter `BOTTOMDRAGLAW`.
+ logical :: bottomdragmap !< If true, apply the spatially varying drag coefficient (cdrag_2d)
+ !! instead of the spatially uniform drag coefficient (cdrag).
logical :: body_force_drag !< If true, the bottom stress is imposed as an explicit body force
!! applied over a fixed distance from the bottom, rather than as an
!! implicit calculation based on an enhanced near-bottom viscosity.
@@ -87,6 +93,12 @@ module MOM_set_visc
real :: Chan_drag_max_vol !< The maximum bottom boundary layer volume within which the
!! channel drag is applied, normalized by the full cell area,
!! or a negative value to apply no maximum [Z ~> m].
+ real :: channel_break_depth !< When CHANNEL_DRAG is true, the bathymetric depth interpolated
+ !! to the vorticity point is a combination of the harmonic mean of the
+ !! adjacent velocity point depths below this depth [Z ~> m] and the
+ !! arithmetic mean of the adjacent depths above it, to roughly mimic a
+ !! continental shelf break profile. The internal version of this depth
+ !! uses the same offset (G%Z_ref) as the bathymetry.
logical :: correct_BBL_bounds !< If true, uses the correct bounds on the BBL thickness and
!! viscosity so that the bottom layer feels the intended drag.
logical :: RiNo_mix !< If true, use Richardson number dependent mixing.
@@ -103,6 +115,10 @@ module MOM_set_visc
real :: omega_frac !< When setting the decay scale for turbulence, use this
!! fraction of the absolute rotation rate blended with the local
!! value of f, as sqrt((1-of)*f^2 + of*4*omega^2) [nondim]
+ real :: tideampfac2 !< A factor to multiply by tideamp to convert to a mean ustar,
+ !! accounts for conversion of amplitude to mean magnitude over
+ !! a time average much longer than the tidal periods and for
+ !! non-commuting conversion of mean tideamp to mean ustar**3 [nondim]
logical :: concave_trigonometric_L !< If true, use trigonometric expressions to determine the
!! fractional open interface lengths for concave topography.
integer :: answer_date !< The vintage of the order of arithmetic and expressions in the set
@@ -117,6 +133,8 @@ module MOM_set_visc
type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to
!! regulate the timing of diagnostic output.
! Allocatable data arrays
+ real, allocatable, dimension(:,:) :: cdrag_u !< The spatially varying quadratic drag coefficient [nondim]
+ real, allocatable, dimension(:,:) :: cdrag_v !< The spatially varying quadratic drag coefficient [nondim]
real, allocatable, dimension(:,:) :: tideamp !< RMS tidal amplitude at h points [Z T-1 ~> m s-1]
! Diagnostic arrays
real, allocatable, dimension(:,:) :: bbl_u !< BBL mean U current [L T-1 ~> m s-1]
@@ -152,7 +170,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
type(porous_barrier_type),intent(in) :: pbv !< porous barrier fractional cell metrics
! Local variables
- real, dimension(SZIB_(G)) :: &
+ real, dimension(SZIB_(G),SZJB_(G)) :: &
ustar, & ! The bottom friction velocity [H T-1 ~> m s-1 or kg m-2 s-1].
T_EOS, & ! The temperature used to calculate the partial derivatives
! of density with T and S [C ~> degC].
@@ -181,7 +199,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
D_v, & ! Bottom depth linearly interpolated to v points [Z ~> m].
mask_v ! A mask that disables any contributions from v points that
! are land or past open boundary conditions [nondim], 0 or 1.
- real, dimension(SZIB_(G),SZK_(GV)) :: &
+ real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: &
h_at_vel, & ! Layer thickness at a velocity point, using an upwind-biased
! second order accurate estimate based on the previous velocity
! direction [H ~> m or kg m-2].
@@ -207,6 +225,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
real :: ustarsq ! 400 times the square of ustar, times
! Rho0 divided by G_Earth and the conversion
! from m to thickness units [H R ~> kg m-2 or kg2 m-5].
+ real :: cdrag ! The drag coefficient [nondim].
real :: cdrag_sqrt ! Square root of the drag coefficient [nondim].
real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion factor
! from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3].
@@ -231,7 +250,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
real :: BBL_thick_max ! A huge upper bound on the boundary layer thickness [Z ~> m].
real :: kv_bbl ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]
real :: C2f ! C2f = 2*f at velocity points [T-1 ~> s-1].
- real :: u2_bg(SZIB_(G)) ! The square of an assumed background velocity, for calculating the mean
+ real :: u2_bg(SZIB_(G),SZJB_(G)) ! The square of an assumed background velocity, for calculating the mean
! magnitude near the bottom for use in the quadratic bottom drag [L2 T-2 ~> m2 s-2].
real :: hwtot ! Sum of the thicknesses used to calculate
! the near-bottom velocity magnitude [H ~> m or kg m-2].
@@ -242,7 +261,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1].
real :: Thtot ! Running sum of thickness times temperature [C H ~> degC m or degC kg m-2].
real :: Shtot ! Running sum of thickness times salinity [S H ~> ppt m or ppt kg m-2].
- real :: SpV_htot ! Running sum of thickness times specific volume [R-1 H ~> m4 kg-1 or m]
+ real :: SpV_htot ! Running sum of thickness times specific volume [H R-1 ~> m4 kg-1 or m]
real :: hweight ! The thickness of a layer that is within Hbbl
! of the bottom [H ~> m or kg m-2].
real :: dzweight ! The counterpart of hweight in height units [Z ~> m].
@@ -252,11 +271,14 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
! The 400 is a constant proposed by Killworth and Edwards, 1999.
real, dimension(SZI_(G),SZJ_(G),max(GV%nk_rho_varies,1)) :: &
Rml ! The mixed layer coordinate density [R ~> kg m-3].
- real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate
+ real :: p_ref(SZI_(G),SZJ_(G)) ! The pressure used to calculate the coordinate
! density [R L2 T-2 ~> Pa] (usually set to 2e7 Pa = 2000 dbar).
- real :: D_vel ! The bottom depth at a velocity point [Z ~> m].
- real :: Dp, Dm ! The depths at the edges of a velocity cell [Z ~> m].
+ real :: D_vel ! The bottom depth relative to the shelfbreak depth at a velocity point [Z ~> m].
+ real :: Dp, Dm ! The bottom depths at the edges of a velocity cell relative to the
+ ! shelfbreak depth [Z ~> m].
+ real :: D_vel_p, D_vel_m ! The bottom depths in adjacent velocity points relative to the
+ ! shelfbreak depth [Z ~> m].
real :: crv ! crv is the curvature of the bottom depth across a
! cell, times the cell width squared [Z ~> m].
real :: slope ! The absolute value of the bottom depth slope across
@@ -301,11 +323,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
real :: h_bbl_fr ! The fraction of the bottom boundary layer in a layer [nondim].
real :: h_sum ! The sum of the thicknesses of the layers below the one being
! worked on [H ~> m or kg m-2].
+ real :: tideampfac2_x_0p5 ! tideampfac2 multiplied by the c-grid averaging factor of 0.5
real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 ! Rational constants [nondim]
real :: tmp ! A temporary variable, sometimes in [Z ~> m]
- logical :: use_BBL_EOS, do_i(SZIB_(G))
- integer, dimension(2) :: EOSdom ! The computational domain for the equation of state
- integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml
+ logical :: use_BBL_EOS, do_i(SZIB_(G),SZJB_(G))
+ integer, dimension(2,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, jstart
+ 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
@@ -315,6 +339,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
dz_neglect = GV%dZ_subroundoff
Rho0x400_G = 400.0*(GV%H_to_RZ / GV%g_Earth_Z_T2)
+ tideampfac2_x_0p5 = CS%tideampfac2*0.5
if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//&
"Module must be initialized before it is used.")
@@ -339,354 +364,431 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
use_BBL_EOS = associated(tv%eqn_of_state) .and. CS%BBL_use_EOS
OBC => CS%OBC
- cdrag_sqrt = sqrt(CS%cdrag)
- cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H
- cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H
- cdrag_L_to_H = CS%cdrag * US%L_to_m * GV%m_to_H
- cdrag_RL_to_H = CS%cdrag * US%L_to_Z * GV%RZ_to_H
+ if (.not.CS%bottomdragmap) then
+ cdrag_sqrt = sqrt(CS%cdrag)
+ cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H
+ cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H
+ cdrag_L_to_H = CS%cdrag * US%L_to_m * GV%m_to_H
+ cdrag_RL_to_H = CS%cdrag * US%L_to_Z * GV%RZ_to_H
+ endif
BBL_thick_max = G%Rad_Earth_L * US%L_to_Z
K2 = max(nkmb+1, 2)
+ !$omp target enter data map(alloc: dz)
+
! Find the vertical distances across layers.
- call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1)
+ call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1, do_offload=.true.)
! With a linear drag law, the friction velocity is already known.
! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel
+ !$omp target enter data map(to: tv, tv%T, tv%S, tv%p_surf, CS) map(alloc: Rml, p_ref, ustar, &
+ !$omp umag_avg, u2_bg, mask_u, mask_v, h_bbl_drag, dz_bbl_drag, do_i, dR_dS, dR_dT, D_u, D_v, &
+ !$omp press, S_EOS, T_EOS, Rml_vel)
+
if ((nkml>0) .and. .not.use_BBL_EOS) then
- EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1)
- do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo
- !$OMP parallel do default(shared)
- do k=1,nkmb ; do j=Jsq,Jeq+1
- call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), tv%eqn_of_state, &
- EOSdom)
- enddo ; enddo
+ EOSdom(1,1) = Isq - (G%isd-1) ; EOSdom(1,2) = G%iec+1 - (G%isd-1)
+ EOSdom(2,1) = Jsq - (G%jsd-1) ; EOSdom(2,2) = G%jec+1 - (G%jsd-1)
+ do concurrent (j=Jsq:Jeq+1, i=Isq:Ieq+1)
+ p_ref(i,j) = tv%P_Ref
+ enddo
+ do k=1,nkmb
+ call calculate_density(tv%T(:,:,k), tv%S(:,:,k), p_ref, Rml(:,:,k), tv%eqn_of_state, EOSdom)
+ enddo
endif
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is-1,ie+1
- D_v(i,J) = 0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) + G%Z_ref
+ do concurrent (J=js-1:je, i=is-1:ie+1)
+ D_v(i,J) = 0.5*(G%bathyT(i,j) + G%bathyT(i,j+1))
mask_v(i,J) = G%mask2dCv(i,J)
- enddo ; enddo
- !$OMP parallel do default(shared)
- do j=js-1,je+1 ; do I=is-1,ie
- D_u(I,j) = 0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) + G%Z_ref
+ enddo
+ do concurrent (j=js-1:je+1, I=is-1:ie)
+ D_u(I,j) = 0.5*(G%bathyT(i,j) + G%bathyT(i+1,j))
mask_u(I,j) = G%mask2dCu(I,j)
- enddo ; enddo
+ enddo
- if (associated(OBC)) then ; do n=1,OBC%number_of_segments
- if (.not. OBC%segment(n)%on_pe) cycle
+ if (associated(OBC) .and. CS%Channel_drag) then
+ !$omp target update from(mask_u, mask_v, D_u, D_v)
! Use a one-sided projection of bottom depths at OBC points.
- I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
- if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= je)) then
- do i = max(is-1,OBC%segment(n)%HI%isd), min(ie+1,OBC%segment(n)%HI%ied)
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) D_v(i,J) = G%bathyT(i,j) + G%Z_ref
- if (OBC%segment(n)%direction == OBC_DIRECTION_S) D_v(i,J) = G%bathyT(i,j+1) + G%Z_ref
- enddo
- elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= ie)) then
- do j = max(js-1,OBC%segment(n)%HI%jsd), min(je+1,OBC%segment(n)%HI%jed)
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) D_u(I,j) = G%bathyT(i,j) + G%Z_ref
- if (OBC%segment(n)%direction == OBC_DIRECTION_W) D_u(I,j) = G%bathyT(i+1,j) + G%Z_ref
- enddo
+ if (OBC%v_N_OBCs_on_PE) then
+ Js_OBC = max(js-1, OBC%Js_v_N_obc) ; Je_OBC = min(je, OBC%Je_v_N_obc)
+ is_OBC = max(is-1, OBC%is_v_N_obc) ; ie_OBC = min(ie+1, OBC%ie_v_N_obc)
+ !$OMP parallel do default(shared)
+ do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC
+ if (OBC%segnum_v(i,J) > 0) D_v(i,J) = G%bathyT(i,j) ! OBC_DIRECTION_N
+ enddo ; enddo
endif
- enddo ; endif
- if (associated(OBC)) then ; do n=1,OBC%number_of_segments
- ! Now project bottom depths across cell-corner points in the OBCs. The two
- ! projections have to occur in sequence and can not be combined easily.
- if (.not. OBC%segment(n)%on_pe) cycle
- ! 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%IsdB), min(ie,OBC%segment(n)%HI%IedB)
- if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
- D_u(I,j+1) = D_u(I,j) ; mask_u(I,j+1) = 0.0
- elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then
- D_u(I,j) = D_u(I,j+1) ; mask_u(I,j) = 0.0
- endif
- 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%JsdB), min(je,OBC%segment(n)%HI%JedB)
- if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
- D_v(i+1,J) = D_v(i,J) ; mask_v(i+1,J) = 0.0
- elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then
- D_v(i,J) = D_v(i+1,J) ; mask_v(i,J) = 0.0
- endif
- enddo
+ if (OBC%v_S_OBCs_on_PE) then
+ !$omp target update from(D_v)
+ Js_OBC = max(js-1, OBC%Js_v_S_obc) ; Je_OBC = min(je, OBC%Je_v_S_obc)
+ is_OBC = max(is-1, OBC%is_v_S_obc) ; ie_OBC = min(ie+1, OBC%ie_v_S_obc)
+ !$OMP parallel do default(shared)
+ do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC
+ if (OBC%segnum_v(i,J) < 0) D_v(i,J) = G%bathyT(i,j+1) ! OBC_DIRECTION_S
+ enddo ; enddo
+ !$omp target update to(D_v)
+ endif
+ if (OBC%u_E_OBCs_on_PE) then
+ !$omp target update from(D_u)
+ js_OBC = max(js-1, OBC%js_u_E_obc) ; je_OBC = min(je+1, OBC%je_u_E_obc)
+ Is_OBC = max(is-1, OBC%Is_u_E_obc) ; Ie_OBC = min(ie, OBC%Ie_u_E_obc)
+ !$OMP parallel do default(shared)
+ do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC
+ if (OBC%segnum_u(I,j) > 0) D_u(I,j) = G%bathyT(i,j) ! OBC_DIRECTION_E
+ enddo ; enddo
+ !$omp target update to(D_u)
+ endif
+ if (OBC%u_W_OBCs_on_PE) then
+ js_OBC = max(js-1, OBC%js_u_W_obc) ; je_OBC = min(je+1, OBC%je_u_W_obc)
+ Is_OBC = max(is-1, OBC%Is_u_W_obc) ; Ie_OBC = min(ie, OBC%Ie_u_W_obc)
+ !$OMP parallel do default(shared)
+ do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC
+ if (OBC%segnum_u(I,j) < 0) D_u(I,j) = G%bathyT(i+1,j) ! OBC_DIRECTION_W
+ enddo ; enddo
endif
- enddo ; endif
- if (.not.use_BBL_EOS) Rml_vel(:,:) = 0.0
+ do n=1,OBC%number_of_segments
+ ! Now project bottom depths across cell-corner points in the OBCs. The two
+ ! projections have to occur in sequence and can not be combined easily.
+ if (.not. OBC%segment(n)%on_pe) cycle
+ ! 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%IsdB), min(ie,OBC%segment(n)%HI%IedB)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
+ D_u(I,j+1) = D_u(I,j) ; mask_u(I,j+1) = 0.0
+ elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then
+ D_u(I,j) = D_u(I,j+1) ; mask_u(I,j) = 0.0
+ endif
+ 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%JsdB), min(je,OBC%segment(n)%HI%JedB)
+ if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
+ D_v(i+1,J) = D_v(i,J) ; mask_v(i+1,J) = 0.0
+ elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then
+ D_v(i,J) = D_v(i+1,J) ; mask_v(i,J) = 0.0
+ endif
+ enddo
+ endif
+ enddo
+ !$omp target update to(mask_u, mask_v, D_u, D_v)
+ endif
+
+ if (.not.use_BBL_EOS) then
+ do concurrent (k=1:nz, j=G%jsdB:G%Jedb, i=G%isdB:G%iedB)
+ Rml_vel(i,j,k) = 0.0
+ enddo
+ endif
! Resetting Ray_[uv] is required by body force drag.
- if (allocated(visc%Ray_u)) visc%Ray_u(:,:,:) = 0.0
- if (allocated(visc%Ray_v)) visc%Ray_v(:,:,:) = 0.0
+ if (allocated(visc%Ray_u)) then
+ do concurrent (k=1:nz, j=G%jsd:G%jed, i=G%isdB:G%iedB)
+ visc%Ray_u(i,j,k) = 0.0
+ enddo
+ endif
+ if (allocated(visc%Ray_v)) then
+ do concurrent (k=1:nz, j=G%jsdB:G%jedB, i=G%isd:G%ied)
+ visc%Ray_v(i,j,k) = 0.0
+ enddo
+ endif
- !$OMP parallel do default(private) shared(u,v,h,dz,tv,visc,G,GV,US,CS,Rml,nz,nkmb,nkml,K2, &
- !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G, &
- !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, &
- !$OMP cdrag_L_to_H,cdrag_RL_to_H,use_BBL_EOS,BBL_thick_max, &
- !$OMP OBC,D_u,D_v,mask_u,mask_v,pbv)
- do j=Jsq,Jeq ; do m=1,2
+ !$omp target enter data map(alloc: S_vel, T_vel, SpV_vel, h_vel, h_at_vel, dz_vel, &
+ !$omp dz_at_vel)
+ do m=1,2
if (m==1) then
! m=1 refers to u-points
- if (j 0.0)
- enddo
+ jstart = G%Jsc
else
! m=2 refers to v-points
is = G%isc ; ie = G%iec
- do i=is,ie
- do_i(i) = (G%mask2dCv(i,J) > 0.0)
- enddo
+ jstart = Jsq
endif
- ! Calculate thickness at velocity points (u or v depending on value of m).
- ! Also interpolate the ML density or T/S properties.
- if (m==1) then ! u-points
- do k=1,nz ; do I=is,ie
- if (do_i(I)) then
- if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then
- ! If the flow is from thin to thick then bias towards the thinner thickness
- h_at_vel(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / &
- (h(i,j,k) + h(i+1,j,k) + h_neglect)
- dz_at_vel(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / &
- (dz(i,j,k) + dz(i+1,j,k) + dz_neglect)
- else
- ! If the flow is from thick to thin then use the simple average thickness
- h_at_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k))
- dz_at_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k))
- endif
- endif
- h_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k))
- dz_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k))
- enddo ; enddo
- if (use_BBL_EOS) then ; do k=1,nz ; do I=is,ie
- ! Perhaps these should be thickness weighted.
- T_vel(I,k) = 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k))
- S_vel(I,k) = 0.5 * (tv%S(i,j,k) + tv%S(i+1,j,k))
- enddo ; enddo ; else ; do k=1,nkmb ; do I=is,ie
- Rml_vel(I,k) = 0.5 * (Rml(i,j,k) + Rml(i+1,j,k))
- enddo ; enddo ; endif
- if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do I=is,ie
- SpV_vel(I,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k))
- enddo ; enddo ; endif
- else ! v-points
- do k=1,nz ; do i=is,ie
- if (do_i(i)) then
- if (v(i,J,k) * (h(i,j+1,k) - h(i,j,k)) >= 0) then
- ! If the flow is from thin to thick then bias towards the thinner thickness
- h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / &
- (h(i,j,k) + h(i,j+1,k) + h_neglect)
- dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / &
- (dz(i,j,k) + dz(i,j+1,k) + dz_neglect)
- else
- ! If the flow is from thick to thin then use the simple average thickness
- h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k))
- dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k))
- endif
- endif
- h_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k))
- dz_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k))
- enddo ; enddo
- if (use_BBL_EOS) then ; do k=1,nz ; do i=is,ie
- ! Perhaps these should be thickness weighted.
- T_vel(i,k) = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k))
- S_vel(i,k) = 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k))
- enddo ; enddo ; else ; do k=1,nkmb ; do i=is,ie
- Rml_vel(i,k) = 0.5 * (Rml(i,j,k) + Rml(i,j+1,k))
- enddo ; enddo ; endif
- if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do i=is,ie
- SpV_vel(i,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k))
- enddo ; enddo ; endif
- endif
-
- if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then
- ! Apply a zero gradient projection of thickness across OBC points.
+ do concurrent (j=jstart:Jeq)
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 k=1,nz
- h_at_vel(I,k) = h(i,j,k) ; h_vel(I,k) = h(i,j,k)
- dz_at_vel(I,k) = dz(i,j,k) ; dz_vel(I,k) = dz(i,j,k)
- enddo
- if (use_BBL_EOS) then
- do k=1,nz
- T_vel(I,k) = tv%T(i,j,k) ; S_vel(I,k) = tv%S(i,j,k)
- enddo
+ do concurrent (i=is:ie)
+ do_i(i,j) = (G%mask2dCu(I,j) > 0.0)
+ enddo
+ else
+ do concurrent (i=is:ie)
+ do_i(i,j) = (G%mask2dCv(i,J) > 0.0)
+ enddo
+ endif
+
+ ! Calculate thickness at velocity points (u or v depending on value of m).
+ ! Also interpolate the ML density or T/S properties.
+ if (m==1) then ! u-points
+ do concurrent (k=1:nz, I=is:ie)
+ if (do_i(I,j)) then
+ if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then
+ ! If the flow is from thin to thick then bias towards the thinner thickness
+ h_at_vel(I,j,k) = 2.0*h(i,j,k)*h(i+1,j,k) / &
+ (h(i,j,k) + h(i+1,j,k) + h_neglect)
+ dz_at_vel(I,j,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / &
+ (dz(i,j,k) + dz(i+1,j,k) + dz_neglect)
else
- do k=1,nkmb
- Rml_vel(I,k) = Rml(i,j,k)
- enddo
+ ! If the flow is from thick to thin then use the simple average thickness
+ h_at_vel(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k))
+ dz_at_vel(I,j,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k))
endif
- 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
- do k=1,nz
- h_at_vel(I,k) = h(i+1,j,k) ; h_vel(I,k) = h(i+1,j,k)
- dz_at_vel(I,k) = dz(i+1,j,k) ; dz_vel(I,k) = dz(i+1,j,k)
- enddo
- if (use_BBL_EOS) then
- do k=1,nz
- T_vel(I,k) = tv%T(i+1,j,k) ; S_vel(I,k) = tv%S(i+1,j,k)
- enddo
+ endif
+ h_vel(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k))
+ dz_vel(I,j,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k))
+ enddo
+ if (use_BBL_EOS) then ; do concurrent (k=1:nz, I=is:ie)
+ ! Perhaps these should be thickness weighted.
+ T_vel(I,j,k) = 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k))
+ S_vel(I,j,k) = 0.5 * (tv%S(i,j,k) + tv%S(i+1,j,k))
+ enddo ; else ; do concurrent (k=1:nkmb, I=is:ie)
+ Rml_vel(I,j,k) = 0.5 * (Rml(i,j,k) + Rml(i+1,j,k))
+ enddo ; endif
+ if (allocated(tv%SpV_avg)) then ; do concurrent (k=1:nz, I=is:ie)
+ SpV_vel(I,j,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k))
+ enddo ; endif
+ else ! v-points
+ do concurrent (k=1:nz, i=is:ie)
+ if (do_i(i,j)) then
+ if (v(i,J,k) * (h(i,j+1,k) - h(i,j,k)) >= 0) then
+ ! If the flow is from thin to thick then bias towards the thinner thickness
+ h_at_vel(i,j,k) = 2.0*h(i,j,k)*h(i,j+1,k) / &
+ (h(i,j,k) + h(i,j+1,k) + h_neglect)
+ dz_at_vel(i,j,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / &
+ (dz(i,j,k) + dz(i,j+1,k) + dz_neglect)
else
- do k=1,nkmb
- Rml_vel(I,k) = Rml(i+1,j,k)
- enddo
+ ! If the flow is from thick to thin then use the simple average thickness
+ h_at_vel(i,j,k) = 0.5 * (h(i,j,k) + h(i,j+1,k))
+ dz_at_vel(i,j,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k))
endif
- if (allocated(tv%SpV_avg)) then ; do k=1,nz
- SpV_vel(I,k) = tv%SpV_avg(i+1,j,k)
- enddo ; endif
endif
- endif ; enddo
- else
- do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then
- if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then
- do k=1,nz
- h_at_vel(i,k) = h(i,j,k) ; h_vel(i,k) = h(i,j,k)
- dz_at_vel(i,k) = dz(i,j,k) ; dz_vel(i,k) = dz(i,j,k)
- enddo
- if (use_BBL_EOS) then
+ h_vel(i,j,k) = 0.5 * (h(i,j,k) + h(i,j+1,k))
+ dz_vel(i,j,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k))
+ enddo
+ if (use_BBL_EOS) then ; do concurrent (k=1:nz, i=is:ie)
+ ! Perhaps these should be thickness weighted.
+ T_vel(i,j,k) = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k))
+ S_vel(i,j,k) = 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k))
+ enddo ; else ; do concurrent (k=1:nkmb, i=is:ie)
+ Rml_vel(i,j,k) = 0.5 * (Rml(i,j,k) + Rml(i,j+1,k))
+ enddo ; endif
+ if (allocated(tv%SpV_avg)) then ; do concurrent (k=1:nz, i=is:ie)
+ SpV_vel(i,j,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k))
+ enddo ; endif
+ endif
+
+ if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then
+ ! Apply a zero gradient projection of thickness across OBC points.
+ if (m==1) then
+ do concurrent (I=is:ie, do_i(I,j) .and. (OBC%segnum_u(I,j) /= 0)) &
+ DO_LOCALITY(local(k))
+ if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E
do k=1,nz
- T_vel(i,k) = tv%T(i,j,k) ; S_vel(i,k) = tv%S(i,j,k)
+ h_at_vel(I,j,k) = h(i,j,k) ; h_vel(I,j,k) = h(i,j,k)
+ dz_at_vel(I,j,k) = dz(i,j,k) ; dz_vel(I,j,k) = dz(i,j,k)
enddo
- else
- do k=1,nkmb
- Rml_vel(i,k) = Rml(i,j,k)
+ if (use_BBL_EOS) then
+ do k=1,nz
+ T_vel(I,j,k) = tv%T(i,j,k) ; S_vel(I,j,k) = tv%S(i,j,k)
+ enddo
+ else
+ do k=1,nkmb
+ Rml_vel(I,j,k) = Rml(i,j,k)
+ enddo
+ endif
+ if (allocated(tv%SpV_avg)) then ; do k=1,nz
+ SpV_vel(I,j,k) = tv%SpV_avg(i,j,k)
+ enddo ; endif
+ elseif (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W
+ do k=1,nz
+ h_at_vel(I,j,k) = h(i+1,j,k) ; h_vel(I,j,k) = h(i+1,j,k)
+ dz_at_vel(I,j,k) = dz(i+1,j,k) ; dz_vel(I,j,k) = dz(i+1,j,k)
enddo
+ if (use_BBL_EOS) then
+ do k=1,nz
+ T_vel(I,j,k) = tv%T(i+1,j,k) ; S_vel(I,j,k) = tv%S(i+1,j,k)
+ enddo
+ else
+ do k=1,nkmb
+ Rml_vel(I,j,k) = Rml(i+1,j,k)
+ enddo
+ endif
+ if (allocated(tv%SpV_avg)) then ; do k=1,nz
+ SpV_vel(I,j,k) = tv%SpV_avg(i+1,j,k)
+ enddo ; endif
endif
- 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
- do k=1,nz
- h_at_vel(i,k) = h(i,j+1,k) ; h_vel(i,k) = h(i,j+1,k)
- dz_at_vel(i,k) = dz(i,j+1,k) ; dz_vel(i,k) = dz(i,j+1,k)
- enddo
- if (use_BBL_EOS) then
+ enddo
+ else
+ do concurrent (i=is:ie, do_i(i,j) .and. (OBC%segnum_v(i,J) /= 0)) &
+ DO_LOCALITY(local(k))
+ if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N
do k=1,nz
- T_vel(i,k) = tv%T(i,j+1,k) ; S_vel(i,k) = tv%S(i,j+1,k)
+ h_at_vel(i,j,k) = h(i,j,k) ; h_vel(i,j,k) = h(i,j,k)
+ dz_at_vel(i,j,k) = dz(i,j,k) ; dz_vel(i,j,k) = dz(i,j,k)
enddo
- else
- do k=1,nkmb
- Rml_vel(i,k) = Rml(i,j+1,k)
+ if (use_BBL_EOS) then
+ do k=1,nz
+ T_vel(i,j,k) = tv%T(i,j,k) ; S_vel(i,j,k) = tv%S(i,j,k)
+ enddo
+ else
+ do k=1,nkmb
+ Rml_vel(i,j,k) = Rml(i,j,k)
+ enddo
+ endif
+ if (allocated(tv%SpV_avg)) then ; do k=1,nz
+ SpV_vel(i,j,k) = tv%SpV_avg(i,j,k)
+ enddo ; endif
+ elseif (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S
+ do k=1,nz
+ h_at_vel(i,j,k) = h(i,j+1,k) ; h_vel(i,j,k) = h(i,j+1,k)
+ dz_at_vel(i,j,k) = dz(i,j+1,k) ; dz_vel(i,j,k) = dz(i,j+1,k)
enddo
+ if (use_BBL_EOS) then
+ do k=1,nz
+ T_vel(i,j,k) = tv%T(i,j+1,k) ; S_vel(i,j,k) = tv%S(i,j+1,k)
+ enddo
+ else
+ do k=1,nkmb
+ Rml_vel(i,j,k) = Rml(i,j+1,k)
+ enddo
+ endif
+ if (allocated(tv%SpV_avg)) then ; do k=1,nz
+ SpV_vel(i,j,k) = tv%SpV_avg(i,j+1,k)
+ enddo ; endif
endif
- if (allocated(tv%SpV_avg)) then ; do k=1,nz
- SpV_vel(i,k) = tv%SpV_avg(i,j+1,k)
- enddo ; endif
- endif
+ enddo
+ endif
+ endif ; endif
+
+ ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant
+ if (CS%BBL_use_tidal_bg) then
+ do concurrent (i=is:ie, do_i(i,j)) ; if (m==1) then
+ u2_bg(I,j) = tideampfac2_x_0p5 * ( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ &
+ G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) )
+ else
+ u2_bg(i,j) = tideampfac2_x_0p5 * ( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ &
+ G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) )
endif ; enddo
+ else
+ do concurrent (i=is:ie, do_i(i,j))
+ u2_bg(i,j) = CS%drag_bg_vel * CS%drag_bg_vel
+ enddo
endif
- endif ; endif
- ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant
- if (CS%BBL_use_tidal_bg) then
- do i=is,ie ; if (do_i(i)) then ; if (m==1) then
- u2_bg(I) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ &
- G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) )
- else
- u2_bg(i) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ &
- G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) )
- endif ; endif ; enddo
- else
- do i=is,ie ; if (do_i(i)) then
- u2_bg(i) = CS%drag_bg_vel * CS%drag_bg_vel
- endif ; enddo
- endif
+ if (use_BBL_EOS .or. CS%body_force_drag .or. .not.CS%linear_drag) then
+ ! Calculate the mean velocity magnitude over the bottommost CS%Hbbl of
+ ! the water column for determining the quadratic bottom drag.
+ ! Used in ustar(i,j)
+ do concurrent (i=is:ie, do_i(i,j)) DO_LOCALITY(local(k, cdrag_sqrt)) &
+ DO_LOCALITY(local_init(cdrag_sqrt_H, cdrag_sqrt_H_RL))
+ htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0
+ dztot_vel = 0.0 ; dzwtot = 0.0
+ Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0
+
+ if (CS%bottomdragmap) then
+ if (m==1) then
+ cdrag_sqrt = sqrt(CS%cdrag_u(i,j))
+ else
+ cdrag_sqrt = sqrt(CS%cdrag_v(i,j))
+ endif
+ cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H
+ cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H
+ endif
- if (use_BBL_EOS .or. CS%body_force_drag .or. .not.CS%linear_drag) then
- ! Calculate the mean velocity magnitude over the bottommost CS%Hbbl of
- ! the water column for determining the quadratic bottom drag.
- ! Used in ustar(i)
- do i=is,ie ; if (do_i(i)) then
- htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0
- dztot_vel = 0.0 ; dzwtot = 0.0
- Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0
+ do k=nz,1,-1
+ if (htot_vel>=CS%Hbbl) exit ! terminate the k loop
- do k=nz,1,-1
+ hweight = MIN(CS%Hbbl - htot_vel, h_at_vel(i,j,k))
+ if (hweight < 1.5*GV%Angstrom_H + h_neglect) cycle
+ dzweight = MIN(CS%dz_bbl - dztot_vel, dz_at_vel(i,j,k))
- if (htot_vel>=CS%Hbbl) exit ! terminate the k loop
+ htot_vel = htot_vel + h_at_vel(i,j,k)
+ hwtot = hwtot + hweight
+ dztot_vel = dztot_vel + dz_at_vel(i,j,k)
+ dzwtot = dzwtot + dzweight
- hweight = MIN(CS%Hbbl - htot_vel, h_at_vel(i,k))
- if (hweight < 1.5*GV%Angstrom_H + h_neglect) cycle
- dzweight = MIN(CS%dz_bbl - dztot_vel, dz_at_vel(i,k))
+ if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then
+ v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC)
+ hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + u2_bg(I,j))
+ else
+ u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC)
+ hutot = hutot + hweight * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + u2_bg(i,j))
+ endif ; endif
- htot_vel = htot_vel + h_at_vel(i,k)
- hwtot = hwtot + hweight
- dztot_vel = dztot_vel + dz_at_vel(i,k)
- dzwtot = dzwtot + dzweight
+ if (use_BBL_EOS .and. (hweight >= 0.0)) then
+ Thtot = Thtot + hweight * T_vel(i,j,k)
+ Shtot = Shtot + hweight * S_vel(i,j,k)
+ endif
+ if (allocated(tv%SpV_avg) .and. (hweight >= 0.0)) then
+ SpV_htot = SpV_htot + hweight * SpV_vel(i,j,k)
+ endif
+ enddo ! end of k loop
+
+ ! Find the Adcroft reciprocal of the total thickness weights
+ I_hwtot = 0.0 ; if (hwtot > 0.0) I_hwtot = 1.0 / hwtot
+
+ ! Set u* based on u*^2 = Cdrag u_bbl^2
+ if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then
+ ustar(i,j) = cdrag_sqrt_H * CS%drag_bg_vel
+ elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then
+ ustar(i,j) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot)
+ elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag)
+ ustar(i,j) = cdrag_sqrt_H_RL * hutot / SpV_htot
+ else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg))
+ ustar(i,j) = cdrag_sqrt_H * hutot / hwtot
+ endif
- if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then
- v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC)
- hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + u2_bg(I))
+ umag_avg(i,j) = hutot * I_hwtot
+ h_bbl_drag(i,j) = hwtot
+ dz_bbl_drag(i,j) = dzwtot
+
+ if (use_BBL_EOS) then ; if (hwtot > 0.0) then
+ T_EOS(i,j) = Thtot/hwtot ; S_EOS(i,j) = Shtot/hwtot
else
- u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC)
- hutot = hutot + hweight * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + u2_bg(i))
+ T_EOS(i,j) = 0.0 ; S_EOS(i,j) = 0.0
endif ; endif
- if (use_BBL_EOS .and. (hweight >= 0.0)) then
- Thtot = Thtot + hweight * T_vel(i,k)
- Shtot = Shtot + hweight * S_vel(i,k)
+ ! Diagnostic BBL flow speed at u- and v-points.
+ if (CS%id_bbl_u>0 .and. m==1) then
+ if (hwtot > 0.0) CS%bbl_u(I,j) = hutot/hwtot
+ elseif (CS%id_bbl_v>0 .and. m==2) then
+ if (hwtot > 0.0) CS%bbl_v(i,J) = hutot/hwtot
endif
- if (allocated(tv%SpV_avg) .and. (hweight >= 0.0)) then
- SpV_htot = SpV_htot + hweight * SpV_vel(i,k)
+ enddo
+ else
+ do concurrent (i=is:ie) DO_LOCALITY(local(cdrag_sqrt)) &
+ DO_LOCALITY(local_init(cdrag_sqrt_H))
+ if (CS%bottomdragmap) then
+ if (m==1) then
+ cdrag_sqrt = sqrt(CS%cdrag_u(i,j))
+ else
+ cdrag_sqrt = sqrt(CS%cdrag_v(i,j))
+ endif
+ cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H
endif
- enddo ! end of k loop
-
- ! Find the Adcroft reciprocal of the total thickness weights
- I_hwtot = 0.0 ; if (hwtot > 0.0) I_hwtot = 1.0 / hwtot
-
- ! Set u* based on u*^2 = Cdrag u_bbl^2
- if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then
- ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel
- elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then
- ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot)
- elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag)
- ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot
- else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg))
- ustar(i) = cdrag_sqrt_H * hutot / hwtot
- endif
-
- umag_avg(i) = hutot * I_hwtot
- h_bbl_drag(i) = hwtot
- dz_bbl_drag(i) = dzwtot
+ ustar(i,j) = cdrag_sqrt_H * CS%drag_bg_vel
+ enddo
+ endif ! Not linear_drag
- if (use_BBL_EOS) then ; if (hwtot > 0.0) then
- T_EOS(i) = Thtot/hwtot ; S_EOS(i) = Shtot/hwtot
+ if (use_BBL_EOS) then
+ if (associated(tv%p_surf)) then
+ if (m==1) then ; do concurrent (i=is:ie) ; press(I,j) = 0.5*(tv%p_surf(i,j) + tv%p_surf(i+1,j)) ; enddo
+ else ; do concurrent (i=is:ie) ; press(i,j) = 0.5*(tv%p_surf(i,j) + tv%p_surf(i,j+1)) ; enddo ; endif
else
- T_EOS(i) = 0.0 ; S_EOS(i) = 0.0
- endif ; endif
-
- ! Diagnostic BBL flow speed at u- and v-points.
- if (CS%id_bbl_u>0 .and. m==1) then
- if (hwtot > 0.0) CS%bbl_u(I,j) = hutot/hwtot
- elseif (CS%id_bbl_v>0 .and. m==2) then
- if (hwtot > 0.0) CS%bbl_v(i,J) = hutot/hwtot
+ do concurrent (i=is:ie) ; press(i,j) = 0.0 ; enddo
endif
- endif ; enddo
- else
- do i=is,ie ; ustar(i) = cdrag_sqrt_H*CS%drag_bg_vel ; enddo
- endif ! Not linear_drag
+ do concurrent (i=is:ie, .not.do_i(i,j)) ; T_EOS(i,j) = 0.0 ; S_EOS(i,j) = 0.0 ; enddo
- if (use_BBL_EOS) then
- if (associated(tv%p_surf)) then
- if (m==1) then ; do i=is,ie ; press(I) = 0.5*(tv%p_surf(i,j) + tv%p_surf(i+1,j)) ; enddo
- else ; do i=is,ie ; press(i) = 0.5*(tv%p_surf(i,j) + tv%p_surf(i,j+1)) ; enddo ; endif
- else
- do i=is,ie ; press(i) = 0.0 ; enddo
+ do concurrent (k=1:nz, i=is:ie)
+ press(i,j) = press(i,j) + (GV%H_to_RZ*GV%g_Earth) * h_vel(i,j,k)
+ enddo
endif
- do i=is,ie ; if (.not.do_i(i)) then ; T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 ; endif ; enddo
- do k=1,nz ; do i=is,ie
- press(i) = press(i) + (GV%H_to_RZ*GV%g_Earth) * h_vel(i,k)
- enddo ; enddo
- call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, &
- (/is-G%IsdB+1,ie-G%IsdB+1/) )
+ enddo ! end of j loop
+
+ if (use_BBL_EOS) then
+ EOSdom(1,1) = is-G%IsdB+1 ; EOSdom(1,2) = ie-G%IsdB+1
+ EOSdom(2,1) = jstart-G%JsdB+1 ; EOSdom(2,2) = Jeq-G%JsdB+1
+ call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, EOSdom)
endif
! Find a BBL thickness given by equation 2.20 of Killworth and Edwards, 1999:
@@ -696,12 +798,32 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
! rotation (h_f) and stratification (h_N):
! ( h / h_f )^2 + ( h / h_N ) = 1
! When stratification dominates h_N< kg m-2 or kg2 m-5]
+ ustarsq = Rho0x400_G * ustar(i,j)**2 ! Note not in units of u*^2 but [H R ~> kg m-2 or kg2 m-5]
htot = 0.0
dztot = 0.0
+ if (CS%bottomdragmap) then
+ if (m==1) then
+ cdrag = CS%cdrag_u(i,j)
+ else
+ cdrag = CS%cdrag_v(i,j)
+ endif
+ cdrag_L_to_H = cdrag * US%L_to_m * GV%m_to_H
+ cdrag_RL_to_H = cdrag * US%L_to_Z * GV%RZ_to_H
+ endif
+
! Calculate the thickness of a stratification limited BBL ignoring rotation:
! h_N = Ci u* / N (limit of KW99 eq. 2.20 for |f|->0)
! For layer mode, N^2 = g'/h. Since (Ci u*)^2 = (h_N N)^2 = h_N g' then
@@ -714,57 +836,57 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
if (use_BBL_EOS) then
Thtot = 0.0 ; Shtot = 0.0 ; oldfn = 0.0
do k=nz,2,-1
- if (h_at_vel(i,k) <= 0.0) cycle
+ if (h_at_vel(i,j,k) <= 0.0) cycle
! Delta rho * h_bbl assuming everything below is homogenized
- oldfn = dR_dT(i)*(Thtot - T_vel(i,k)*htot) + &
- dR_dS(i)*(Shtot - S_vel(i,k)*htot)
+ oldfn = dR_dT(i,j)*(Thtot - T_vel(i,j,k)*htot) + &
+ dR_dS(i,j)*(Shtot - S_vel(i,j,k)*htot)
if (oldfn >= ustarsq) exit
! Local Delta rho * h_bbl at interface
- Dfn = (dR_dT(i)*(T_vel(i,k) - T_vel(i,k-1)) + &
- dR_dS(i)*(S_vel(i,k) - S_vel(i,k-1))) * &
- (h_at_vel(i,k) + htot)
+ Dfn = (dR_dT(i,j)*(T_vel(i,j,k) - T_vel(i,j,k-1)) + &
+ dR_dS(i,j)*(S_vel(i,j,k) - S_vel(i,j,k-1))) * &
+ (h_at_vel(i,j,k) + htot)
if ((oldfn + Dfn) <= ustarsq) then
! Use whole layer
- Dh = h_at_vel(i,k)
- Ddz = dz_at_vel(i,k)
+ Dh = h_at_vel(i,j,k)
+ Ddz = dz_at_vel(i,j,k)
else
! Use only part of the layer
frac_used = sqrt((ustarsq-oldfn) / (Dfn))
- Dh = h_at_vel(i,k) * frac_used
- Ddz = dz_at_vel(i,k) * frac_used
+ Dh = h_at_vel(i,j,k) * frac_used
+ Ddz = dz_at_vel(i,j,k) * frac_used
endif
! Increment total BBL thickness and cumulative T and S
htot = htot + Dh
dztot = dztot + Ddz
- Thtot = Thtot + T_vel(i,k)*Dh ; Shtot = Shtot + S_vel(i,k)*Dh
+ Thtot = Thtot + T_vel(i,j,k)*Dh ; Shtot = Shtot + S_vel(i,j,k)*Dh
enddo
- if ((oldfn < ustarsq) .and. h_at_vel(i,1) > 0.0) then
+ if ((oldfn < ustarsq) .and. h_at_vel(i,j,1) > 0.0) then
! Layer 1 might be part of the BBL.
- if (dR_dT(i) * (Thtot - T_vel(i,1)*htot) + &
- dR_dS(i) * (Shtot - S_vel(i,1)*htot) < ustarsq) then
- htot = htot + h_at_vel(i,1)
- dztot = dztot + dz_at_vel(i,1)
+ if (dR_dT(i,j) * (Thtot - T_vel(i,j,1)*htot) + &
+ dR_dS(i,j) * (Shtot - S_vel(i,j,1)*htot) < ustarsq) then
+ htot = htot + h_at_vel(i,j,1)
+ dztot = dztot + dz_at_vel(i,j,1)
endif
endif ! Examination of layer 1.
else ! Use Rlay and/or the coordinate density as density variables.
Rhtot = 0.0
do k=nz,K2,-1
oldfn = Rhtot - GV%Rlay(k)*htot
- Dfn = (GV%Rlay(k) - GV%Rlay(k-1))*(h_at_vel(i,k)+htot)
+ Dfn = (GV%Rlay(k) - GV%Rlay(k-1))*(h_at_vel(i,j,k)+htot)
if (oldfn >= ustarsq) then
cycle
elseif ((oldfn + Dfn) <= ustarsq) then
- Dh = h_at_vel(i,k)
- Ddz = dz_at_vel(i,k)
+ Dh = h_at_vel(i,j,k)
+ Ddz = dz_at_vel(i,j,k)
else
frac_used = sqrt((ustarsq-oldfn) / (Dfn))
- Dh = h_at_vel(i,k) * frac_used
- Ddz = dz_at_vel(i,k) * frac_used
+ Dh = h_at_vel(i,j,k) * frac_used
+ Ddz = dz_at_vel(i,j,k) * frac_used
endif
htot = htot + Dh
@@ -773,32 +895,32 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
enddo
if (nkml>0) then
do k=nkmb,2,-1
- oldfn = Rhtot - Rml_vel(i,k)*htot
- Dfn = (Rml_vel(i,k) - Rml_vel(i,k-1)) * (h_at_vel(i,k)+htot)
+ oldfn = Rhtot - Rml_vel(i,j,k)*htot
+ Dfn = (Rml_vel(i,j,k) - Rml_vel(i,j,k-1)) * (h_at_vel(i,j,k)+htot)
if (oldfn >= ustarsq) then
cycle
elseif ((oldfn + Dfn) <= ustarsq) then
- Dh = h_at_vel(i,k)
- Ddz = dz_at_vel(i,k)
+ Dh = h_at_vel(i,j,k)
+ Ddz = dz_at_vel(i,j,k)
else
frac_used = sqrt((ustarsq-oldfn) / (Dfn))
- Dh = h_at_vel(i,k) * frac_used
- Ddz = dz_at_vel(i,k) * frac_used
+ Dh = h_at_vel(i,j,k) * frac_used
+ Ddz = dz_at_vel(i,j,k) * frac_used
endif
htot = htot + Dh
dztot = dztot + Ddz
- Rhtot = Rhtot + Rml_vel(i,k)*Dh
+ Rhtot = Rhtot + Rml_vel(i,j,k)*Dh
enddo
- if (Rhtot - Rml_vel(i,1)*htot < ustarsq) then
- htot = htot + h_at_vel(i,1)
- dztot = dztot + dz_at_vel(i,1)
+ if (Rhtot - Rml_vel(i,j,1)*htot < ustarsq) then
+ htot = htot + h_at_vel(i,j,1)
+ dztot = dztot + dz_at_vel(i,j,1)
endif
else
if (Rhtot - GV%Rlay(1)*htot < ustarsq) then
- htot = htot + h_at_vel(i,1)
- dztot = dztot + dz_at_vel(i,1)
+ htot = htot + h_at_vel(i,j,1)
+ dztot = dztot + dz_at_vel(i,j,1)
endif
endif
endif ! use_BBL_EOS
@@ -818,10 +940,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
! xp = 1/2 + sqrt( 1/4 + (2 f h_N/u*)^2 )
! To avoid dividing by zero if u*=0 then
! xp u* = 1/2 u* + sqrt( 1/4 u*^2 + (2 f h_N)^2 )
- if (CS%cdrag * u2_bg(i) <= 0.0) then
+ if (CS%cdrag * u2_bg(i,j) <= 0.0) then
! This avoids NaNs and overflows, and could be used in all cases,
! but is not bitwise identical to the current code.
- ustH = ustar(i) ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2)
+ ustH = ustar(i,j) ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2)
if (dztot*ustH <= (CS%BBL_thick_min+dz_neglect) * (0.5*ustH + root)) then
bbl_thick = CS%BBL_thick_min
else
@@ -834,7 +956,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
! The following expression reads
! h_bbl = h_N / ( 1/2 + sqrt( 1/4 + ( 2 f h_N / u* )^2 ) )
! which is h_bbl = h_N/xp as described above.
- bbl_thick = dztot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f / (ustar(i)*ustar(i)) ) )
+ bbl_thick = dztot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f / (ustar(i,j)*ustar(i,j)) ) )
if (bbl_thick < CS%BBL_thick_min) bbl_thick = CS%BBL_thick_min
endif
@@ -852,28 +974,38 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
if ((bbl_thick > 0.5*CS%dz_bbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%dz_bbl
! If drag is a body force, bbl_thick is HBBL
- if (CS%body_force_drag) bbl_thick = dz_bbl_drag(i)
+ if (CS%body_force_drag) bbl_thick = dz_bbl_drag(i,j)
if (CS%Channel_drag) then
vol_below(nz+1) = 0.0
do K=nz,1,-1
- vol_below(K) = vol_below(K+1) + dz_vel(i,k)
+ vol_below(K) = vol_below(K+1) + dz_vel(i,j,k)
enddo
- !### The harmonic mean edge depths here are not invariant to offsets!
+ ! Find the bathymetry at adjacent points relative to the shelf break. For now this
+ ! shelf break depth is set with a global constant, but it could vary in space.
if (m==1) then
- D_vel = D_u(I,j)
- tmp = G%mask2dCu(I,j+1) * D_u(I,j+1)
- Dp = 2.0 * D_vel * tmp / (D_vel + tmp)
- tmp = G%mask2dCu(I,j-1) * D_u(I,j-1)
- Dm = 2.0 * D_vel * tmp / (D_vel + tmp)
+ D_vel = D_u(I,j) - CS%channel_break_depth
+ D_vel_p = G%mask2dCu(I,j+1) * (D_u(I,j+1) - CS%channel_break_depth)
+ D_vel_m = G%mask2dCu(I,j-1) * (D_u(I,j-1) - CS%channel_break_depth)
else
- D_vel = D_v(i,J)
- tmp = G%mask2dCv(i+1,J) * D_v(i+1,J)
- Dp = 2.0 * D_vel * tmp / (D_vel + tmp)
- tmp = G%mask2dCv(i-1,J) * D_v(i-1,J)
- Dm = 2.0 * D_vel * tmp / (D_vel + tmp)
+ D_vel = D_v(i,J) - CS%channel_break_depth
+ D_vel_p = G%mask2dCv(i+1,J) * (D_v(i+1,J) - CS%channel_break_depth)
+ D_vel_m = G%mask2dCv(i-1,J) * (D_v(i-1,J) - CS%channel_break_depth)
+ endif
+ ! This profile uses a harmonic mean bottom depth below some reference value to
+ ! roughly mimic the topographic shape at and beneath a continental shelf break.
+ ! Above this a simple arithmetic mean is used.
+ if ((D_vel > 0.0) .and. (D_vel_p > 0.0)) then
+ Dp = 2.0 * D_vel * D_vel_p / (D_vel + D_vel_p)
+ else ! This is above the shelf-break, noting that D is positive downward.
+ Dp = 0.5 * (min(D_vel, 0.0) + min(D_vel_p, 0.0))
+ endif
+ if ((D_vel > 0.0) .and. (D_vel_m > 0.0)) then
+ Dm = 2.0 * D_vel * D_vel_m / (D_vel + D_vel_m)
+ else ! This is above the shelf-break, noting that D is positive downward.
+ Dm = 0.5 * (min(D_vel, 0.0) + min(D_vel_m, 0.0))
endif
if (Dm > Dp) then ; tmp = Dp ; Dp = Dm ; Dm = tmp ; endif
crv = 3.0*(Dp + Dm - 2.0*D_vel)
@@ -934,7 +1066,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
do K=nz,1,-1
!modify L(K) for porous barrier parameterization
if (m==1) then ; L(K) = L(K)*pbv%por_layer_widthU(I,j,K)
- else ; L(K) = L(K)*pbv%por_layer_widthV(i,J,K); endif
+ else ; L(K) = L(K)*pbv%por_layer_widthV(i,J,K) ; endif
! Determine the drag contributing to the bottom boundary layer
! and the Rayleigh drag that acts on each layer.
@@ -947,12 +1079,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
endif
if (allocated(tv%SpV_avg)) then
- cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k)
+ cdrag_conv = cdrag_RL_to_H / SpV_vel(i,j,k)
else
cdrag_conv = cdrag_L_to_H
endif
- h_vel_pos = h_vel(i,k) + h_neglect
+ h_vel_pos = h_vel(i,j,k) + h_neglect
if (m==1) then ; Cell_width = G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)
else ; Cell_width = G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k) ; endif
gam = 1.0 - L(K+1)/L(K)
@@ -966,12 +1098,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
if (m==1) then
if (Rayleigh > 0.0) then
v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC)
- visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + u2_bg(I))
+ visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + u2_bg(I,j))
else ; visc%Ray_u(I,j,k) = 0.0 ; endif
else
if (Rayleigh > 0.0) then
u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC)
- visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + u2_bg(i))
+ visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + u2_bg(i,j))
else ; visc%Ray_v(i,J,k) = 0.0 ; endif
endif
@@ -981,18 +1113,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
! the correct stress when the shear occurs over bbl_thick.
! See next block for explanation.
if (CS%correct_BBL_bounds .and. &
- cdrag_sqrt*ustar(i)*bbl_thick*BBL_visc_frac <= CS%Kv_BBL_min) then
+ cdrag_sqrt*ustar(i,j)*bbl_thick*BBL_visc_frac <= CS%Kv_BBL_min) then
! If the bottom stress implies less viscosity than Kv_BBL_min then
! set kv_bbl to the bound and recompute bbl_thick to be consistent
! but with a ridiculously large upper bound on thickness (for Cd u*=0)
kv_bbl = CS%Kv_BBL_min
- if ((cdrag_sqrt*ustar(i))*BBL_visc_frac*BBL_thick_max > kv_bbl) then
- bbl_thick = kv_bbl / ( (cdrag_sqrt*ustar(i)) * BBL_visc_frac )
+ if ((cdrag_sqrt*ustar(i,j))*BBL_visc_frac*BBL_thick_max > kv_bbl) then
+ bbl_thick = kv_bbl / ( (cdrag_sqrt*ustar(i,j)) * BBL_visc_frac )
else
bbl_thick = BBL_thick_max
endif
else
- kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick*BBL_visc_frac
+ kv_bbl = (cdrag_sqrt*ustar(i,j)) * bbl_thick*BBL_visc_frac
endif
else ! Not Channel_drag.
@@ -1012,39 +1144,39 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
! kv_bbl = 0.5 h_bbl Cdrag u_bbl
! = 0.5 h_bbl sqrt(Cdrag) u*
if (CS%correct_BBL_bounds .and. &
- cdrag_sqrt*ustar(i)*bbl_thick <= CS%Kv_BBL_min) then
+ cdrag_sqrt*ustar(i,j)*bbl_thick <= CS%Kv_BBL_min) then
! If the bottom stress implies less viscosity than Kv_BBL_min then
! set kv_bbl to the bound and recompute bbl_thick to be consistent
! but with a ridiculously large upper bound on thickness (for Cd u*=0)
kv_bbl = CS%Kv_BBL_min
- if ((cdrag_sqrt*ustar(i))*BBL_thick_max > kv_bbl) then
- bbl_thick = kv_bbl / ( cdrag_sqrt*ustar(i) )
+ if ((cdrag_sqrt*ustar(i,j))*BBL_thick_max > kv_bbl) then
+ bbl_thick = kv_bbl / ( cdrag_sqrt*ustar(i,j) )
else
bbl_thick = BBL_thick_max
endif
else
- kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick
+ kv_bbl = (cdrag_sqrt*ustar(i,j)) * bbl_thick
endif
endif
- if (CS%body_force_drag) then ; if (h_bbl_drag(i) > 0.0) then
+ if (CS%body_force_drag) then ; if (h_bbl_drag(i,j) > 0.0) then
! Increment the Rayleigh drag as a way introduce the bottom drag as a body force.
h_sum = 0.0
- I_hwtot = 1.0 / h_bbl_drag(i)
+ I_hwtot = 1.0 / h_bbl_drag(i,j)
do k=nz,1,-1
- h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot
+ h_bbl_fr = min(h_bbl_drag(i,j) - h_sum, h_at_vel(i,j,k)) * I_hwtot
if (allocated(tv%SpV_avg)) then
- cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k)
+ cdrag_conv = cdrag_RL_to_H / SpV_vel(i,j,k)
else
cdrag_conv = cdrag_L_to_H
endif
if (m==1) then
- visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (cdrag_conv * umag_avg(I)) * h_bbl_fr
+ visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (cdrag_conv * umag_avg(I,j)) * h_bbl_fr
else
- visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (cdrag_conv * umag_avg(i)) * h_bbl_fr
+ visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (cdrag_conv * umag_avg(i,j)) * h_bbl_fr
endif
- h_sum = h_sum + h_at_vel(i,k)
- if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone.
+ h_sum = h_sum + h_at_vel(i,j,k)
+ if (h_sum >= h_bbl_drag(i,j)) exit ! The top of this layer is above the drag zone.
enddo
! Do not enhance the near-bottom viscosity in this case.
Kv_bbl = CS%Kv_BBL_min
@@ -1058,8 +1190,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
visc%bbl_thick_v(i,J) = bbl_thick
if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = kv_bbl
endif
- endif ; enddo ! end of i loop
- enddo ; enddo ! end of m & j loops
+ endif ; enddo ; enddo ! end of i & j loops
+ enddo ! end of m loop
+
+ !$omp target exit data map(release: dz, tv, tv%T, tv%S, S_vel, T_vel, SpV_vel, h_vel, h_at_vel, &
+ !$omp dz_vel, dz_at_vel, Rml, Rml_vel, p_ref, ustar, umag_avg, u2_bg, mask_u, mask_v, &
+ !$omp h_bbl_drag, dz_bbl_drag, do_i, dR_dS, dR_dT, D_u, D_v, press, S_EOS, T_EOS, tv%p_surf, CS)
! Offer diagnostics for averaging
if (CS%id_bbl_thick_u > 0) &
@@ -1080,22 +1216,27 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv)
call post_data(CS%id_Ray_v, visc%Ray_v, CS%diag)
if (CS%debug) then
- if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) &
- call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, &
- unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.)
- if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) &
- call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, &
- haloshift=0, unscale=GV%HZ_T_to_m2_s, scalar_pair=.true.)
- if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) &
- call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, &
- G%HI, haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.)
+ if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) then
+ !$omp target update from(visc%Ray_u, visc%Ray_v)
+ call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, &
+ unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.)
+ endif
+ if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then
+ !$omp target update from(visc%Kv_bbl_u, visc%Kv_bbl_v)
+ call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, &
+ haloshift=0, unscale=GV%HZ_T_to_m2_s, scalar_pair=.true.)
+ endif
+ if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) then
+ !$omp target update from(visc%bbl_thick_u, visc%bbl_thick_v)
+ call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, &
+ G%HI, haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.)
+ endif
endif
-
end subroutine set_viscous_BBL
!> Determine the normalized open length of each interface, given the edge depths and normalized
!! volumes below each interface.
-subroutine find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV)
+pure subroutine find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV)
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by
!! the full horizontal area of a velocity cell [Z ~> m]
@@ -1105,12 +1246,14 @@ subroutine find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV)
!! of a velocity cell [Z ~> m]
real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at
!! the depth of each interface [nondim]
+ !$omp declare target
! Local variables
real :: slope ! The absolute value of the bottom depth slope across a cell times the cell width [Z ~> m].
real :: I_slope ! The inverse of the normalized slope [Z-1 ~> m-1]
real :: Vol_open ! The cell volume above which it is open [Z ~> m].
integer :: K, nz
+ !$omp declare target
nz = GV%ke
@@ -1135,7 +1278,7 @@ end subroutine find_L_open_uniform_slope
!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective)
!! using trigonometric expressions. In this case there can be two separate open regions.
-subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV)
+pure subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV)
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by
!! the full horizontal area of a velocity cell [Z ~> m]
@@ -1146,6 +1289,7 @@ subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV)
!! of a velocity cell [Z ~> m]
real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at
!! the depth of each interface [nondim]
+ !$omp declare target
! Local variables
real :: crv ! crv is the curvature of the bottom depth across a
@@ -1167,6 +1311,7 @@ subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV)
real, parameter :: C1_3 = 1.0/3.0, C1_12 = 1.0/12.0 ! Rational constants [nondim]
real, parameter :: C2pi_3 = 8.0*atan(1.0)/3.0 ! An irrational constant, 2/3 pi. [nondim]
integer :: K, nz
+ !$omp declare target
nz = GV%ke
@@ -1228,7 +1373,7 @@ end subroutine find_L_open_concave_trigonometric
!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) using
!! iterative methods to solve the relevant cubic equations. In this case there can be two separate open regions.
-subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV)
+pure subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV)
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by
!! the full horizontal area of a velocity cell [Z ~> m]
@@ -1239,6 +1384,7 @@ subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV)
!! of a velocity cell [Z ~> m]
real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at
!! the depth of each interface [nondim]
+ !$omp declare target
! Local variables
real :: crv ! crv is the curvature of the bottom depth across a
@@ -1287,6 +1433,7 @@ subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV)
real, parameter :: C1_3 = 1.0 / 3.0, C1_12 = 1.0 / 12.0 ! Rational constants [nondim]
integer :: K, nz, itt
integer, parameter :: max_itt = 10
+ !$omp declare target
nz = GV%ke
@@ -1553,7 +1700,7 @@ end subroutine find_L_open_concave_iterative
!> Test the validity the normalized open lengths of each interface for concave bathymetry (from the ocean perspective)
!! by evaluating and returing the relevant cubic equations.
-subroutine test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err, GV)
+pure subroutine test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err, GV)
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by
!! the full horizontal area of a velocity cell [Z ~> m]
@@ -1566,6 +1713,7 @@ subroutine test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err, GV)
!! the depth of each interface [nondim]
real, dimension(SZK_(GV)+1), intent(out) :: vol_err !< The difference between vol_below and the
!! value obtained from using L in the cubic equation [Z ~> m]
+ !$omp declare target
! Local variables
real :: crv ! crv is the curvature of the bottom depth across a
@@ -1589,6 +1737,7 @@ subroutine test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err, GV)
real, parameter :: C1_3 = 1.0 / 3.0, C1_12 = 1.0 / 12.0 ! Rational constants [nondim]
integer :: K, nz
+ !$omp declare target
nz = GV%ke
@@ -1634,7 +1783,7 @@ end subroutine test_L_open_concave
!> Determine the normalized open length of each interface for convex bathymetry (from the ocean
!! perspective) using Newton's method iterations. In this case there is a single open region
!! with the minimum depth at one edge of the cell.
-subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS)
+pure subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS)
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by
!! the full horizontal area of a velocity cell [Z ~> m]
@@ -1648,6 +1797,7 @@ subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS)
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(set_visc_CS), intent(in) :: CS !< The control structure returned by a previous
!! call to set_visc_init.
+ !$omp declare target
! Local variables
real :: crv ! crv is the curvature of the bottom depth across a
@@ -1679,7 +1829,9 @@ subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS)
! accuracy of a single L(:) Newton iteration [Z5 ~> m5]
real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0 ! Rational constants [nondim]
logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration
- integer :: K, nz, itt, maxitt=20
+ integer :: K, nz, itt
+ integer, parameter:: maxitt = 20
+ !$omp declare target
nz = GV%ke
@@ -1795,7 +1947,7 @@ subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS)
end subroutine find_L_open_convex
!> This subroutine finds a thickness-weighted value of v at the u-points.
-function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC)
+pure function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure
real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
@@ -1810,6 +1962,7 @@ function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC)
type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure
real :: set_v_at_u !< The return value of v at u points points in the
!! same units as u, i.e. [L T-1 ~> m s-1] or other units.
+ !$omp declare target
! This subroutine finds a thickness-weighted value of v at the u-points.
real :: hwt(0:1,-1:0) ! Masked weights used to average u onto v [H ~> m or kg m-2].
@@ -1821,11 +1974,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
@@ -1840,7 +1993,7 @@ function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC)
end function set_v_at_u
!> This subroutine finds a thickness-weighted value of u at the v-points.
-function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC)
+pure function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure
real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
@@ -1855,6 +2008,7 @@ function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC)
type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure
real :: set_u_at_v !< The return value of u at v points in the
!! same units as u, i.e. [L T-1 ~> m s-1] or other units.
+ !$omp declare target
! This subroutine finds a thickness-weighted value of u at the v-points.
real :: hwt(-1:0,0:1) ! Masked weights used to average u onto v [H ~> m or kg m-2].
@@ -1866,11 +2020,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
@@ -1919,7 +2073,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
! surface mixed layer [H C ~> m degC or kg degC m-2].
Shtot, & ! The integrated salt of layers that are within the
! surface mixed layer [H S ~> m ppt or kg ppt m-2].
- SpV_htot, & ! Running sum of thickness times specific volume [R-1 H ~> m4 kg-1 or m]
+ SpV_htot, & ! Running sum of thickness times specific volume [H R-1 ~> m4 kg-1 or m]
Rhtot, & ! The integrated density of layers that are within the surface mixed layer
! [H R ~> kg m-2 or kg2 m-5]. Rhtot is only used if no
! equation of state is used.
@@ -2034,9 +2188,14 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(visc_ML): "//&
"Module must be initialized before it is used.")
+ ! TODO: Remove this check and move it outside of the function call.
if (.not.(CS%dynamic_viscous_ML .or. associated(forces%frac_shelf_u) .or. &
associated(forces%frac_shelf_v)) ) return
+ ! NOTE: Requried since this is called by the GPU-enabled dycore, but it could
+ ! also be implicitly fixing other functions.
+ !$omp target update from(u, v)
+
Rho0x400_G = 400.0*(GV%H_to_RZ / GV%g_Earth_Z_T2)
cdrag_sqrt = sqrt(CS%cdrag)
cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H
@@ -2091,8 +2250,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 +2259,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
@@ -2310,7 +2468,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
ustarsq = Rho0x400_G * ustar(i)**2
htot(i) = 0.0 ; dztot(i) = 0.0
if (use_EOS) then
- Thtot(i) = 0.0 ; Shtot(i) = 0.0
+ Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; oldfn = 0.0
do k=1,nz-1
if (h_at_vel(i,k) <= 0.0) cycle
T_Lay = 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k))
@@ -2498,6 +2656,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
if (do_any) then ; do i=is,ie ; if (do_i(i)) then
visc%nkml_visc_v(i,J) = k_massive(i)
endif ; enddo ; endif
+
endif ! dynamic_viscous_ML
do_any_shelf = .false.
@@ -2589,7 +2748,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
htot(i) = 0.0
dztot(i) = 0.0
if (use_EOS) then
- Thtot(i) = 0.0 ; Shtot(i) = 0.0
+ Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; oldfn = 0.0
do k=1,nz-1
if (h_at_vel(i,k) <= 0.0) cycle
T_Lay = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k))
@@ -2666,6 +2825,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS)
enddo ! J-loop at v-points
+ !$omp target update to(visc%nkml_visc_u, visc%nkml_visc_v) if (CS%dynamic_viscous_ML)
+
if (CS%debug) then
if (allocated(visc%nkml_visc_u) .and. allocated(visc%nkml_visc_v)) &
call uvchksum("nkml_visc_[uv]", visc%nkml_visc_u, visc%nkml_visc_v, &
@@ -2737,6 +2898,8 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C
if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. &
(use_kappa_shear .and. .not.KS_at_vertex )) then
call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1)
+ !$omp target enter data map(alloc: visc%Kv_shear)
+
call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, &
"Shear-driven turbulent viscosity at interfaces", &
units=Kv_units, conversion=GV%HZ_T_to_MKS, z_grid='i')
@@ -2879,8 +3042,15 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
! is used in place of the absolute value of the local Coriolis
! parameter in the denominator of some expressions [nondim]
real :: Chan_max_thick_dflt ! The default value for CHANNEL_DRAG_MAX_THICK [Z ~> m]
-
- integer :: i, j, k, is, ie, js, je
+ real :: tideamp_factor ! A factor to multiply by tideamp when converting to mean tidal magnitude [nondim]
+ real :: shelfbreak_depth ! When CHANNEL_DRAG is true, the bathymetric depth interpolated
+ ! to the vorticity point is a combination of the harmonic mean of the
+ ! adjacent velocity point depths below this depth [Z ~> m] and the
+ ! arithmetic mean of the adjacent depths above it, to roughly mimic a
+ ! continental shelf break profile.
+ real, allocatable, dimension(:,:) :: cdrag_h !< The spatially varying quadratic drag coefficient [nondim]
+
+ integer :: i, j, is, ie, js, je
integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz
integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags.
logical :: adiabatic, use_omega, MLE_use_PBL_MLD
@@ -2889,8 +3059,8 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
! isopycnal or stacked shallow water mode.
logical :: use_temperature ! If true, temperature and salinity are used as state variables.
logical :: use_EOS ! If true, density calculated from T & S using an equation of state.
- character(len=200) :: filename, tideamp_file ! Input file names or paths
- character(len=80) :: tideamp_var ! Input file variable names
+ character(len=200) :: filename, cdrag_file, tideamp_file ! Input file names or paths
+ character(len=80) :: cdrag_var, tideamp_var ! Input file variable names
! This include declares and sets the variable "version".
# include "version_variable.h"
character(len=40) :: mdl = "MOM_set_visc" ! This module's name.
@@ -2932,8 +3102,18 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
default=.false., do_not_log=.not.CS%bottomdraglaw)
call get_param(param_file, mdl, "CHANNEL_DRAG", CS%Channel_drag, &
"If true, the bottom drag is exerted directly on each "//&
- "layer proportional to the fraction of the bottom it "//&
- "overlies.", default=.false.)
+ "layer proportional to the fraction of the bottom it overlies.", &
+ default=.false.)
+ call get_param(param_file, mdl, "CHANNEL_DRAG_SHELFBREAK_DEPTH", shelfbreak_depth, &
+ "When CHANNEL_DRAG is true, the bathymetric depth interpolated to the "//&
+ "vorticity point is a combination of the harmonic mean of the adjacent "//&
+ "velocity point depths below this depth and the arithmetic mean of the "//&
+ "depths above it, to roughly mimic a continental shelf break profile. "//&
+ "Setting this to exceed MAXIMUM_DEPTH leads to linear interpolation of "//&
+ "the topography between velocity points.", &
+ default=0.0, units="m", scale=US%m_to_Z, do_not_log=.not.CS%Channel_drag)
+ CS%channel_break_depth = shelfbreak_depth - G%Z_ref
+
call get_param(param_file, mdl, "LINEAR_DRAG", CS%linear_drag, &
"If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag "//&
"law is cdrag*DRAG_BG_VEL*u.", default=.false.)
@@ -3006,6 +3186,16 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
"CDRAG is the drag coefficient relating the magnitude of "//&
"the velocity field to the bottom stress. CDRAG is only "//&
"used if BOTTOMDRAGLAW is defined.", units="nondim", default=0.003)
+ call get_param(param_file, mdl, "CDRAG_MAP", CS%bottomdragmap, &
+ "If true, apply a spatially varying scaling factor to CDRAG, "//&
+ "specified by CDRAG_VAR in CDRAG_FILE.", default=.false.)
+ call get_param(param_file, mdl, "CDRAG_FILE", cdrag_file, &
+ "The name of the file with the spatially varying bottom drag "//&
+ "scaling factor.", default="", do_not_log=.not.CS%bottomdragmap)
+ call get_param(param_file, mdl, "CDRAG_VAR", cdrag_var, &
+ "The name of the variable in CDRAG_FILE with the spatially "//&
+ "varying bottom drag scaling factor at h points.", &
+ default="", do_not_log=.not.CS%bottomdragmap)
call get_param(param_file, mdl, "BBL_USE_TIDAL_BG", CS%BBL_use_tidal_bg, &
"Flag to use the tidal RMS amplitude in place of constant "//&
"background velocity for computing u* in the BBL. "//&
@@ -3023,6 +3213,17 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
! nor dimensional testing in this mode. If we ever detect a dimensional sensitivity to
! this parameter, in this mode, then it means it is being used inappropriately.
CS%drag_bg_vel = 1.e30
+ call get_param(param_file, mdl, "TIDEAMP_FACTOR", tideamp_factor, &
+ "A parameter to multiply by tideamp when converting to ustar. "//&
+ "It accounts for converting the amplitude to a mean magintude (approx 1/sqrt(2)) "//&
+ "and possibly also for non-commuting averaging operators when converting to ustar**3. "//&
+ "It is ignored if negative and uncapped so it can be greater than 1 if desired.",&
+ units="nondim", default=-1.0)
+ if (tideamp_factor < 0.0) then
+ CS%tideampfac2 = 1.0
+ else
+ CS%tideampfac2 = tideamp_factor*tideamp_factor
+ endif
else
call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, &
"DRAG_BG_VEL is either the assumed bottom velocity (with "//&
@@ -3119,6 +3320,8 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
CS%Hbbl = CS%dz_bbl * (US%Z_to_m * GV%m_to_H) ! Rescaled for use in expressions in thickness units.
+ !$omp target update to(CS)
+
if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then
! This is necessary for reproducibility across restarts in non-symmetric mode.
call pass_var(visc%Kv_shear_Bu, G%Domain, position=CORNER, complete=.true.)
@@ -3127,8 +3330,10 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
if (CS%bottomdraglaw) then
allocate(visc%bbl_thick_u(IsdB:IedB,jsd:jed), source=0.0)
allocate(visc%bbl_thick_v(isd:ied,JsdB:JedB), source=0.0)
+ !$omp target enter data map(to: visc%bbl_thick_u, visc%bbl_thick_v)
allocate(visc%kv_bbl_u(IsdB:IedB,jsd:jed), source=0.0)
allocate(visc%kv_bbl_v(isd:ied,JsdB:JedB), source=0.0)
+ !$omp target enter data map(to: visc%kv_bbl_u, visc%kv_bbl_v)
allocate(visc%ustar_bbl(isd:ied,jsd:jed), source=0.0)
allocate(visc%BBL_meanKE_loss(isd:ied,jsd:jed), source=0.0)
allocate(visc%BBL_meanKE_loss_sqrtCd(isd:ied,jsd:jed), source=0.0)
@@ -3151,6 +3356,27 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
if (CS%id_bbl_v>0) then
allocate(CS%bbl_v(isd:ied,JsdB:JedB), source=0.0)
endif
+ if (CS%bottomdragmap) then
+ if (len_trim(cdrag_file)==0 .or. len_trim(cdrag_var)==0) then
+ call MOM_error(FATAL,"CDRAG_FILE and CDRAG_VAR are required when using CDRAG_MAP.")
+ endif
+ allocate(cdrag_h(isd:ied,jsd:jed), source=0.0)
+ allocate(CS%cdrag_u(IsdB:IedB,jsd:jed), source=0.0)
+ allocate(CS%cdrag_v(isd:ied,JsdB:JedB), source=0.0)
+ filename = trim(CS%inputdir) // trim(cdrag_file)
+ call log_param(param_file, mdl, "INPUTDIR/CDRAG_FILE", filename)
+ call MOM_read_data(filename, cdrag_var, cdrag_h, G%domain, scale=CS%cdrag)
+ call pass_var(cdrag_h, G%domain)
+ do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0) then
+ CS%cdrag_u(I,j) = (G%mask2dT(i,j) * cdrag_h(i,j) + G%mask2dT(i+1,j) * cdrag_h(i+1,j)) / &
+ (G%mask2dT(i,j) + G%mask2dT(i+1,j))
+ endif ; enddo ; enddo
+ do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0) then
+ CS%cdrag_v(i,J) = (G%mask2dT(i,j) * cdrag_h(i,j) + G%mask2dT(i,j+1) * cdrag_h(i,j+1)) / &
+ (G%mask2dT(i,j) + G%mask2dT(i,j+1))
+ endif ; enddo ; enddo
+ deallocate(cdrag_h)
+ endif
if (CS%BBL_use_tidal_bg) then
allocate(CS%tideamp(isd:ied,jsd:jed), source=0.0)
filename = trim(CS%inputdir) // trim(tideamp_file)
@@ -3172,6 +3398,8 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS
if (CS%dynamic_viscous_ML) then
allocate(visc%nkml_visc_u(IsdB:IedB,jsd:jed), source=0.0)
allocate(visc%nkml_visc_v(isd:ied,JsdB:JedB), source=0.0)
+ !$omp target enter data map(to: visc%nkml_visc_u, visc%nkml_visc_v)
+
CS%id_nkml_visc_u = register_diag_field('ocean_model', 'nkml_visc_u', &
diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'nondim')
CS%id_nkml_visc_v = register_diag_field('ocean_model', 'nkml_visc_v', &
diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90
index 4bdf610a24..f91eeac4f2 100644
--- a/src/parameterizations/vertical/MOM_sponge.F90
+++ b/src/parameterizations/vertical/MOM_sponge.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Implements sponge regions in isopycnal mode
module MOM_sponge
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : sum_across_PEs
use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field
use MOM_diag_mediator, only : diag_ctrl
@@ -222,7 +224,7 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean)
CS%fldno = CS%fldno + 1
if (CS%fldno > MAX_FIELDS_) then
- write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease &
+ write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease &
&the number of fields to be damped in the call to &
&initialize_sponge." )') CS%fldno
call MOM_error(FATAL,"set_up_sponge_field: "//mesg)
@@ -241,8 +243,8 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean)
CS%var(CS%fldno)%p => f_ptr
if (nlay/=CS%nz) then
- write(mesg,'("Danger: Sponge reference fields require nz (",I3,") layers.&
- & A field with ",I3," layers was passed to set_up_sponge_field.")') &
+ write(mesg,'("Danger: Sponge reference fields require nz (",I0,") layers.&
+ & A field with ",I0," layers was passed to set_up_sponge_field.")') &
CS%nz, nlay
if (is_root_pe()) call MOM_error(WARNING, "set_up_sponge_field: "//mesg)
endif
@@ -518,7 +520,7 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml)
enddo
enddo
- wpb = 0.0; wb = 0.0
+ wpb = 0.0 ; wb = 0.0
do k=nz,nkmb+1,-1
if (GV%Rlay(k) > Rcv_ml(i,j)) then
w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), &
diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90
index 9a972e6e06..21c1c07c7c 100644
--- a/src/parameterizations/vertical/MOM_tidal_mixing.F90
+++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interface to vertical tidal mixing schemes including CVMix tidal mixing.
module MOM_tidal_mixing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field
use MOM_diag_mediator, only : safe_alloc_ptr, post_data
use MOM_diagnose_Kdwork, only : vbf_CS
@@ -507,16 +509,16 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di
units="nondim", default=0.1)
do j=js,je ; do i=is,ie
- if (G%bathyT(i,j)+G%Z_ref < CS%min_zbot_itides) CS%mask_itidal(i,j) = 0.0
+ if (max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) < CS%min_zbot_itides) CS%mask_itidal(i,j) = 0.0
CS%tideamp(i,j) = CS%tideamp(i,j) * CS%mask_itidal(i,j) * G%mask2dT(i,j)
! Restrict rms topo to a fraction (often 10 percent) of the column depth.
if ((CS%tidal_answer_date < 20190101) .and. (max_frac_rough >= 0.0)) then
- hamp = min(max_frac_rough*(G%bathyT(i,j)+G%Z_ref), sqrt(CS%h2(i,j)))
+ hamp = min(max_frac_rough * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0), sqrt(CS%h2(i,j)))
CS%h2(i,j) = hamp*hamp
else
if (max_frac_rough >= 0.0) &
- CS%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, CS%h2(i,j))
+ CS%h2(i,j) = min((max_frac_rough * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0))**2, CS%h2(i,j))
endif
utide = CS%tideamp(i,j)
@@ -713,7 +715,7 @@ subroutine calculate_tidal_mixing(dz, j, N2_bot, Rho_bot, N2_lay, N2_int, TKE_to
!! dissipated within a layer and the
!! diapycnal diffusivity within that layer,
!! usually (~Rho_0 / (G_Earth * dRho_lay))
- !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1]
+ !! [T2 Z-1 ~> s2 m-1]
real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer to
!! entrain to its maximum realizable
!! thickness [H Z2 T-3 ~> m3 s-3 or W m-2]
@@ -1009,7 +1011,7 @@ subroutine add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, m
!! dissipated within a layer and the
!! diapycnal diffusivity within that layer,
!! usually (~Rho_0 / (G_Earth * dRho_lay))
- !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1]
+ !! [T2 Z-1 ~> s2 m-1]
real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer
!! to entrain to its maximum realizable
!! thickness [H Z2 T-3 ~> m3 s-3 or W m-2]
@@ -1488,7 +1490,7 @@ subroutine setup_tidal_diagnostics(G, GV, CS)
! local
integer :: isd, ied, jsd, jed, nz
- isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = GV%ke
+ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke
if ((CS%id_Kd_itidal > 0) .or. (CS%id_Kd_Itidal_work > 0)) &
allocate(CS%dd%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.0)
diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90
index d3c0099d20..71f4d00028 100644
--- a/src/parameterizations/vertical/MOM_vert_friction.F90
+++ b/src/parameterizations/vertical/MOM_vert_friction.F90
@@ -1,7 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+#include "do_concurrent_compat.h"
+
!> Implements vertical viscosity (vertvisc)
module MOM_vert_friction
-! This file is part of MOM6. See LICENSE.md for the license.
use MOM_domains, only : pass_var, To_All, Omit_corners
use MOM_domains, only : pass_vector, Scalar_Pair
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
@@ -21,7 +26,7 @@ module MOM_vert_friction
use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S
use MOM_PointAccel, only : write_u_accel, write_v_accel, PointAccel_init
use MOM_PointAccel, only : PointAccel_CS
-use MOM_time_manager, only : time_type, time_type_to_real, operator(-)
+use MOM_time_manager, only : time_type, time_minus_signed
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : thermo_var_ptrs, vertvisc_type
use MOM_variables, only : cont_diag_ptrs, accel_diag_ptrs
@@ -77,11 +82,8 @@ module MOM_vert_friction
!! viscosity via Kv_gl90 = alpha_gl90 * f^2. Note that the implied
!! Kv_gl90 corresponds to a kappa_gl90 that scales as N^2 with depth.
!! [H Z T ~> m2 s or kg s m-1]
- real :: maxvel !< Velocity components greater than maxvel are truncated [L T-1 ~> m s-1].
real :: vel_underflow !< Velocity components smaller than vel_underflow
!! are set to 0 [L T-1 ~> m s-1].
- logical :: CFL_based_trunc !< If true, base truncations on CFL numbers, not
- !! absolute velocities.
real :: CFL_trunc !< Velocity components will be truncated when they
!! are large enough that the corresponding CFL number
!! exceeds this value [nondim].
@@ -248,10 +250,10 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, lpost, Cemp_NL, G
real :: Gat1, Gsig, dGdsig !< Shape parameters [nondim]
real :: du, dv !< Intermediate velocity differences [L T-1 ~> m s-1]
real :: depth !< Cumulative of thicknesses [H ~> m]
- integer :: b, kbld, kp1, k, nz !< band and vertical indices
+ integer :: b, kp1, k, nz !< band and vertical indices
integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq !< horizontal indices
- is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec
+ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke
pi = 4. * atan2(1.,1.)
@@ -411,6 +413,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, lpost, Cemp_NL, G
end subroutine vertFPmix
+
!> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb
!! (1990), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme
!! redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization,
@@ -430,98 +433,95 @@ 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)
- 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
- !! at velocity points [Z ~> m]
- logical, dimension(SZIB_(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
- !! 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
- !! 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(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.
+subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, i, j, z_i, G, GV, CS, VarMix, work_on_u)
+ !$omp declare target
+ type(ocean_grid_type), intent(in) :: G !< Grid structure.
+ type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure.
+ real, dimension(SZK_(GV)), intent(in) :: hvel !< Distance between interfaces
+ !! at velocity points [Z ~> m]
+ integer, intent(in) :: i !< Column i-index
+ integer, intent(in) :: j !< Column j-index
+ real, dimension(SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the
+ !! bottom, normalized by the GL90 bottom
+ !! boundary layer thickness [nondim]
+ real, dimension(SZK_(GV)+1),intent(out) :: a_cpl_gl90 !< Coupling coefficient associated
+ !! with GL90 across interfaces; is not
+ !! included in a_cpl [H T-1 ~> m s-1 or Pa s m-1].
+ type(vertvisc_cs), intent(in) :: CS !< Vertical viscosity control structure
+ type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients
+ logical, intent(in) :: work_on_u !< If true, u-points are being calculated,
+ !! otherwise they are v-points.
! local variables
logical :: kdgl90_use_vert_struct ! use vertical structure for GL90 coefficient
- integer :: i, k, is, ie, nz, Isq, Ieq
+ integer :: k, nz
real :: f2 !< Squared Coriolis parameter at a velocity grid point [T-2 ~> s-2].
real :: h_neglect ! A vertical distance that is so small it is usually lost in roundoff error
! and can be neglected [Z ~> m].
real :: botfn ! A function that is 1 at the bottom and small far from it [nondim]
real :: z2 ! The distance from the bottom, normalized by Hbbl_gl90 [nondim]
- is = G%isc ; ie = G%iec
- Isq = G%IscB ; Ieq = G%IecB
nz = GV%ke
-
h_neglect = GV%dZ_subroundoff
kdgl90_use_vert_struct = .false.
+
if (VarMix%use_variable_mixing) then
kdgl90_use_vert_struct = allocated(VarMix%kdgl90_struct)
endif
- if (work_on_u) then
- ! compute coupling coefficient at u-points
- do I=Isq,Ieq; if (do_i(I)) then
+ a_cpl_gl90(:) = 0.
+
+ do K=2,nz
+ if (work_on_u) then
+ ! compute coupling coefficient at u-points
f2 = 0.25 * (G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J))**2
- do K=2,nz
- 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)
+ if (CS%use_GL90_N2) then
+ a_cpl_gl90(K) = 2. * f2 * CS%alpha_gl90 / (hvel(k) + hvel(k-1) + h_neglect)
+ else
+ if (CS%read_kappa_gl90) then
+ a_cpl_gl90(K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i+1,j)) / GV%g_prime(K)
else
- 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)
- else
- a_cpl_gl90(I,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) )
- endif
+ a_cpl_gl90(K) = f2 * CS%kappa_gl90 / GV%g_prime(K)
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
+ if (kdgl90_use_vert_struct) then
+ a_cpl_gl90(K) = a_cpl_gl90(K) * 0.5 &
+ * (VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i+1,j,k-1))
+ endif
+ endif
+ ! botfn determines when a point is within the influence of the GL90 bottom boundary layer,
+ ! going from 1 at the bottom to 0 in the interior.
+ z2 = z_i(k)
+ botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2)
+
+ a_cpl_gl90(K) = a_cpl_gl90(K) * (1. - botfn)
+ else
+ ! compute viscosities at v-points
f2 = 0.25 * (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J))**2
- do K=2,nz
- 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)
+
+ if (CS%use_GL90_N2) then
+ a_cpl_gl90(K) = 2. * f2 * CS%alpha_gl90 / (hvel(k) + hvel(k-1) + h_neglect)
+ else
+ if (CS%read_kappa_gl90) then
+ a_cpl_gl90(K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i,j+1)) / GV%g_prime(K)
else
- 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)
- else
- a_cpl_gl90(i,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) )
- endif
+ a_cpl_gl90(K) = f2 * CS%kappa_gl90 / GV%g_prime(K)
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
+ if (kdgl90_use_vert_struct) then
+ a_cpl_gl90(K) = a_cpl_gl90(K) * 0.5 &
+ * (VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i,j+1,k-1))
+ endif
+ endif
+ ! botfn determines when a point is within the influence of the GL90 bottom boundary layer,
+ ! going from 1 at the bottom to 0 in the interior.
+ z2 = z_i(k)
+ botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2)
+ a_cpl_gl90(K) = a_cpl_gl90(K) * (1. - botfn)
+ endif
+ enddo
end subroutine find_coupling_coef_gl90
+
!> Perform a fully implicit vertical diffusion
!! of momentum. Stress top and bottom boundary conditions are used.
!!
@@ -535,7 +535,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
@@ -554,7 +553,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, &
type(accel_diag_ptrs), intent(inout) :: ADp !< Accelerations in the momentum
!! equations for diagnostics
type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation terms
- type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure
+ type(vertvisc_CS) :: CS !< Vertical viscosity control structure
real, dimension(SZIB_(G),SZJ_(G)), &
optional, intent(out) :: taux_bot !< Zonal bottom stress from ocean to
!! rock [R L Z T-2 ~> Pa]
@@ -571,11 +570,16 @@ 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 :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2].
+ real :: b1
+ ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1].
+ real :: c1(SZK_(GV))
+ ! A variable used by the tridiagonal solver [nondim].
+ real :: d1
+ ! d1=1-c1 is used by the tridiagonal solver [nondim].
+ real :: Ray
+ ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1]
+ real :: b_denom_1
+ ! The first term in the denominator of b1 [H ~> m or kg m-2].
real :: Hmix ! The mixed layer thickness over which stress
! is applied with direct_stress [H ~> m or kg m-2].
@@ -591,8 +595,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,17 +605,13 @@ 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
integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n
- is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec
+ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke
- if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// &
- "Module must be initialized before it is used.")
-
if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(visc): "// &
"Module must be initialized before it is used.")
@@ -637,347 +638,450 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, &
if (CS%StokesMixing) then
if (present(Waves)) DoStokesMixing = associated(Waves)
if (.not. DoStokesMixing) &
- call MOM_error(FATAL,"Stokes Mixing called without allocated"//&
- "Waves Control Structure")
+ call MOM_error(FATAL, "Stokes Mixing called without associated Waves Control Structure")
endif
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
-
- 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 (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq
+ ! tridiagonal solver.
+
+ ! WGL: Brandon Reichl says the following is obsolete. u(I,j,k) already
+ ! includes Stokes.
+ ! When mixing down Eulerian current + Stokes drift add before calling solver
+ if (DoStokesMixing) then
+ do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then
+ u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k)
+ endif ; enddo ; enddo ; enddo
+ endif
+
+ 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 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
+
+ !$omp target enter data map(to: ADp)
+ !$omp target enter data map(alloc: surface_stress)
+ !$omp target enter data map(alloc: ADp%dv_dt_str)
+ !$omp target enter data map(alloc: ADp%du_dt_str)
+
+ if (associated(ADp%du_dt_visc_gl90)) then
+ do concurrent (k=1:nz, j=G%jsc:G%jec, 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
+ endif
+
+ if (associated(ADp%du_dt_str)) then
+ do concurrent (k=1:nz, j=G%jsc:G%jec, 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)
- endif ; enddo ; 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 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
+ 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 concurrent (j=G%jsc:G%jec, I=Isq:Ieq, G%mask2dCu(i,j) > 0.0)
+ 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
+ enddo
+ else
+ do concurrent (j=G%jsc:G%jec, I=Isq:Ieq)
+ surface_stress(I,j) = dt_Rho0 * (G%mask2dCu(I,j)*forces%taux(I,j))
+ 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
+
+ !$omp target enter data map(alloc: c1)
+ !$omp target enter data map(to: visc%Ray_u) if (allocated(visc%Ray_u))
+
+ !$omp target teams loop collapse(2) &
+ !$omp private(b1, c1, d1, Ray, b_denom_1)
+ do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then
+ Ray = 0.
+ if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,1)
+
+ b_denom_1 = CS%h_u(I,j,1) + dt * (Ray + CS%a_u(I,j,1))
+ b1 = 1. / (b_denom_1 + dt * CS%a_u(I,j,2))
+ d1 = b_denom_1 * b1
+ u(I,j,1) = b1 * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I,j))
if (associated(ADp%du_dt_str)) then
- 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
- endif ; enddo ; enddo
+ ADp%du_dt_str(I,j,1) = b1 * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I,j) * Idt)
endif
- ! 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)
- endif ; enddo ; enddo
+ do k=2,nz
+ if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,k)
+
+ c1(k) = dt * CS%a_u(I,j,K) * b1
+ b_denom_1 = CS%h_u(I,j,k) + dt * (Ray + CS%a_u(I,j,K) * d1)
+ b1 = 1. / (b_denom_1 + dt * CS%a_u(I,j,K+1))
+ d1 = b_denom_1 * b1
+ u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1
+
+ if (associated(ADp%du_dt_str)) then
+ ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) &
+ + dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1
+ endif
+
+ !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch.
+ ! XXX: Check GPU behavior
+ if (dt < 0) exit
+ enddo
+
+ if (associated(ADp%du_dt_str)) then
+ if (abs(ADp%du_dt_str(I,j,nz)) < accel_underflow) &
+ ADp%du_dt_str(I,j,nz) = 0.
+ endif
+
+ do k=nz-1,1,-1
+ u(I,j,k) = u(I,j,k) + c1(k+1) * u(I,j,k+1)
+
+ if (associated(ADp%du_dt_str)) then
+ ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(k+1) * ADp%du_dt_str(I,j,k+1)
+
+ if (abs(ADp%du_dt_str(I,j,k)) < accel_underflow) &
+ ADp%du_dt_str(I,j,k) = 0.0
+ endif
+ enddo
+ endif ; enddo ; enddo
+
+ ! compute vertical velocity tendency that arises from GL90 viscosity;
+ ! follow tridiagonal solve method as above; to avoid corrupting u,
+ ! use ADp%du_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop
+ if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then
+ if (associated(ADp%du_dt_visc_gl90)) then
+ do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then
+ b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero
+ b1 = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,2))
+ d1 = b_denom_1 * b1
+
+ ADp%du_dt_visc_gl90(I,j,1) = b1 * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1))
+
+ do k=2,nz
+ c1(k) = dt * CS%a_u_gl90(I,j,K) * b1
+ b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1)
+ b1 = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1))
+ d1 = b_denom_1 * b1
+
+ ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) &
+ + dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1
+ enddo
+
! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90
- do k=nz-1,1,-1 ; 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
+ do k=nz-1,1,-1
+ ADp%du_dt_visc_gl90(I,j,k) = &
+ ADp%du_dt_visc_gl90(I,j,k) + c1(k+1) * ADp%du_dt_visc_gl90(I,j,k+1)
+ enddo
+
+ do k=1,nz
! now fill ADp%du_dt_visc_gl90(I,j,k) with actual velocity tendency due to GL90;
! note that on RHS: ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k)
! and ADp%du_dt_visc_gl90(I,j,k) the updated velocity due to GL90
- ADp%du_dt_visc_gl90(I,j,k) = (ADp%du_dt_visc_gl90(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt
- if (abs(ADp%du_dt_visc_gl90(I,j,k)) < accel_underflow) ADp%du_dt_visc_gl90(I,j,k) = 0.0
- endif ; enddo ; enddo ;
+ ADp%du_dt_visc_gl90(I,j,k) = &
+ (ADp%du_dt_visc_gl90(I,j,k) - ADp%du_dt_visc(I,j,k)) * Idt
+
+ if (abs(ADp%du_dt_visc_gl90(I,j,k)) < accel_underflow) then
+ ADp%du_dt_visc_gl90(I,j,k) = 0.0
+ endif
+ enddo
+
! to compute energetics, we need to multiply by u*h, where u is original velocity before
! velocity update; note that ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k)
if (CS%id_GLwork > 0) then
- do k=1,nz; 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)
- endif ; enddo ; enddo
+ do k=1,nz
+ KE_u(I,j,k) = ADp%du_dt_visc(I,j,k) * CS%h_u(I,j,k) * G%areaCu(I,j) * ADp%du_dt_visc_gl90(I,j,k)
+ enddo
endif
- endif
+ endif ; enddo ; enddo
endif
+ endif
- if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq
- ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt
- if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) ADp%du_dt_visc(I,j,k) = 0.0
- enddo ; enddo ; endif
-
- if (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 (associated(ADp%du_dt_visc)) then
+ do concurrent (j=G%jsc:G%jec, I=Isq:Ieq)
+ do k=1,nz
+ ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k)) * Idt
- 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))
+ if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) &
+ ADp%du_dt_visc(I,j,k) = 0.0
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
+ enddo
+ endif
+
+ if (allocated(visc%taux_shelf)) then
+ do j=G%jsc,G%jec ; do I=Isq,Ieq
+ visc%taux_shelf(I,j) = -GV%H_to_RZ * CS%a1_shelf_u(I,j) * u(I,j,1) ! - u_shelf?
+ enddo ; enddo
+ endif
- ! 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 concurrent (j=G%jsc:G%jec, I=Isq:Ieq)
+ taux_bot(I,j) = GV%H_to_RZ * (u(I,j,nz) * CS%a_u(I,j,nz+1))
+ 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 concurrent (j=G%jsc:G%jec, I=Isq:Ieq)
+ do k=1,nz
+ taux_bot(I,j) = taux_bot(I,j) + GV%H_to_RZ * (visc%Ray_u(I,j,k) * u(I,j,k))
+ 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 concurrent (k=1:nz, J=Jsq:Jeq, 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
+ 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 concurrent (k=1:nz, J=Jsq:Jeq, 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)
- 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
+ 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 concurrent (J=Jsq:Jeq, i=is:ie, G%mask2dCv(i,J) > 0.0)
+ 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
+ enddo
+ else
+ do concurrent (J=Jsq:Jeq, i=is:ie)
+ surface_stress(i,J) = dt_Rho0 * (G%mask2dCv(i,J) * forces%tauy(i,J))
+ enddo
+ endif
+
+ !$omp target enter data map(to: visc%Ray_v) if (allocated(visc%Ray_v))
+
+ !$omp target teams loop collapse(2) &
+ !$omp private(b1, c1, d1, Ray, b_denom_1)
+ do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then
+ Ray = 0.
+ if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,1)
+
+ b_denom_1 = CS%h_v(i,J,1) + dt * (Ray + CS%a_v(i,J,1))
+ b1 = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2))
+ d1 = b_denom_1 * b1
+ v(i,J,1) = b1 * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i,J))
if (associated(ADp%dv_dt_str)) then
- do i=is,ie ; if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) ADp%dv_dt_str(i,J,nz) = 0.0 ; enddo
- do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then
- ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(i,k+1) * ADp%dv_dt_str(i,J,k+1)
- if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) ADp%dv_dt_str(i,J,k) = 0.0
- endif ; enddo ; enddo
+ ADp%dv_dt_str(i,J,1) = b1 * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i,J) * Idt)
endif
- ! 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)
- 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)
- endif ; enddo ; enddo
+ do k=2,nz
+ if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,k)
+
+ c1(k) = dt * CS%a_v(i,J,K) * b1
+ b_denom_1 = CS%h_v(i,J,k) + dt * (Ray + CS%a_v(i,J,K) * d1)
+ b1 = 1. / (b_denom_1 + dt * CS%a_v(i,J,K+1))
+ d1 = b_denom_1 * b1
+ v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1
+
+ if (associated(ADp%dv_dt_str)) then
+ ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) &
+ + dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1
+ endif
+
+ !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch.
+ ! XXX: Check GPU behavior
+ if (dt < 0) exit
+ enddo
+
+ if (associated(ADp%dv_dt_str)) then
+ if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) &
+ ADp%dv_dt_str(i,J,nz) = 0.0
+ endif
+
+ do k=nz-1,1,-1
+ v(i,J,k) = v(i,J,k) + c1(k+1) * v(i,J,k+1)
+
+ if (associated(ADp%dv_dt_str)) then
+ ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(k+1) * ADp%dv_dt_str(i,J,k+1)
+
+ if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) &
+ ADp%dv_dt_str(i,J,k) = 0.0
+ endif
+ enddo
+ endif ; enddo ; enddo
+
+ ! compute vertical velocity tendency that arises from GL90 viscosity;
+ ! follow tridiagonal solve method as above; to avoid corrupting v,
+ ! use ADp%dv_dt_visc_gl90 as a placeholder for updated v (due to GL90) until last do loop
+ if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then
+ if (associated(ADp%dv_dt_visc_gl90)) then
+ do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then
+ b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero
+ b1 = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2))
+ d1 = b_denom_1 * b1
+ ADp%dv_dt_visc_gl90(I,J,1) = b1 * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1))
+
+ do k=2,nz
+ c1(k) = dt * CS%a_v_gl90(i,J,K) * b1
+ b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K) * d1)
+ b1 = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1))
+ d1 = b_denom_1 * b1
+ ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) &
+ + dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1
+ enddo
+
! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90
- do k=nz-1,1,-1 ; 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
+ do k=nz-1,1,-1
+ ADp%dv_dt_visc_gl90(i,J,k) = ADp%dv_dt_visc_gl90(i,J,k) + c1(k+1) * ADp%dv_dt_visc_gl90(i,J,k+1)
+ enddo
+ endif ; enddo ; enddo
+
+ do k=1,nz
+ do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then
! now fill ADp%dv_dt_visc_gl90(i,J,k) with actual velocity tendency due to GL90;
! note that on RHS: ADp%dv_dt_visc(i,J,k) holds the original velocity value v(i,J,k)
! and ADp%dv_dt_visc_gl90(i,J,k) the updated velocity due to GL90
- ADp%dv_dt_visc_gl90(i,J,k) = (ADp%dv_dt_visc_gl90(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt
- if (abs(ADp%dv_dt_visc_gl90(i,J,k)) < accel_underflow) ADp%dv_dt_visc_gl90(i,J,k) = 0.0
- endif ; enddo ; enddo ;
- ! 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)
+ ADp%dv_dt_visc_gl90(i,J,k) = (ADp%dv_dt_visc_gl90(i,J,k) - ADp%dv_dt_visc(i,J,k)) * Idt
+
+ if (abs(ADp%dv_dt_visc_gl90(i,J,k)) < accel_underflow) &
+ ADp%dv_dt_visc_gl90(i,J,k) = 0.0
+ endif ; enddo ; enddo
+ enddo
+
+ ! to compute energetics, we need to multiply by v*h, where u is original velocity before
+ ! velocity update; note that ADp%dv_dt_visc(I,j,k) holds the original velocity value v(i,J,k)
+ if (CS%id_GLwork > 0) then
+ do k=1,nz
+ do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then
+ ! note that on RHS: ADp%dv_dt_visc(I,j,k) holds the original velocity value v(I,j,k)
+ KE_v(I,j,k) = ADp%dv_dt_visc(i,J,k) * CS%h_v(i,J,k) * G%areaCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k)
endif ; enddo ; enddo
- endif
+ enddo
endif
endif
+ endif
+
+ if (associated(ADp%dv_dt_visc)) then
+ do concurrent (J=Jsq:Jeq, i=is:ie)
+ do k=1,nz
+ 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
- if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; 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
+ 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 (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
+ ! JORGE TODO: this has to be malloced
+ if (present(tauy_bot)) then
+ do concurrent (J=Jsq:Jeq, i=is:ie)
+ tauy_bot(i,J) = GV%H_to_RZ * (v(i,J,nz) * CS%a_v(i,J,nz+1))
+ enddo
- 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))
+ if (allocated(visc%Ray_v)) then
+ do concurrent (J=Jsq:Jeq, i=is:ie)
+ do k=1,nz
+ tauy_bot(i,J) = tauy_bot(i,J) + GV%H_to_RZ * (visc%Ray_v(i,J,k)*v(i,J,k))
+ enddo
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
+ endif
- ! When mixing down Eulerian current + Stokes drift subtract after calling solver
- if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie
- if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k)
- enddo ; enddo ; endif
-
- if ( lfpmix ) then ; do k=1,nz ; do 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
@@ -998,6 +1102,14 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, &
call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS)
+ !$omp target exit data map(delete: c1)
+
+ !$omp target exit data map(from: ADp%du_dt_str, ADp%dv_dt_str)
+ !$omp target exit data map(delete: ADp)
+ !$omp target exit data map(delete: surface_stress)
+ !$omp target exit data map(delete: visc%Ray_u) if (allocated(visc%Ray_u))
+ !$omp target exit data map(delete: visc%Ray_v) if (allocated(visc%Ray_v))
+
! Here the velocities associated with open boundary conditions are applied.
if (associated(OBC)) then
do n=1,OBC%number_of_segments
@@ -1036,7 +1148,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, &
if (CS%id_dv_dt_str > 0) &
call post_data(CS%id_dv_dt_str, ADp%dv_dt_str, CS%diag)
- if (associated(ADp%du_dt_visc) .and. associated(ADp%du_dt_visc)) then
+ if (associated(ADp%du_dt_visc) .and. associated(ADp%dv_dt_visc)) then
! Diagnostics of the fractional thicknesses times momentum budget terms
! 3D diagnostics of hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option.
! The code is retained for debugging purposes in the future.
@@ -1071,6 +1183,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.
@@ -1088,90 +1201,97 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS)
!! viscosity is applied in the meridional direction [nondim]
real, intent(in) :: dt !< Time increment [T ~> s]
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
- type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure
+ type(vertvisc_CS) :: CS !< Vertical viscosity control structure
! 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 :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2].
- logical :: do_i(SZIB_(G))
+ real :: b1
+ ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1].
+ real :: c1(SZK_(GV))
+ ! A variable used by the tridiagonal solver [nondim].
+ real :: d1
+ ! d1=1-c1 is used by the tridiagonal solver [nondim].
+ real :: Ray
+ ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1]
+ real :: b_denom_1
+ ! The first term in the denominator of b1 [H ~> m or kg m-2].
integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz
is = G%isc ; ie = G%iec
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke
- if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// &
+ if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remnant): "// &
"Module must be initialized before it is used.")
- if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remant): "// &
- "Module must be initialized before it is used.")
+ ! Find the zonal viscous remnant using a modification of a standard tridagonal solver.
- do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo
+ !$omp target teams loop collapse(2) &
+ !$omp private(b1, c1, d1, Ray, b_denom_1)
+ do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then
+ Ray = 0.
+ if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,1)
+
+ b_denom_1 = CS%h_u(I,j,1) + dt * (Ray + CS%a_u(I,j,1))
+ b1 = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,2))
+ d1 = b_denom_1 * b1
+ visc_rem_u(I,j,1) = b1 * CS%h_u(I,j,1)
+
+ do k=2,nz
+ if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,k)
+
+ c1(k) = dt * CS%a_u(I,j,K) * b1
+ b_denom_1 = CS%h_u(I,j,k) + dt * (Ray + CS%a_u(I,j,K) * d1)
+ b1 = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1))
+ d1 = b_denom_1 * b1
+ visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1
+
+ !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch.
+ ! XXX: Check GPU behavior
+ if (dt < 0) exit
+ 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)
-
- endif ; enddo ; enddo ! i and k loops
-
- enddo ! end u-component j loop
+ do k=nz-1,1,-1
+ visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(k+1) * visc_rem_u(I,j,k+1)
+ enddo
+ endif ; enddo ; enddo
! Now find the meridional viscous remnant using the robust tridiagonal solver.
- !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1)
- do J=Jsq,Jeq
- do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.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)
- endif ; enddo ; enddo
- do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then
- visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,k+1)*visc_rem_v(i,J,k+1)
- endif ; enddo ; enddo ! i and k loops
- enddo ! end of v-component J loop
+
+ !$omp target teams loop collapse(2) &
+ !$omp private(b1, c1, d1, Ray, b_denom_1)
+ do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then
+ Ray = 0.
+ if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,1)
+
+ b_denom_1 = CS%h_v(i,J,1) + dt * (Ray + CS%a_v(i,J,1))
+ b1 = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2))
+ d1 = b_denom_1 * b1
+ visc_rem_v(i,J,1) = b1 * CS%h_v(i,J,1)
+
+ do k=2,nz
+ if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,k)
+
+ c1(k) = dt * CS%a_v(i,J,K) * b1
+ b_denom_1 = CS%h_v(i,J,k) + dt * (Ray + CS%a_v(i,J,K) * d1)
+ b1 = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1))
+ d1 = b_denom_1 * b1
+ visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1
+
+ !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch.
+ ! XXX: Check GPU behavior
+ if (dt < 0) exit
+ enddo
+
+ do k=nz-1,1,-1
+ visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(k+1) * visc_rem_v(i,J,k+1)
+ enddo
+ endif ; enddo ; enddo
if (CS%debug) then
+ !$omp target update from(visc_rem_u, visc_rem_v)
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 +1315,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 +1324,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(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 :: &
+ 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(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 :: &
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 +1374,8 @@ 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 ! The height of an interface at h-points [Z ~> m].
+ real :: zcol_p1 ! An adjacent east/north h-point interface height [Z ~> m].
real :: botfn ! A function which goes from 1 at the bottom to 0 much more
! than Hbbl into the interior [nondim].
real :: topfn ! A function which goes from 1 at the top to 0 much more
@@ -1273,28 +1393,20 @@ 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_any_shelf
- integer, dimension(SZIB_(G)) :: &
- zi_dir ! A trinary logical array indicating which thicknesses to use for
- ! finding z_clear.
+ integer :: zi_dir
+ ! A ternary logical indicating which thickness to use for finding z_clear.
integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
+
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke
- if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(coef): "// &
- "Module must be initialized before it is used.")
-
if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(coef): "// &
"Module must be initialized before it is used.")
h_neglect = GV%H_subroundoff
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)
- if (CS%use_GL90_in_SSW) then
- I_Hbbl_gl90(:) = 1.0 / (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
if (CS%id_Kv_u > 0) allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0)
@@ -1317,492 +1429,1209 @@ 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
+ !$omp target enter data map(alloc: Ustar_2d)
call find_ustar(forces, tv, Ustar_2d, G, GV, US, halo=1)
- !$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
+ ! First do u-points
- ! 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
-
-! 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
+ ! TODO: tv and VarMix probably should be conditionally transferred (if at all)
+ !$omp target enter data map(alloc: z_i, z_i_gl90, dz_harm, hvel, dz_vel, a_cpl, a_cpl_gl90, &
+ !$omp& tv, varmix, hvel_shelf, dz_vel_shelf, a_shelf)
- endif ; enddo ! i loop
- enddo ! k loop
- endif
+ ! These are used in diagnostics, so they need to be mapped back and forth
+ !$omp target enter data map(to: hML_u, kv_u, kv_gl90_u )
+ !$omp target enter data map(to: hML_v, kv_v, kv_gl90_v)
- 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
+ !$omp target teams distribute parallel do collapse(2) &
+ !$omp private(z_i, z_i_gl90, dz_harm, hvel, dz_vel, a_cpl, a_cpl_gl90, &
+ !$omp& I_Hbbl, I_Hbbl_gl90, kv_bbl, bbl_thick, Dmin, zi_dir, zh, zcol, &
+ !$omp& zcol_p1, h_harm, h_arith, h_delta, dz_arith, z2, botfn, z_clear, &
+ !$omp& z2_wt, h_ml)
+ do j=js,je ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then
+ I_Hbbl = 1. / (CS%Hbbl + dz_neglect)
if (CS%use_GL90_in_SSW) then
- ! 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.)
+ I_Hbbl_gl90 = 1. / (CS%Hbbl_gl90 + dz_neglect)
endif
- if (allocated(hML_u)) then
- do i=isq,ieq ; if (do_i(i)) then ; hML_u(I,j) = h_ml(I) ; endif ; enddo
+ if (CS%bottomdraglaw) then
+ kv_bbl = visc%Kv_bbl_u(I,j)
+ bbl_thick = visc%bbl_thick_u(I,j) + dz_neglect
+ I_Hbbl = 1. / bbl_thick
endif
- 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
+ Dmin = min(G%bathyT(i,j), G%bathyT(i+1,j))
+ zi_dir = 0
+
+ ! Project thickness outward across OBCs using a zero-gradient condition.
+ if (associated(OBC)) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ Dmin = G%bathyT(i,j)
+ zi_dir = -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
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ Dmin = G%bathyT(i+1,j)
+ zi_dir = 1
+ endif
+ endif
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
+ ! 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.
+
+ z_i(nz+1) = 0.
+
+ if (.not. CS%harmonic_visc) then
+ zh = 0.
+ zcol = -G%bathyT(i,j)
+ zcol_p1 = -G%bathyT(i+1,j)
endif
- ! 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)
- enddo ; enddo
+
+ if (CS%use_GL90_in_SSW) then
+ z_i_gl90(nz+1) = 0.
endif
- enddo
+ do k=nz,1,-1
+ h_harm = 2. * h(i,j,k) * h(i+1,j,k) / (h(i,j,k) + h(i+1,j,k) + h_neglect)
+ h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k))
+ h_delta = h(i+1,j,k) - h(i,j,k)
+ dz_harm(k) = 2. * dz(i,j,k) * dz(i+1,j,k) / (dz(i,j,k) + dz(i+1,j,k) + dz_neglect)
+ dz_arith = 0.5 * (dz(i+1,j,k) + dz(i,j,k))
+
+ ! Project thickness outward across OBCs using a zero-gradient condition.
+ if (associated(OBC)) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ h_harm = h(i,j,k)
+ h_arith = h(i,j,k)
+ h_delta = 0.
+ dz_harm(k) = dz(i,j,k)
+ dz_arith = dz(i,j,k)
+ endif
+ endif
- ! 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
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ h_harm = h(i+1,j,k)
+ h_arith = h(i+1,j,k)
+ h_delta = 0.
+ dz_harm(k) = dz(i+1,j,k)
+ dz_arith = dz(i+1,j,k)
+ endif
+ endif
+ endif
- ! 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
+ if (CS%harmonic_visc) then
+ ! The following block calculates the thicknesses at velocity grid points
+ ! for the vertical viscosity (hvel and dz_vel). Near the bottom an
+ ! upwind biased thickness is used to control the effect of spurious
+ ! Montgomery potential gradients at the bottom where nearly massless
+ ! layers ride over the topography.
+
+ hvel(k) = h_harm
+ dz_vel(k) = dz_harm(k)
+
+ if (u(I,j,k) * h_delta < 0) then
+ z2 = z_i(k+1)
+ botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2)
+
+ hvel(k) = (1. - botfn) * h_harm + botfn * h_arith
+ dz_vel(k) = (1. - botfn) * dz_harm(k) + botfn * dz_arith
endif
- endif ; enddo
- endif ; endif
-
-! The following block calculates the thicknesses at velocity
-! grid points for the vertical viscosity (hvel). Near the
-! bottom an upwind biased thickness is used to control the effect
-! of spurious Montgomery potential gradients at the bottom where
-! nearly massless layers layers ride over the topography.
- if (CS%harmonic_visc) then
- do i=is,ie ; z_i(i,nz+1) = 0.0 ; enddo
-
- do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then
- hvel(i,k) = h_harm(i,k)
- 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)
+
+ z_i(k) = z_i(k+1) + dz_harm(k) * I_Hbbl
+ else
+ zcol = zcol + dz(i,j,k)
+ zcol_p1 = zcol_p1 + dz(i+1,j,k)
+
+ zh = zh + dz_harm(k)
+
+ z_clear = max(zcol, zcol_p1) + Dmin
+ if (zi_dir < 0) z_clear = zcol + Dmin
+ if (zi_dir > 0) z_clear = zcol_p1 + Dmin
+
+ z_i(k) = max(zh, z_clear) * I_Hbbl
+
+ hvel(k) = h_arith
+ dz_vel(k) = dz_arith
+
+ if (u(I,j,k) * h_delta > 0.) then
+ if (zh * I_Hbbl < CS%harm_BL_val) then
+ hvel(k) = h_harm
+ dz_vel(k) = dz_harm(k)
+ else
+ z2_wt = 1.
+ if (zh * I_Hbbl < 2. * CS%harm_BL_val) &
+ z2_wt = max(0., min(1., zh * I_Hbbl * I_valBL - 1.))
+
+ z2 = z2_wt * (max(zh, z_clear) * I_Hbbl)
+ botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2)
+
+ hvel(k) = (1. - botfn) * h_arith + botfn * h_harm
+ dz_vel(k) = (1. - botfn) * dz_arith + botfn * dz_harm(k)
+ endif
endif
- 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)
+ endif
+
+ if (CS%use_GL90_in_SSW) then
+ ! The following block calculates the normalized height above the GL90 BBL
+ ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the
+ ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose isthat the
+ ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure
+ ! that no momentum gets fluxed into vanished layers. The scheme is not
+ ! sensitive to the exact value of Hbbl_gl90, as long as it is in a
+ ! reasonable range (~1-20 m): large enough to capture vanished layers
+ ! over topography, small enough to not contaminate the interior.
+
+ z_i_gl90(k) = z_i_gl90(k+1) + dz_harm(k) * I_Hbbl_gl90
+ endif
+ enddo
+
+ call find_coupling_coef_k(a_cpl, dz_vel, i, j, dz_harm, bbl_thick, kv_bbl, z_i, &
+ h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC)
+
+ if (allocated(hML_u)) hML_u(I,j) = h_ml
+
+ if (CS%use_GL90_in_SSW) then
+ call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, i, j, z_i_gl90, G, GV, &
+ CS, VarMix, work_on_u=.true.)
+ endif
+
+ do_any_shelf = .false.
+ if (associated(forces%frac_shelf_u)) then
+ CS%a1_shelf_u(I,j) = 0.
+ do_any_shelf = forces%frac_shelf_u(I,j) > 0.
+
+ if (do_any_shelf) then
+ if (.not. CS%harmonic_visc) then
+ zh = 0.
+ Ztop_min = min(zcol, zcol_p1)
+ I_HTbl = 1. / (visc%tbl_thick_shelf_u(I,j) + dz_neglect)
+ endif
+
+ do k=1,nz
+ if (CS%harmonic_visc) then
+ hvel_shelf(k) = hvel(k)
+ dz_vel_shelf(k) = dz_vel(k)
else
- 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)
+ ! Find upwind-biased thickness near the surface.
+ ! (Perhaps this needs to be done more carefully, via find_eta.)
+
+ h_harm = 2. * h(i,j,k) * h(i+1,j,k) &
+ / (h(i,j,k) + h(i+1,j,k) + h_neglect)
+ h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k))
+ h_delta = h(i+1,j,k) - h(i,j,k)
+ dz_arith = 0.5 * (dz(i+1,j,k) + dz(i,j,k))
+
+ if (associated(OBC)) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ h_harm = h(i,j,k)
+ h_arith = h(i,j,k)
+ h_delta = 0.
+ dz_arith = dz(i,j,k)
+ endif
+ endif
+
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ h_harm = h(i+1,j,k)
+ h_arith = h(i+1,j,k)
+ h_delta = 0.
+ dz_arith = dz(i+1,j,k)
+ endif
+ endif
+ endif
+
+ zcol = zcol - dz(i,j,k)
+ zcol_p1 = zcol_p1 - dz(i+1,j,k)
+
+ zh = zh + dz_harm(k)
+
+ hvel_shelf(k) = hvel(k)
+ dz_vel_shelf(k) = dz_vel(k)
+
+ if (u(I,j,k) * h_delta > 0.) then
+ if (zh * I_HTbl < CS%harm_BL_val) then
+ hvel_shelf(k) = min(hvel(k), h_harm)
+ dz_vel_shelf(k) = min(dz_vel(k), dz_harm(k))
+ else
+ z2_wt = 1.
+ if (zh * I_HTbl < 2. * CS%harm_BL_val) then
+ z2_wt = max(0., min(1., zh * I_HTbl * I_valBL - 1.))
+ endif
+
+ z2 = z2_wt * (max(zh, Ztop_min - min(zcol, zcol_p1)) * I_HTbl)
+ ! TODO: replace **6 with multiply
+ topfn = 1. / (1. + 0.09 * z2**6)
+
+ hvel_shelf(k) = min(hvel(k), (1. - topfn) * h_arith + topfn * h_harm)
+ dz_vel_shelf(k) = min(dz_vel(k), (1. - topfn) * dz_arith + topfn * dz_harm(k))
+ endif
+ endif
endif
+ enddo
+
+ call find_coupling_coef(a_shelf, dz_vel_shelf, i, j, dz_harm, &
+ bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, &
+ tv, work_on_u=.true., OBC=OBC, shelf=.true.)
+
+ CS%a1_shelf_u(I,j) = a_shelf(1)
+ endif
+ endif
+
+ if (do_any_shelf) then
+ if (CS%use_GL90_in_SSW) then
+ do K=1,nz+1
+ CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(K) + &
+ (1. - forces%frac_shelf_u(I,j)) * a_cpl(K)) + a_cpl_gl90(K))
+
+ ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH
+ ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(K), a_cpl(K)) + &
+ ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(K))
+
+ CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K))
+ enddo
+ else
+ do K=1,nz+1
+ CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(K) + &
+ (1. - forces%frac_shelf_u(I,j)) * a_cpl(K)))
+
+ ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH
+ ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(K), a_cpl(K)) + &
+ ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(K))
+ enddo
+ endif
+
+ do k=1,nz
+ ! Should we instead take the inverse of the average of the inverses?
+ CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(k) &
+ + (1. - forces%frac_shelf_u(I,j)) * hvel(k) + h_neglect
+ enddo
+ else
+ if (CS%use_GL90_in_SSW) then
+ do K=1,nz+1
+ a_cpl(K) = a_cpl(K) + a_cpl_gl90(K)
+ enddo
+
+ do K=1,nz+1
+ CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K))
+ enddo
+ endif
+
+ do K=1,nz+1
+ CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(K))
+ enddo
+
+ do k=1,nz
+ CS%h_u(I,j,k) = hvel(k) + h_neglect
+ enddo
+ endif
+
+ ! Diagnose total Kv at u-points
+ if (CS%id_Kv_u > 0) then
+ do k=1,nz
+ Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K) + CS%a_u(I,j,K+1)) * CS%h_u(I,j,k)
+ enddo
+ endif
+
+ ! Diagnose GL90 Kv at u-points
+ if (CS%id_Kv_gl90_u > 0) then
+ do k=1,nz
+ Kv_gl90_u(I,j,k) = 0.5 * (CS%a_u_gl90(I,j,K) + CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k)
+ enddo
+ endif
+ endif ; enddo ; enddo
+
+ ! Now work on v-points.
+
+ !$omp target teams distribute parallel do collapse(2) &
+ !$omp private(z_i, z_i_gl90, dz_harm, hvel, dz_vel, a_cpl, a_cpl_gl90, &
+ !$omp I_Hbbl, I_Hbbl_gl90, kv_bbl, bbl_thick, Dmin, zi_dir, zh, zcol, &
+ !$omp zcol_p1, h_harm, h_arith, h_delta, dz_arith, z2, botfn, z_clear, &
+ !$omp z2_wt, h_ml)
+ do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then
+ I_Hbbl = 1. / (CS%Hbbl + dz_neglect)
+ if (CS%use_GL90_in_SSW) then
+ I_Hbbl_gl90 = 1. / (CS%Hbbl_gl90 + dz_neglect)
+ endif
+
+ if (CS%bottomdraglaw) then
+ kv_bbl = visc%Kv_bbl_v(i,J)
+ bbl_thick = visc%bbl_thick_v(i,J) + dz_neglect
+ I_Hbbl = 1. / bbl_thick
+ endif
+
+ Dmin = min(G%bathyT(i,j), G%bathyT(i,j+1))
+ zi_dir = 0
+
+ ! Project thickness outward across OBCs using a zero-gradient condition.
+ if (associated(OBC)) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ Dmin = G%bathyT(i,j)
+ zi_dir = -1
endif
+ endif
- endif ; enddo ; enddo ! i & k loops
+ if (OBC%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ Dmin = G%bathyT(i,j+1)
+ zi_dir = 1
+ endif
+ endif
+ endif
+
+ z_i(nz+1) = 0.
+
+ if (.not. CS%harmonic_visc) then
+ zh = 0.
+ zcol = -G%bathyT(i,j)
+ zcol_p1 = -G%bathyT(i,j+1)
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.)
+ z_i_gl90(nz+1) = 0.
endif
- if ( allocated(hML_v)) then
- do i=is,ie ; if (do_i(i)) then ; hML_v(i,J) = h_ml(i) ; endif ; enddo
+ do k=nz,1,-1
+ h_harm = 2. * h(i,j,k) * h(i,j+1,k) / (h(i,j,k) + h(i,j+1,k) + h_neglect)
+ h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k))
+ h_delta = h(i,j+1,k) - h(i,j,k)
+ dz_harm(k) = 2. * dz(i,j,k) * dz(i,j+1,k) / (dz(i,j,k) + dz(i,j+1,k) + dz_neglect)
+ dz_arith = 0.5 * (dz(i,j+1,k) + dz(i,j,k))
+
+ ! Project thickness outward across OBCs using a zero-gradient condition.
+ if (associated(OBC)) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ h_harm = h(i,j,k)
+ h_arith = h(i,j,k)
+ h_delta = 0.
+ dz_harm(k) = dz(i,j,k)
+ dz_arith = dz(i,j,k)
+ endif
+ endif
+
+ if (OBC%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ h_harm = h(i,j+1,k)
+ h_arith = h(i,j+1,k)
+ h_delta = 0.
+ dz_harm(k) = dz(i,j+1,k)
+ dz_arith = dz(i,j+1,k)
+ endif
+ endif
+ endif
+
+ if (CS%harmonic_visc) then
+ ! The following block calculates the thicknesses at velocity grid points
+ ! for the vertical viscosity (hvel and dz_vel). Near the bottom an
+ ! upwind biased thickness is used to control the effect of spurious
+ ! Montgomery potential gradients at the bottom where nearly massless
+ ! layers ride over the topography.
+
+ hvel(k) = h_harm
+ dz_vel(k) = dz_harm(k)
+
+ if (v(i,J,k) * h_delta < 0) then
+ z2 = z_i(k+1)
+ botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2)
+
+ hvel(k) = (1. - botfn) * h_harm + botfn * h_arith
+ dz_vel(k) = (1. - botfn) * dz_harm(k) + botfn * dz_arith
+ endif
+
+ z_i(k) = z_i(k+1) + dz_harm(k) * I_Hbbl
+ else
+ zcol = zcol + dz(i,j,k)
+ zcol_p1 = zcol_p1 + dz(i,j+1,k)
+
+ zh = zh + dz_harm(k)
+
+ z_clear = max(zcol, zcol_p1) + Dmin
+ if (zi_dir < 0) z_clear = zcol + Dmin
+ if (zi_dir > 0) z_clear = zcol_p1 + Dmin
+
+ z_i(k) = max(zh, z_clear) * I_Hbbl
+
+ hvel(k) = h_arith
+ dz_vel(k) = dz_arith
+
+ if (v(i,J,k) * h_delta > 0) then
+ if (zh * I_Hbbl < CS%harm_BL_val) then
+ hvel(k) = h_harm
+ dz_vel(k) = dz_harm(k)
+ else
+ z2_wt = 1.
+ if (zh * I_Hbbl < 2. * CS%harm_BL_val) &
+ z2_wt = max(0., min(1., zh * I_Hbbl * I_valBL - 1.))
+
+ ! TODO: should z_clear be used here?
+ z2 = z2_wt * (max(zh, max(zcol, zcol_p1) + Dmin) * I_Hbbl)
+ botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2)
+
+ hvel(k) = (1. - botfn) * h_arith + botfn * h_harm
+ dz_vel(k) = (1. - botfn) * dz_arith + botfn * dz_harm(k)
+ endif
+ endif
+ endif
+
+ if (CS%use_GL90_in_SSW) then
+ ! The following block calculates the normalized height above the GL90 BBL
+ ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the
+ ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the
+ ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure
+ ! that no momentum gets fluxed into vanished layers. The scheme is not
+ ! sensitive to the exact value of Hbbl_gl90, as long as it is in a
+ ! reasonable range (~1-20 m): large enough to capture vanished layers
+ ! over topography, small enough to not contaminate the interior.
+
+ z_i_gl90(k) = z_i_gl90(k+1) + dz_harm(k) * I_Hbbl_gl90
+ endif
+ enddo
+
+ call find_coupling_coef_k(a_cpl, dz_vel, i, j, dz_harm, bbl_thick, kv_bbl, z_i, &
+ h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC)
+
+ if (allocated(hML_v)) hML_v(i,J) = h_ml
+
+ if (CS%use_GL90_in_SSW) then
+ call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, i, j, z_i_gl90, G, GV, &
+ CS, VarMix, work_on_u=.false.)
endif
+
do_any_shelf = .false.
if (associated(forces%frac_shelf_v)) then
- do i=is,ie
- CS%a1_shelf_v(i,J) = 0.0
- do_i_shelf(i) = (do_i(i) .and. forces%frac_shelf_v(i,J) > 0.0)
- if (do_i_shelf(I)) do_any_shelf = .true.
- enddo
+ CS%a1_shelf_v(i,J) = 0.
+ do_any_shelf = forces%frac_shelf_v(i,J) > 0.
+
if (do_any_shelf) then
- if (CS%harmonic_visc) then
- do k=1,nz ; do i=is,ie
- hvel_shelf(i,k) = hvel(i,k) ; 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=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))
+ ! Initialize non-harmonic depths
+ if (.not. CS%harmonic_visc) then
+ zh = 0.
+ Ztop_min = min(zcol, zcol_p1)
+ I_HTbl = 1. / (visc%tbl_thick_shelf_v(i,J) + dz_neglect)
+ endif
+
+ do k=1,nz
+ if (CS%harmonic_visc) then
+ hvel_shelf(k) = hvel(k)
+ dz_vel_shelf(k) = dz_vel(k)
+ else
+ ! Find upwind-biased thickness near the surface.
+ ! Perhaps this needs to be done more carefully, via find_eta.
+ h_harm = 2. * h(i,j,k) * h(i,j+1,k) &
+ / (h(i,j,k) + h(i,j+1,k) + h_neglect)
+ h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k))
+ h_delta = h(i,j+1,k) - h(i,j,k)
+ dz_arith = 0.5 * (dz(i,j+1,k) + dz(i,j,k))
+
+ ! Project thickness outward across OBCs using a zero-gradient condition.
+ if (associated(OBC)) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ h_harm = h(i,j,k)
+ h_arith = h(i,j,k)
+ h_delta = 0.
+ dz_arith = dz(i,j,k)
endif
- endif
- endif ; enddo
- enddo
+ endif
+
+ if (OBC%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ h_harm = h(i,j+1,k)
+ h_arith = h(i,j+1,k)
+ h_delta = 0.
+ dz_arith = dz(i,j+1,k)
+ endif
+ endif
+ endif
+
+ zcol = zcol - dz(i,j,k)
+ zcol_p1 = zcol_p1 - dz(i,j+1,k)
+
+ zh = zh + dz_harm(k)
+
+ hvel_shelf(k) = hvel(k)
+ dz_vel_shelf(k) = dz_vel(k)
+
+ if (v(i,J,k) * h_delta > 0.) then
+ if (zh * I_HTbl < CS%harm_BL_val) then
+ hvel_shelf(k) = min(hvel(k), h_harm)
+ dz_vel_shelf(k) = min(dz_vel(k), dz_harm(k))
+ else
+ z2_wt = 1.
+ if (zh * I_HTbl < 2. * CS%harm_BL_val) &
+ z2_wt = max(0., min(1., zh * I_HTbl * I_valBL - 1.))
+
+ z2 = z2_wt * (max(zh, Ztop_min - min(zcol, zcol_p1)) * I_HTbl)
+ ! TODO: Replace **6
+ topfn = 1. / (1. + 0.09 * z2**6)
+
+ hvel_shelf(k) = min(hvel(k), (1. - topfn) * h_arith + topfn * h_harm)
+ dz_vel_shelf(k) = min(dz_vel(k), (1. - topfn) * dz_arith + topfn * dz_harm(k))
+ endif
+ endif
+ endif
+ enddo
+
+ call find_coupling_coef(a_shelf, dz_vel_shelf, i, j, dz_harm, &
+ bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, &
+ tv, work_on_u=.false., OBC=OBC, shelf=.true.)
+
+ CS%a1_shelf_v(i,J) = a_shelf(1)
+ endif
+ endif
+
+ if (do_any_shelf) then
+ if (CS%use_GL90_in_SSW) then
+ do K=1,nz+1
+ CS%a_v(I,j,K) = min(a_cpl_max, (forces%frac_shelf_v(I,j) * a_shelf(K) + &
+ (1. - forces%frac_shelf_v(I,j)) * a_cpl(K)) + a_cpl_gl90(K))
+
+ ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH
+ ! CS%a_v(I,j,K) = min(a_cpl_max, forces%frac_shelf_v(I,j) * max(a_shelf(K), a_cpl(K)) + &
+ ! (1. - forces%frac_shelf_v(I,j)) * a_cpl(K))
+
+ CS%a_v_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K))
+ enddo
+ else
+ do K=1,nz+1
+ CS%a_v(I,j,K) = min(a_cpl_max, (forces%frac_shelf_v(I,j) * a_shelf(K) + &
+ (1. - forces%frac_shelf_v(I,j)) * a_cpl(K)))
+ ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH
+ ! CS%a_v(I,j,K) = min(a_cpl_max, forces%frac_shelf_v(I,j) * max(a_shelf(K), a_cpl(K)) + &
+ ! (1. - forces%frac_shelf_v(I,j)) * a_cpl(K))
+ enddo
+ endif
+
+ do k=1,nz
+ ! Should we instead take the inverse of the average of the inverses?
+ CS%h_v(I,j,k) = forces%frac_shelf_v(I,j) * hvel_shelf(k) &
+ + (1. - forces%frac_shelf_v(I,j)) * hvel(k) + h_neglect
+ enddo
+ else
+ if (CS%use_GL90_in_SSW) then
+ do K=1,nz+1
+ a_cpl(K) = a_cpl(K) + a_cpl_gl90(K)
+ enddo
+
+ do K=1,nz+1
+ CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(K))
+ enddo
+ endif
+
+ do K=1,nz+1
+ CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(K))
+ enddo
+
+ do k=1,nz
+ CS%h_v(i,J,k) = hvel(k) + h_neglect
+ enddo
+ endif
+
+ ! Diagnose total Kv at v-points
+ if (CS%id_Kv_v > 0) then
+ do k=1,nz
+ Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K) + CS%a_v(i,J,K+1)) * CS%h_v(i,J,k)
+ enddo
+ endif
+
+ ! Diagnose GL90 Kv at v-points
+ if (CS%id_Kv_gl90_v > 0) then
+ do k=1,nz
+ Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K) + CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k)
+ enddo
+ endif
+ endif ; enddo ; enddo
+
+ !$omp target exit data map(delete: z_i, z_i_gl90, dz_harm, hvel, dz_vel, a_cpl, a_cpl_gl90, &
+ !$omp& tv, varmix, hvel_shelf, dz_vel_shelf, a_shelf, hml_u, kv_u, kv_gl90_u)
+
+ ! These are used in diagnostics, so they need to be mapped back and forth
+ !$omp target exit data map(from: hML_u, kv_u, kv_gl90_u )
+ !$omp target exit data map(from: hML_v, kv_v, kv_gl90_v)
+
+ !$omp target exit data map(delete: Ustar_2d)
+
+ if (CS%debug) then
+ call uvchksum("loop vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, &
+ unscale=GV%H_to_m, scalar_pair=.true.)
+ call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, &
+ unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.)
+ if (allocated(hML_u) .and. allocated(hML_v)) &
+ call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, &
+ haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.)
+ endif
+
+! Offer diagnostic fields for averaging.
+ if (query_averaging_enabled(CS%diag)) then
+ if (associated(visc%Kv_slow) .and. (CS%id_Kv_slow > 0)) &
+ call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag)
+ if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag)
+ if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag)
+ if (CS%id_Kv_gl90_u > 0) call post_data(CS%id_Kv_gl90_u, Kv_gl90_u, CS%diag)
+ if (CS%id_Kv_gl90_v > 0) call post_data(CS%id_Kv_gl90_v, Kv_gl90_v, CS%diag)
+ if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag)
+ if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag)
+ if (CS%id_au_gl90_vv > 0) call post_data(CS%id_au_gl90_vv, CS%a_u_gl90, CS%diag)
+ if (CS%id_av_gl90_vv > 0) call post_data(CS%id_av_gl90_vv, CS%a_v_gl90, CS%diag)
+ if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag)
+ if (CS%id_h_v > 0) call post_data(CS%id_h_v, CS%h_v, CS%diag)
+ if (CS%id_hML_u > 0) call post_data(CS%id_hML_u, hML_u, CS%diag)
+ if (CS%id_hML_v > 0) call post_data(CS%id_hML_v, hML_v, CS%diag)
+ endif
+
+ if (allocated(hML_u)) deallocate(hML_u)
+ if (allocated(hML_v)) deallocate(hML_v)
+
+end subroutine vertvisc_coef
+
+!> Calculate the 'coupling coefficient' (a_cpl) at the interfaces.
+!! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent
+!! layer thicknesses are used to calculate a_cpl near the bottom.
+pure subroutine find_coupling_coef_k(a_cpl, hvel, i, j, h_harm, bbl_thick, kv_bbl, z_i, h_ml, &
+ dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf)
+ !$omp declare target
+ 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(SZK_(GV)+1), &
+ intent(out) :: a_cpl !< Coupling coefficient across interfaces [H T-1 ~> m s-1 or Pa s m-1]
+ real, dimension(SZK_(GV)), &
+ intent(in) :: hvel !< Distance between interfaces at velocity points [Z ~> m]
+ integer, intent(in) :: i !< Column i-index
+ integer, intent(in) :: j !< Column j-index
+ real, dimension(SZK_(GV)), &
+ intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity
+ !! grid point [Z ~> m]
+ real, intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m]
+ real, intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of
+ !! any depth-dependent contributions from
+ !! visc%Kv_shear [H Z T-1 ~> m2 s-1 or Pa s]
+ real, dimension(SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the bottom,
+ !! normalized by the bottom boundary layer thickness [nondim]
+ real, intent(out) :: h_ml !< Mixed layer depth [Z ~> m]
+ real, intent(in) :: dt !< Time increment [T ~> s]
+ 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
+ !! the Boussinesq reference density or the
+ !! time-evolving surface density in non-Boussinesq
+ !! mode [Z T-1 ~> m s-1]
+ type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available
+ !! thermodynamic fields.
+ logical, intent(in) :: work_on_u !< If true, u-points are being calculated,
+ !! otherwise they are v-points
+ type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure
+ logical, optional, intent(in) :: shelf !< If present and true, use a surface boundary
+ !! condition appropriate for an ice shelf.
+
+ real :: u_star ! ustar at a velocity point [Z T-1 ~> m s-1]
+ real :: tau_mag ! The magnitude of the wind stress at a velocity point including gustiness [H Z T-2 ~> m2 s-2 or Pa]
+ real :: absf ! The average of the neighboring absolute values of f [T-1 ~> s-1].
+ real :: rho_av1 ! The harmonic mean surface layer density at velocity points [R ~> kg m-3]
+ real :: z_t ! The distance from the top, sometimes normalized
+ ! by Hmix, [Z ~> m] or [nondim].
+ real :: kv_TBL ! The viscosity in a top boundary layer under ice [H Z T-1 ~> m2 s-1 or Pa s]
+ real :: tbl_thick ! The thickness of the top boundary layer [Z ~> m]
+ real :: Kv_add ! A viscosity to add [H Z T-1 ~> m2 s-1 or Pa s]
+ real :: Kv_tot ! The total viscosity at an interface [H Z T-1 ~> m2 s-1 or Pa s]
+ integer :: nk_in_ml ! The index of the deepest interface in the mixed layer.
+ real :: h_shear ! The distance over which shears occur [Z ~> m].
+ real :: dhc ! The distance between the center of adjacent layers [Z ~> m].
+ real :: visc_ml ! The mixed layer viscosity [H Z T-1 ~> m2 s-1 or Pa s].
+ real :: I_Hmix ! The inverse of the mixed layer thickness [Z-1 ~> m-1].
+ real :: a_ml ! The layer coupling coefficient across an interface in
+ ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1].
+ real :: a_floor ! A lower bound on the layer coupling coefficient across an interface in
+ ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1].
+ real :: I_amax ! The inverse of the maximum coupling coefficient [T H-1 ~> s m-1 or s m2 kg-1].
+ real :: temp1 ! A temporary variable [Z2 ~> m2]
+ real :: ustar2_denom ! A temporary variable in the surface boundary layer turbulence
+ ! calculations [H Z-1 T-1 ~> s-1 or kg m-3 s-1]
+ real :: h_neglect ! A vertical distance that is so small it is usually lost
+ ! in roundoff and can be neglected [Z ~> m].
+ real :: z2 ! A copy of z_i [nondim]
+ real :: botfn ! A function that is 1 at the bottom and small far from it [nondim]
+ real :: topfn ! A function that is 1 at the top and small far from it [nondim]
+ real :: kv_top ! A viscosity associated with the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s]
+ logical :: do_shelf, do_OBCs, can_exit
+ integer :: k
+ integer :: nz, max_nk
+
+ nz = GV%ke
+
+ h_neglect = GV%dZ_subroundoff
+
+ if (CS%answer_date < 20190101) then
+ ! The maximum coupling coefficient was originally introduced to avoid
+ ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10
+ ! sets the maximum coupling coefficient increment to 1e10 m per timestep.
+ I_amax = (1.0e-10*GV%H_to_m) * dt
+ else
+ I_amax = 0.0
+ endif
+
+ do_shelf = .false. ; if (present(shelf)) do_shelf = shelf
+
+ do_OBCs = .false.
+ !if (associated(OBC)) then
+ ! if (work_on_u) then
+ ! do_OBCS = OBC%u_E_OBCs_on_PE .or. OBC%u_W_OBCs_on_PE
+ ! else
+ ! do_OBCS = OBC%v_N_OBCs_on_PE .or. OBC%v_S_OBCs_on_PE
+ ! endif
+ !endif
+
+ a_cpl(:) = 0.
+ h_ml = 0.
+
+ if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then
+ I_Hmix = 1. / (CS%Hmix + h_neglect)
+ z_t = h_neglect * I_Hmix
+ endif
+
+ do K=2,nz
+ Kv_tot = CS%Kv
+
+ if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then
+ ! This is an older (vintage ~1997) way to prevent wind stresses from driving very
+ ! large flows in nearly massless near-surface layers when there is not a physically-
+ ! based surface boundary layer parameterization. It does not have a plausible
+ ! physical basis, and probably should not be used.
+ z_t = z_t + h_harm(k-1) * I_Hmix
+ Kv_tot = CS%Kv + CS%Kvml_invZ2 / ((z_t * z_t) * &
+ (1. + 0.09 * z_t * z_t * z_t * z_t * z_t * z_t))
+ endif
+
+ if (associated(visc%Kv_shear)) then
+ ! Add in viscosities that are determined by physical processes that are handled in
+ ! other modules, and which do not respond immediately to the changing layer thicknesses.
+ ! These processes may include shear-driven mixing or contributions from some boundary
+ ! layer turbulence schemes. Other viscosity contributions that respond to the evolving
+ ! layer thicknesses or the surface wind stresses are added later.
+ if (work_on_u) then
+ Kv_add = 0.5 * (visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k))
+
+ if (do_OBCs) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ Kv_add = visc%Kv_shear(i,j,k)
+ endif
+ endif
+
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ Kv_add = visc%Kv_shear(i+1,j,k)
+ endif
+ endif
+ endif
+
+ Kv_tot = Kv_tot + Kv_add
+ else
+ Kv_add = 0.5 * (visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k))
+
+ if (do_OBCs) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ Kv_add = visc%Kv_shear(i,j,k)
+ endif
+ endif
+
+ if (OBC%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ Kv_add = visc%Kv_shear(i,j+1,k)
+ endif
+ endif
+ endif
+
+ Kv_tot = Kv_tot + Kv_add
+ endif
+ 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
+ Kv_tot = Kv_tot + 0.5 * (visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k))
+ else
+ Kv_tot = Kv_tot + 0.5 * (visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k))
+ endif
+ endif
+
+ ! 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
+ ! botfn determines when a point is within the influence of the bottom
+ ! boundary layer, going from 1 at the bottom to 0 in the interior.
+ z2 = z_i(k)
+ botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2)
+
+ Kv_tot = Kv_tot + (kv_bbl - CS%Kv) * botfn
+ dhc = 0.5 * (hvel(k) + hvel(k-1))
+ if (dhc > bbl_thick) then
+ h_shear = ((1. - botfn) * dhc + botfn * bbl_thick) + h_neglect
+ else
+ h_shear = dhc + h_neglect
+ endif
+
+ ! Calculate the coupling coefficients from the viscosities.
+ a_cpl(K) = Kv_tot / (h_shear + (I_amax * Kv_tot))
+ elseif (abs(CS%Kv_extra_bbl) > 0.0) then
+ ! There is a simple enhancement of the near-bottom viscosities, but no
+ ! adjustment of the viscous coupling length scales to give a particular
+ ! bottom stress.
+
+ ! botfn determines when a point is within the influence of the bottom
+ ! boundary layer, going from 1 at the bottom to 0 in the interior.
+ z2 = z_i(k)
+ botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2)
+
+ Kv_tot = Kv_tot + CS%Kv_extra_bbl * botfn
+ h_shear = 0.5 * (hvel(k) + hvel(k-1) + h_neglect)
+
+ ! Calculate the coupling coefficients from the viscosities.
+ a_cpl(K) = Kv_tot / (h_shear + I_amax * Kv_tot)
+ else
+ ! Any near-bottom viscous enhancements were already incorporated into
+ ! Kv_tot, and there is no adjustment of the viscous coupling length
+ ! scales to give a particular bottom stress.
+
+ h_shear = 0.5 * (hvel(k) + hvel(k-1) + h_neglect)
+ ! Calculate the coupling coefficients from the viscosities.
+ a_cpl(K) = Kv_tot / (h_shear + I_amax * Kv_tot)
+ endif
+ enddo
+
+ ! Assign the bottom coupling coefficients
+ if (CS%bottomdraglaw) then
+ dhc = hvel(nz) * 0.5
+ a_cpl(nz+1) = kv_bbl / ((min(dhc, bbl_thick) + h_neglect) + I_amax * kv_bbl)
+ elseif (abs(CS%Kv_extra_bbl) > 0.0) then
+ a_cpl(nz+1) = (CS%Kv + CS%Kv_extra_bbl) &
+ / ((0.5 * hvel(nz) + h_neglect) + I_amax * (CS%Kv + CS%Kv_extra_bbl))
+ else
+ a_cpl(nz+1) = CS%Kv / ((0.5 * hvel(nz) + h_neglect) + I_amax * CS%Kv)
+ endif
+
+ ! Add surface intensified viscous coupling, either as a no-slip boundary condition under a
+ ! rigid ice-shelf, or due to wind-stress driven surface boundary layer mixing that has not
+ ! already been added via visc%Kv_shear.
+ if (do_shelf) then
+ ! Set the coefficients to include the no-slip surface stress.
+ if (work_on_u) then
+ kv_TBL = visc%Kv_tbl_shelf_u(I,j)
+ tbl_thick = visc%tbl_thick_shelf_u(I,j) + h_neglect
+ else
+ kv_TBL = visc%Kv_tbl_shelf_v(i,J)
+ tbl_thick = visc%tbl_thick_shelf_v(i,J) + h_neglect
+ endif
+ z_t = 0.0
+
+ ! If a_cpl(1) were not already 0, it would be added here.
+ if (0.5 * hvel(1) > tbl_thick) then
+ a_cpl(1) = kv_TBL / (tbl_thick + I_amax * kv_TBL)
+ else
+ a_cpl(1) = kv_TBL / ((0.5 * hvel(1) + h_neglect) + I_amax * kv_TBL)
+ endif
+
+ do K=2,nz
+ z_t = z_t + hvel(k-1) / tbl_thick
+ topfn = 1. / (1. + 0.09 * z_t**6)
+
+ dhc = 0.5 * (hvel(k) + hvel(k-1))
+ if (dhc > tbl_thick) then
+ h_shear = ((1. - topfn) * dhc + topfn * tbl_thick) + h_neglect
+ else
+ h_shear = dhc + h_neglect
+ endif
+
+ kv_top = topfn * kv_TBL
+ a_cpl(K) = a_cpl(K) + kv_top / (h_shear + I_amax * kv_top)
+ enddo
+ elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then
+
+ ! Find the friction velocity and the absolute value of the Coriolis parameter at this point.
+ ! Zero out the friction velocity on land points.
+ u_star = 0.
+ tau_mag = 0.
+
+ if (allocated(tv%SpV_avg)) then
+ rho_av1 = 0.
+
+ if (work_on_u) then
+ u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j))
+ rho_av1 = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1))
+ absf = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J)))
+
+ if (do_OBCs) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ u_star = Ustar_2d(i,j)
+ rho_av1 = 1. / tv%SpV_avg(i,j,1)
+ endif
+ endif
+
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ u_star = Ustar_2d(i+1,j)
+ rho_av1 = 1. / tv%SpV_avg(i+1,j,1)
+ endif
+ endif
+ endif
+ else
+ u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1))
+ rho_av1 = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1))
+ absf = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J)))
+
+ if (do_OBCs) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ u_star = Ustar_2d(i,j)
+ rho_av1 = 1. / tv%SpV_avg(i,j,1)
+ endif
+ endif
+
+ if (OBC%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ u_star = Ustar_2d(i,j+1)
+ rho_av1 = 1. / tv%SpV_avg(i,j+1,1)
+ endif
+ endif
+ endif
+ endif
+
+ tau_mag = GV%RZ_to_H * rho_av1 * u_star**2
+ else ! (.not.allocated(tv%SpV_avg))
+ if (work_on_u) then
+ u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j))
+ absf = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J)))
+
+ if (do_OBCs) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ u_star = Ustar_2d(i,j)
+ endif
+ endif
+
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ u_star = Ustar_2d(i+1,j)
+ endif
+ endif
+ endif
+ else
+ u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1))
+ absf = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J)))
+
+ if (do_OBCs) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ u_star = Ustar_2d(i,j)
+ endif
+ endif
+
+ if (OBC%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ u_star = Ustar_2d(i,j+1)
+ endif
+ endif
+ endif
+ endif
+
+ tau_mag = GV%Z_to_H * u_star**2
+ endif
+
+ ! Determine the thickness of the surface ocean boundary layer and its extent in index space.
+ nk_in_ml = 0
+
+ if (CS%dynamic_viscous_ML) then
+ ! The fractional number of layers that are within the viscous boundary layer were
+ ! previously stored in visc%nkml_visc_[uv].
+ h_ml = h_neglect
+ max_nk = 0
+
+ if (work_on_u) then
+ nk_in_ml = ceiling(visc%nkml_visc_u(I,j))
+ max_nk = max(max_nk, nk_in_ml)
+
+ do k=1,max_nk
+ if (k <= visc%nkml_visc_u(I,j)) then ! This layer is all in the ML.
+ h_ml = h_ml + hvel(k)
+ elseif (k < visc%nkml_visc_u(I,j) + 1.) then ! Part of this layer is in the ML.
+ h_ml = h_ml + ((visc%nkml_visc_u(I,j) + 1.) - k) * hvel(k)
+ endif
+ enddo
+ else
+ nk_in_ml = ceiling(visc%nkml_visc_v(i,J))
+ max_nk = max(max_nk, nk_in_ml)
+
+ do k=1,max_nk
+ if (k <= visc%nkml_visc_v(i,J)) then ! This layer is all in the ML.
+ h_ml = h_ml + hvel(k)
+ elseif (k < visc%nkml_visc_v(i,J) + 1.) then ! Part of this layer is in the ML.
+ h_ml = h_ml + ((visc%nkml_visc_v(i,J) + 1.) - k) * hvel(k)
+ endif
+ enddo
+ endif
+ elseif (GV%nkml>0) then
+ ! This is a simple application of a refined-bulk mixed layer with GV%nkml sublayers.
+ max_nk = GV%nkml
+ nk_in_ml = GV%nkml
+
+ h_ml = h_neglect
+
+ do k=1,GV%nkml
+ h_ml = h_ml + hvel(k)
+ enddo
+ elseif (CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then
+ ! Determine which interfaces are within CS%Hmix of the surface, and set the viscous
+ ! boundary layer thickness to the the smaller of CS%Hmix and the depth of the ocean.
+ h_ml = 0.0
+ do k=1,nz
+ can_exit = .true.
+ if (h_ml < CS%Hmix) then
+ nk_in_ml = k
+
+ if (h_ml + hvel(k) < CS%Hmix) then
+ h_ml = h_ml + hvel(k)
+ can_exit = .false. ! Part of the next deeper layer is also in the mixed layer.
+ else
+ h_ml = CS%Hmix
+ endif
+ endif
+
+ if (can_exit) exit ! All remaining layers in this row are below the mixed layer depth.
+ enddo
+
+ ! This made more sense in the slab/layer solvers...
+ max_nk = 0
+ max_nk = max(max_nk, nk_in_ml)
+ endif
+
+ ! Avoid working on land or on columns where the viscous coupling could not be increased.
+ if (u_star <= 0.) nk_in_ml = 0
+
+ ! Set the viscous coupling at the interfaces as the larger of what was previously
+ ! set and the contributions from the surface boundary layer.
+ z_t = 0.0
+ if (CS%apply_LOTW_floor .and. &
+ (CS%dynamic_viscous_ML .or. GV%nkml > 0 .or. CS%fixed_LOTW_ML)) then
+ do K=2,max_nk
+ if (k <= nk_in_ml) then
+ z_t = z_t + hvel(k-1)
+
+ ! The viscosity in visc_ml is set to go to 0 at the mixed layer top and bottom
+ ! (in a log-layer) and be further limited by rotation to give the natural Ekman length.
+ temp1 = (z_t * h_ml - z_t * z_t)
+ if (GV%Boussinesq) then
+ ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star**2) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ else
+ ustar2_denom = (CS%vonKar * tau_mag) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ endif
+
+ visc_ml = temp1 * ustar2_denom
+ ! Set the viscous coupling based on the model's vertical resolution. The omission of
+ ! the I_amax factor here is consistent with answer dates above 20190101.
+ a_ml = visc_ml / (0.25 * (hvel(k) + hvel(k-1) + h_neglect))
+
+ ! As a floor on the viscous coupling, assume that the length scale in the denominator can
+ ! not be larger than the distance from the surface, consistent with a logarithmic velocity
+ ! profile. This is consistent with visc_ml, but cancels out common factors of z_t.
+ a_floor = (h_ml - z_t) * ustar2_denom
+
+ ! Choose the largest estimate of a_cpl.
+ a_cpl(K) = max(a_cpl(K), a_ml, a_floor)
+ ! An option could be added to change this to: a_cpl(i,K) = max(a_cpl(i,K) + a_ml, a_floor)
endif
- 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
- endif
- endif
+ enddo
+ elseif (CS%apply_LOTW_floor) then
+ do K=2,max_nk
+ if (k <= nk_in_ml) then
+ z_t = z_t + hvel(k-1)
+
+ temp1 = (z_t * h_ml - z_t * z_t)
+ if (GV%Boussinesq) then
+ ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star**2) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ else
+ ustar2_denom = (CS%vonKar * tau_mag) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ endif
- 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))
- 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
- 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.
+ a_cpl(K) = max(a_cpl(K), (h_ml - z_t) * ustar2_denom)
+ endif
+ 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 ; 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 ; 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
+ do K=2,max_nk
+ if (k <= nk_in_ml) then
+ z_t = z_t + hvel(k-1)
+
+ temp1 = (z_t * h_ml - z_t * z_t)
+ ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer)
+ ! and be further limited by rotation to give the natural Ekman length.
+ ! The following expressions are mathematically equivalent.
+ if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then
+ visc_ml = u_star * CS%vonKar * (GV%Z_to_H * temp1 * u_star) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ else
+ visc_ml = CS%vonKar * (temp1 * tau_mag) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ endif
+ a_ml = visc_ml / (0.25 * (hvel(k) + hvel(k-1) + h_neglect) + 0.5 * I_amax * visc_ml)
- ! 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
- 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)
- enddo ; enddo
+ ! Choose the largest estimate of a_cpl, but these could be changed to be additive.
+ a_cpl(K) = max(a_cpl(K), a_ml)
+ ! An option could be added to change this to: a_cpl(i,K) = a_cpl(i,K) + a_ml
+ endif
+ enddo
endif
- enddo ! end of v-point j loop
-
- if (CS%debug) then
- call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, &
- unscale=GV%H_to_m, scalar_pair=.true.)
- call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, &
- unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.)
- if (allocated(hML_u) .and. allocated(hML_v)) &
- call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, &
- haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.)
- endif
-
-! Offer diagnostic fields for averaging.
- if (query_averaging_enabled(CS%diag)) then
- if (associated(visc%Kv_slow) .and. (CS%id_Kv_slow > 0)) &
- call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag)
- if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag)
- if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag)
- if (CS%id_Kv_gl90_u > 0) call post_data(CS%id_Kv_gl90_u, Kv_gl90_u, CS%diag)
- if (CS%id_Kv_gl90_v > 0) call post_data(CS%id_Kv_gl90_v, Kv_gl90_v, CS%diag)
- if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag)
- if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag)
- if (CS%id_au_gl90_vv > 0) call post_data(CS%id_au_gl90_vv, CS%a_u_gl90, CS%diag)
- if (CS%id_av_gl90_vv > 0) call post_data(CS%id_av_gl90_vv, CS%a_v_gl90, CS%diag)
- if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag)
- if (CS%id_h_v > 0) call post_data(CS%id_h_v, CS%h_v, CS%diag)
- if (CS%id_hML_u > 0) call post_data(CS%id_hML_u, hML_u, CS%diag)
- if (CS%id_hML_v > 0) call post_data(CS%id_hML_v, hML_v, CS%diag)
endif
+end subroutine find_coupling_coef_k
- if (allocated(hML_u)) deallocate(hML_u)
- if (allocated(hML_v)) deallocate(hML_v)
-
-end subroutine vertvisc_coef
!> Calculate the 'coupling coefficient' (a_cpl) at the interfaces.
!! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent
!! layer thicknesses are used to calculate a_cpl near the bottom.
-subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, &
- dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf)
+subroutine find_coupling_coef(a_cpl, hvel, i, j, h_harm, bbl_thick, kv_bbl, z_i, h_ml, &
+ dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf)
+ !$omp declare target
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(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(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 for a column
- real, dimension(SZIB_(G),SZK_(GV)), &
+ integer, intent(in) :: i !< Column i-index
+ integer, intent(in) :: j !< Column j-index
+ real, dimension(SZK_(GV)), &
intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity
!! grid point [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, intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m]
+ real, intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of
!! any depth-dependent contributions from
!! visc%Kv_shear [H Z T-1 ~> m2 s-1 or Pa s]
- real, dimension(SZIB_(G),SZK_(GV)+1), &
+ real, dimension(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, 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 +2648,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 :: &
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 +2656,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 :: &
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 +2680,11 @@ 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
+ integer :: k
+ integer :: nz, max_nk
- a_cpl(:,:) = 0.0
- Kv_tot(:,:) = 0.0
-
- if (work_on_u) then ; is = G%IscB ; ie = G%IecB
- else ; is = G%isc ; ie = G%iec ; endif
nz = GV%ke
+
h_neglect = GV%dZ_subroundoff
if (CS%answer_date < 20190101) then
@@ -1873,143 +2697,146 @@ 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 ((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
- 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 (associated(OBC)) then
if (work_on_u) then
- do K=2,nz ; do i=is,ie ; if (do_i(i)) then
- Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k))
- endif ; enddo ; enddo
- if (do_OBCs) then
- do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then
- if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then
- do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo
- elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then
- do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i+1,j,k) ; enddo
- 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
+ do_OBCS = OBC%u_E_OBCs_on_PE .or. OBC%u_W_OBCs_on_PE
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
+ do_OBCS = OBC%v_N_OBCs_on_PE .or. OBC%v_S_OBCs_on_PE
+ endif
+ endif
+
+ a_cpl(:) = 0.
+ h_ml = 0.
+
+ if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then
+ I_Hmix = 1. / (CS%Hmix + h_neglect)
+ z_t = h_neglect * I_Hmix
+ endif
+
+ do K=2,nz
+ Kv_tot = CS%Kv
+
+ if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then
+ ! This is an older (vintage ~1997) way to prevent wind stresses from driving very
+ ! large flows in nearly massless near-surface layers when there is not a physically-
+ ! based surface boundary layer parameterization. It does not have a plausible
+ ! physical basis, and probably should not be used.
+ z_t = z_t + h_harm(k-1) * I_Hmix
+ Kv_tot = CS%Kv + CS%Kvml_invZ2 / ((z_t * z_t) * &
+ (1. + 0.09 * z_t * z_t * z_t * z_t * z_t * z_t))
+ endif
+
+ if (associated(visc%Kv_shear)) then
+ ! Add in viscosities that are determined by physical processes that are handled in
+ ! other modules, and which do not respond immediately to the changing layer thicknesses.
+ ! These processes may include shear-driven mixing or contributions from some boundary
+ ! layer turbulence schemes. Other viscosity contributions that respond to the evolving
+ ! layer thicknesses or the surface wind stresses are added later.
+ if (work_on_u) then
+ Kv_add = 0.5 * (visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k))
+
+ if (do_OBCs) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ Kv_add = visc%Kv_shear(i,j,k)
+ endif
+ endif
+
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ Kv_add = visc%Kv_shear(i+1,j,k)
+ endif
+ endif
+ endif
+
+ Kv_tot = Kv_tot + Kv_add
+ else
+ Kv_add = 0.5 * (visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k))
+
+ if (do_OBCs) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ Kv_add = visc%Kv_shear(i,j,k)
+ endif
+ endif
+
+ if (OBC%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ Kv_add = visc%Kv_shear(i,j+1,k)
+ endif
endif
- endif ; enddo
+ endif
+
+ Kv_tot = Kv_tot + Kv_add
endif
- do K=2,nz ; do i=is,ie ; if (do_i(i)) then
- Kv_tot(i,K) = Kv_tot(i,K) + Kv_add(i,K)
- endif ; enddo ; enddo
endif
- endif
- if (associated(visc%Kv_shear_Bu)) then
- ! 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
- else
- do K=2,nz ; do i=is,ie ; if (do_i(i)) then
- Kv_tot(i,K) = Kv_tot(i,K) + 0.5*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k))
- endif ; enddo ; enddo
+ if (associated(visc%Kv_shear_Bu)) then
+ ! This is similar to what was done above, but for contributions coming from the corner
+ ! (vorticity) points. Because OBCs run through the faces and corners there is no need
+ ! to further modify these viscosities here to take OBCs into account.
+ if (work_on_u) then
+ Kv_tot = Kv_tot + 0.5 * (visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k))
+ else
+ Kv_tot = Kv_tot + 0.5 * (visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k))
+ endif
endif
- endif
- ! 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 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
+ ! 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
! 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)
+ z2 = z_i(k)
+ botfn = 1. / (1. + 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
+ Kv_tot = Kv_tot + (kv_bbl - CS%Kv) * botfn
+ dhc = 0.5 * (hvel(k) + hvel(k-1))
+ if (dhc > bbl_thick) then
+ h_shear = ((1. - botfn) * dhc + botfn * bbl_thick) + h_neglect
else
h_shear = 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
- 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
+ a_cpl(K) = Kv_tot / (h_shear + (I_amax * Kv_tot))
+ elseif (abs(CS%Kv_extra_bbl) > 0.0) then
+ ! There is a simple enhancement of the near-bottom viscosities, but no
+ ! adjustment of the viscous coupling length scales to give a particular
+ ! bottom stress.
+
! botfn determines when a point is within the influence of the bottom
! boundary layer, going from 1 at the bottom to 0 in the interior.
- z2 = z_i(i,k)
- botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2)
+ z2 = z_i(k)
+ botfn = 1. / (1. + 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)
+ Kv_tot = Kv_tot + CS%Kv_extra_bbl * botfn
+ h_shear = 0.5 * (hvel(k) + hvel(k-1) + h_neglect)
! Calculate the coupling coefficients from the viscosities.
- a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K))
- endif ; enddo ; enddo ! i & k loops
- 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)
+ a_cpl(K) = Kv_tot / (h_shear + I_amax * Kv_tot)
+ 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.
+
+ h_shear = 0.5 * (hvel(k) + hvel(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
+ a_cpl(K) = Kv_tot / (h_shear + I_amax * Kv_tot)
+ endif
+ enddo
+
+ ! Assign the bottom coupling coefficients
+ if (CS%bottomdraglaw) then
+ dhc = hvel(nz) * 0.5
+ a_cpl(nz+1) = kv_bbl / ((min(dhc, bbl_thick) + h_neglect) + I_amax * kv_bbl)
+ elseif (abs(CS%Kv_extra_bbl) > 0.0) then
+ a_cpl(nz+1) = (CS%Kv + CS%Kv_extra_bbl) &
+ / ((0.5 * hvel(nz) + h_neglect) + I_amax * (CS%Kv + CS%Kv_extra_bbl))
+ else
+ a_cpl(nz+1) = CS%Kv / ((0.5 * hvel(nz) + h_neglect) + I_amax * CS%Kv)
endif
! Add surface intensified viscous coupling, either as a no-slip boundary condition under a
@@ -2017,250 +2844,281 @@ 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
- 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
- else
- kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J)
- tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) + h_neglect
- endif
- z_t(i) = 0.0
+ if (work_on_u) then
+ kv_TBL = visc%Kv_tbl_shelf_u(I,j)
+ tbl_thick = visc%tbl_thick_shelf_u(I,j) + h_neglect
+ else
+ kv_TBL = visc%Kv_tbl_shelf_v(i,J)
+ tbl_thick = visc%tbl_thick_shelf_v(i,J) + h_neglect
+ endif
- ! 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))
- else
- a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect) + I_amax*kv_TBL(i))
- endif
- endif ; enddo
+ z_t = 0.0
+
+ ! If a_cpl(1) were not already 0, it would be added here.
+ if (0.5 * hvel(1) > tbl_thick) then
+ a_cpl(1) = kv_TBL / (tbl_thick + I_amax * kv_TBL)
+ else
+ a_cpl(1) = kv_TBL / ((0.5 * hvel(1) + h_neglect) + I_amax * kv_TBL)
+ endif
- do K=2,nz ; 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)
+ do K=2,nz
+ z_t = z_t + hvel(k-1) / tbl_thick
+ topfn = 1. / (1. + 0.09 * z_t**6)
- dhc = 0.5*(hvel(i,k)+hvel(i,k-1))
- if (dhc > tbl_thick(i)) then
- h_shear = ((1.0 - topfn) * dhc + topfn*tbl_thick(i)) + h_neglect
+ dhc = 0.5 * (hvel(k) + hvel(k-1))
+ if (dhc > tbl_thick) then
+ h_shear = ((1. - topfn) * dhc + topfn * tbl_thick) + h_neglect
else
h_shear = dhc + h_neglect
endif
- 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
-
+ kv_top = topfn * kv_TBL
+ a_cpl(K) = a_cpl(K) + kv_top / (h_shear + I_amax * kv_top)
+ enddo
elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then
! Find the friction velocity and the absolute value of the Coriolis parameter at this point.
- u_star(:) = 0.0 ! Zero out the friction velocity on land points.
- tau_mag(:) = 0.0 ! Zero out the friction velocity on land points.
+ u_star = 0. ! Zero out the friction velocity on land points.
+ tau_mag = 0. ! Zero out the friction velocity on land points.
if (allocated(tv%SpV_avg)) then
- rho_av1(:) = 0.0
+ rho_av1 = 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)
+ u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j))
+ rho_av1 = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1))
+ absf = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J)))
+
+ if (do_OBCs) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ u_star = Ustar_2d(i,j)
+ rho_av1 = 1. / tv%SpV_avg(i,j,1)
+ endif
+ endif
+
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ u_star = Ustar_2d(i+1,j)
+ rho_av1 = 1. / tv%SpV_avg(i+1,j,1)
+ endif
+ endif
+ endif
+ else
+ u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1))
+ rho_av1 = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1))
+ absf = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J)))
+
+ if (do_OBCs) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ u_star = Ustar_2d(i,j)
+ rho_av1 = 1. / tv%SpV_avg(i,j,1)
+ endif
endif
- 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%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ u_star = Ustar_2d(i,j+1)
+ rho_av1 = 1. / tv%SpV_avg(i,j+1,1)
+ endif
endif
- endif ; enddo ; endif
+ endif
endif
- do I=is,ie
- tau_mag(I) = GV%RZ_to_H*rho_av1(i) * u_star(I)**2
- enddo
+
+ tau_mag = GV%RZ_to_H * rho_av1 * u_star**2
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
+ u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j))
+ absf = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J)))
+
+ if (do_OBCs) then
+ if (OBC%u_E_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) > 0) then
+ u_star = Ustar_2d(i,j)
+ endif
+ endif
+
+ if (OBC%u_W_OBCs_on_PE) then
+ if (OBC%segnum_u(I,j) < 0) then
+ u_star = Ustar_2d(i+1,j)
+ endif
+ endif
+ endif
else
- 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
+ u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1))
+ absf = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J)))
+
+ if (do_OBCs) then
+ if (OBC%v_N_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) > 0) then
+ u_star = Ustar_2d(i,j)
+ endif
+ endif
+
+ if (OBC%v_S_OBCs_on_PE) then
+ if (OBC%segnum_v(i,J) < 0) then
+ u_star = Ustar_2d(i,j+1)
+ endif
+ endif
+ endif
endif
- do I=is,ie
- tau_mag(I) = GV%Z_to_H*u_star(I)**2
- enddo
+
+ tau_mag = GV%Z_to_H * u_star**2
endif
! Determine the thickness of the surface ocean boundary layer and its extent in index space.
- nk_in_ml(:) = 0
+ 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
+ nk_in_ml = ceiling(visc%nkml_visc_u(I,j))
+ max_nk = max(max_nk, nk_in_ml)
+
+ do k=1,max_nk
if (k <= visc%nkml_visc_u(I,j)) then ! This layer is all in the ML.
- h_ml(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)
+ h_ml = h_ml + hvel(k)
+ elseif (k < visc%nkml_visc_u(I,j) + 1.) then ! Part of this layer is in the ML.
+ h_ml = h_ml + ((visc%nkml_visc_u(I,j) + 1.) - k) * hvel(k)
endif
- 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
+ nk_in_ml = ceiling(visc%nkml_visc_v(i,J))
+ max_nk = max(max_nk, nk_in_ml)
+
+ do k=1,max_nk
if (k <= visc%nkml_visc_v(i,J)) then ! This layer is all in the ML.
- h_ml(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)
+ h_ml = h_ml + hvel(k)
+ elseif (k < visc%nkml_visc_v(i,J) + 1.) then ! Part of this layer is in the ML.
+ h_ml = h_ml + ((visc%nkml_visc_v(i,J) + 1.) - k) * hvel(k)
endif
- 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
+ nk_in_ml = GV%nkml
- 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)
- endif ; enddo ; enddo
+ h_ml = h_neglect
+
+ do k=1,GV%nkml
+ h_ml = h_ml + hvel(k)
+ enddo
elseif (CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then
! Determine which interfaces are within CS%Hmix of the surface, and set the viscous
- ! boundary layer thickness to the the smaller of CS%Hmix and the depth of the ocean.
- h_ml(:) = 0.0
+ ! boundary layer thickness to the smaller of CS%Hmix and the depth of the ocean.
+ h_ml = 0.0
do k=1,nz
can_exit = .true.
- 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)
+ if (h_ml < CS%Hmix) then
+ nk_in_ml = k
+
+ if (h_ml + hvel(k) < CS%Hmix) then
+ h_ml = h_ml + hvel(k)
can_exit = .false. ! Part of the next deeper layer is also in the mixed layer.
else
- h_ml(i) = CS%Hmix
+ h_ml = CS%Hmix
endif
- endif ; enddo
+ endif
+
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
+
+ max_nk = max(0, nk_in_ml)
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
+ ! Avoid working on columns where the viscous coupling could not be increased.
+ if (u_star <= 0.) nk_in_ml = 0
! Set the viscous coupling at the interfaces as the larger of what was previously
! set and the contributions from the surface boundary layer.
- z_t(:) = 0.0
+ z_t = 0.
if (CS%apply_LOTW_floor .and. &
- (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML)) then
- do K=2,max_nk ; 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))
+ (CS%dynamic_viscous_ML .or. GV%nkml > 0 .or. CS%fixed_LOTW_ML)) then
+ do K=2,max_nk
+ if (k <= nk_in_ml) then
+ z_t = z_t + hvel(k-1)
+
+ ! The viscosity in visc_ml is set to go to 0 at the mixed layer top and bottom
+ ! (in a log-layer) and be further limited by rotation to give the natural Ekman length.
+ temp1 = (z_t * h_ml - z_t * z_t)
+ if (GV%Boussinesq) then
+ ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star**2) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ else
+ ustar2_denom = (CS%vonKar * tau_mag) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ endif
+
+ visc_ml = temp1 * ustar2_denom
+ ! Set the viscous coupling based on the model's vertical resolution. The omission of
+ ! the I_amax factor here is consistent with answer dates above 20190101.
+ a_ml = visc_ml / (0.25 * (hvel(k) + hvel(k-1) + h_neglect))
+
+ ! As a floor on the viscous coupling, assume that the length scale in the denominator can
+ ! not be larger than the distance from the surface, consistent with a logarithmic velocity
+ ! profile. This is consistent with visc_ml, but cancels out common factors of z_t.
+ a_floor = (h_ml - z_t) * ustar2_denom
+
+ ! Choose the largest estimate of a_cpl.
+ a_cpl(K) = max(a_cpl(K), a_ml, a_floor)
+ ! An option could be added to change this to: a_cpl(i,K) = max(a_cpl(i,K) + a_ml, a_floor)
endif
- 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
+ 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
+ if (k <= nk_in_ml) then
+ z_t = z_t + hvel(k-1)
+
+ temp1 = (z_t * h_ml - z_t * z_t)
+ if (GV%Boussinesq) then
+ ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star**2) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ else
+ ustar2_denom = (CS%vonKar * tau_mag) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ endif
- 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))
+ ! As a floor on the viscous coupling, assume that the length scale in the denominator can not
+ ! be larger than the distance from the surface, consistent with a logarithmic velocity profile.
+ a_cpl(K) = max(a_cpl(K), (h_ml - z_t) * ustar2_denom)
endif
-
- ! 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
+ 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
+ if (k <= nk_in_ml) then
+ z_t = z_t + hvel(k-1)
+
+ temp1 = (z_t * h_ml - z_t * z_t)
+ ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer)
+ ! and be further limited by rotation to give the natural Ekman length.
+ ! The following expressions are mathematically equivalent.
+ if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then
+ visc_ml = u_star * CS%vonKar * (GV%Z_to_H * temp1 * u_star) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ else
+ visc_ml = CS%vonKar * (temp1 * tau_mag) &
+ / (absf * temp1 + (h_ml + h_neglect) * u_star)
+ endif
+ a_ml = visc_ml / (0.25 * (hvel(k) + hvel(k-1) + h_neglect) + 0.5 * I_amax * visc_ml)
- ! 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(K) = max(a_cpl(K), a_ml)
+ ! An option could be added to change this to: a_cpl(i,K) = a_cpl(i,K) + a_ml
+ endif
+ enddo
endif
endif
-
end subroutine find_coupling_coef
-!> Velocity components which exceed a threshold for physically reasonable values
-!! are truncated. Optionally, any column with excessive velocities may be sent
+
+!> Velocity components which exceed a threshold for physically reasonable values are truncated,
+!! and the running sum of the number of trunctionas within the non-symmetric memory computational
+!! domain is incremented. Optionally, any column with excessive velocities may be sent
!! to a diagnostic reporting subroutine.
subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS)
type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
@@ -2277,196 +3135,171 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS
type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces
type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag
real, intent(in) :: dt !< Time increment [T ~> s]
- type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure
+ type(vertvisc_CS) :: CS !< Vertical viscosity control structure
! Local variables
-
- real :: maxvel ! Velocities components greater than maxvel are truncated [L T-1 ~> m s-1]
- real :: truncvel ! The speed to which velocity components greater than maxvel are set [L T-1 ~> m s-1]
real :: CFL ! The local CFL number [nondim]
real :: H_report ! A thickness below which not to report truncations [H ~> m or kg m-2]
real :: vel_report(SZIB_(G),SZJB_(G)) ! The velocity to report [L T-1 ~> m s-1]
real :: u_old(SZIB_(G),SZJ_(G),SZK_(GV)) ! The previous u-velocity [L T-1 ~> m s-1]
real :: v_old(SZI_(G),SZJB_(G),SZK_(GV)) ! The previous v-velocity [L T-1 ~> m s-1]
+ logical :: trunc_any_array(SZI_(G),SZJB_(G),SZK_(GV))
logical :: trunc_any, dowrite(SZIB_(G),SZJB_(G))
+ logical :: do_any_write
+ integer :: ntrunc ! Thread-safe truncation counter
integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
- maxvel = CS%maxvel
- truncvel = 0.9*maxvel
- H_report = 6.0 * GV%Angstrom_H
+ H_report = 3.0 * GV%Angstrom_H
+
+ !$omp target enter data map(alloc: dowrite, vel_report)
+ !$omp target enter data map(alloc: u_old, v_old)
if (len_trim(CS%u_trunc_file) > 0) then
- !$OMP parallel do default(shared) private(trunc_any,CFL)
- do j=js,je
- trunc_any = .false.
- do I=Isq,Ieq ; dowrite(I,j) = .false. ; enddo
- if (CS%CFL_based_trunc) then
- do I=Isq,Ieq ; vel_report(i,j) = 3.0e8*US%m_s_to_L_T ; enddo ! Speed of light default.
- do k=1,nz ; do I=Isq,Ieq
- if (abs(u(I,j,k)) < CS%vel_underflow) u(I,j,k) = 0.0
- if (u(I,j,k) < 0.0) then
- CFL = (-u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j))
- else
- CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j))
- endif
- if (CFL > CS%CFL_trunc) trunc_any = .true.
- if (CFL > CS%CFL_report) then
- dowrite(I,j) = .true.
- vel_report(I,j) = MIN(vel_report(I,j), abs(u(I,j,k)))
- endif
- enddo ; enddo
+ do_any_write = .false.
+ trunc_any = .false.
+
+ do concurrent (j=js:je, I=Isq:Ieq)
+ dowrite(I,j) = .false.
+ vel_report(I,j) = 3.0e8 * US%m_s_to_L_T
+ enddo
+
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq) &
+ DO_LOCALITY(reduce(.or.: trunc_any, do_any_write))
+ if (abs(u(I,j,k)) < CS%vel_underflow) u(I,j,k) = 0.0
+ if (u(I,j,k) < 0.0) then
+ CFL = (-u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j))
else
- do I=Isq,Ieq; vel_report(I,j) = maxvel; enddo
- do k=1,nz ; do I=Isq,Ieq
- if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0
- elseif (abs(u(I,j,k)) > maxvel) then
- dowrite(I,j) = .true. ; trunc_any = .true.
- endif
- enddo ; enddo
+ CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j))
endif
+ if (CFL > CS%CFL_trunc) trunc_any = .true.
+ if (CFL > CS%CFL_report) then
+ dowrite(I,j) = .true.
+ do_any_write = .true.
+ vel_report(I,j) = min(vel_report(I,j), abs(u(I,j,k)))
+ endif
+ enddo
- do I=Isq,Ieq ; if (dowrite(I,j)) then
- u_old(I,j,:) = u(I,j,:)
- endif ; enddo
-
- if (trunc_any) then ; if (CS%CFL_based_trunc) then
- do k=1,nz ; do I=Isq,Ieq
- if ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then
- u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j)))
- if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1
- elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then
- u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j)))
- if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1
- endif
- enddo ; enddo
- else
- do k=1,nz ; do I=Isq,Ieq ; if (abs(u(I,j,k)) > maxvel) then
- u(I,j,k) = SIGN(truncvel,u(I,j,k))
- if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1
- endif ; enddo ; enddo
- endif ; endif
- enddo ! j-loop
- else ! Do not report accelerations leading to large velocities.
- if (CS%CFL_based_trunc) then
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=js,je ; do I=Isq,Ieq
- if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0
- elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then
+ do concurrent (j=js:je, I=Isq:Ieq, dowrite(I,j))
+ u_old(I,j,:) = u(I,j,:)
+ enddo
+
+ if (trunc_any) then
+ ntrunc = 0
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq) DO_LOCALITY(reduce(+: ntrunc))
+ if ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then
u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j)))
- if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1
+ if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. &
+ (CS%h_u(I,j,k) > H_report)) ntrunc = ntrunc + 1
elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then
u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j)))
- if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1
+ if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. &
+ (CS%h_u(I,j,k) > H_report)) ntrunc = ntrunc + 1
endif
- enddo ; enddo ; enddo
- else
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=js,je ; do I=Isq,Ieq
- if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0
- elseif (abs(u(I,j,k)) > maxvel) then
- u(I,j,k) = SIGN(truncvel, u(I,j,k))
- if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1
- endif
- enddo ; enddo ; enddo
+ enddo
+ CS%ntrunc = CS%ntrunc + ntrunc
endif
- endif
- if (len_trim(CS%u_trunc_file) > 0) then
- do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then
- ! Call a diagnostic reporting subroutines are called if unphysically large values are found.
- call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, &
- vel_report(I,j), forces%taux(I,j), a=CS%a_u, hv=CS%h_u)
- endif ; enddo ; enddo
+ if (do_any_write) then
+ !$omp target update from (u_old, vel_report)
+ do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then
+ ! Call a diagnostic reporting subroutines are called if unphysically large values are found.
+ call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, &
+ vel_report(I,j), forces%taux(I,j), a=CS%a_u, hv=CS%h_u)
+ endif ; enddo ; enddo
+ endif
+ else ! Do not report accelerations leading to large velocities.
+ ntrunc = 0
+ do concurrent (k=1:nz, j=js:je, I=Isq:Ieq) DO_LOCALITY(reduce(+: ntrunc))
+ if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0
+ elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then
+ u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j)))
+ if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. &
+ (CS%h_u(I,j,k) > H_report)) ntrunc = ntrunc + 1
+ elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then
+ u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j)))
+ if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. &
+ (CS%h_u(I,j,k) > H_report)) ntrunc = ntrunc + 1
+ endif
+ enddo
+ CS%ntrunc = CS%ntrunc + ntrunc
endif
if (len_trim(CS%v_trunc_file) > 0) then
- !$OMP parallel do default(shared) private(trunc_any,CFL)
- do J=Jsq,Jeq
- trunc_any = .false.
- do i=is,ie ; dowrite(i,J) = .false. ; enddo
- if (CS%CFL_based_trunc) then
- do i=is,ie ; vel_report(i,J) = 3.0e8*US%m_s_to_L_T ; enddo ! Speed of light default.
- do k=1,nz ; do i=is,ie
- if (abs(v(i,J,k)) < CS%vel_underflow) v(i,J,k) = 0.0
- if (v(i,J,k) < 0.0) then
- CFL = (-v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1))
- else
- CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j))
- endif
- if (CFL > CS%CFL_trunc) trunc_any = .true.
- if (CFL > CS%CFL_report) then
- dowrite(i,J) = .true.
- vel_report(i,J) = MIN(vel_report(i,J), abs(v(i,J,k)))
- endif
- enddo ; enddo
+ do_any_write =.false.
+ trunc_any = .false.
+
+ do concurrent (J=Jsq:Jeq, i=is:ie)
+ dowrite(i,J) = .false.
+ vel_report(i,J) = 3.0e8 * US%m_s_to_L_T
+ enddo
+
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie) &
+ DO_LOCALITY(reduce(.or.: trunc_any, do_any_write))
+ if (abs(v(i,J,k)) < CS%vel_underflow) v(i,J,k) = 0.0
+ if (v(i,J,k) < 0.0) then
+ CFL = (-v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1))
else
- do i=is,ie ; vel_report(i,J) = maxvel ; enddo
- do k=1,nz ; do i=is,ie
- if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0
- elseif (abs(v(i,J,k)) > maxvel) then
- dowrite(i,J) = .true. ; trunc_any = .true.
- endif
- enddo ; enddo
+ CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j))
+ endif
+ if (CFL > CS%CFL_trunc) trunc_any = .true.
+ if (CFL > CS%CFL_report) then
+ dowrite(i,J) = .true.
+ do_any_write = .true.
+ vel_report(i,J) = min(vel_report(i,J), abs(v(i,J,k)))
endif
+ enddo
- do i=is,ie ; if (dowrite(i,J)) then
- v_old(i,J,:) = v(i,J,:)
- endif ; enddo
-
- if (trunc_any) then ; if (CS%CFL_based_trunc) then
- do k=1,nz ; do i=is,ie
- if ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then
- v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J)))
- if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1
- elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then
- v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J)))
- if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1
- endif
- enddo ; enddo
- else
- do k=1,nz ; do i=is,ie ; if (abs(v(i,J,k)) > maxvel) then
- v(i,J,k) = SIGN(truncvel,v(i,J,k))
- if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1
- endif ; enddo ; enddo
- endif ; endif
- enddo ! J-loop
- else ! Do not report accelerations leading to large velocities.
- if (CS%CFL_based_trunc) then
- !$OMP parallel do default(shared)
- do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie
- if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0
- elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then
+ do concurrent (J=Jsq:Jeq, i=is:ie, dowrite(i,J))
+ v_old(i,J,:) = v(i,J,:)
+ enddo
+
+ if (trunc_any) then
+ ntrunc = 0
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie) DO_LOCALITY(reduce(+: ntrunc))
+ if ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then
v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J)))
- if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1
+ if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. &
+ (CS%h_v(i,J,k) > H_report)) ntrunc = ntrunc + 1
elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then
v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J)))
- if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1
- endif
- enddo ; enddo ; enddo
- else
- !$OMP parallel do default(shared)
- do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie
- if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0
- elseif (abs(v(i,J,k)) > maxvel) then
- v(i,J,k) = SIGN(truncvel, v(i,J,k))
- if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1
+ if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. &
+ (CS%h_v(i,J,k) > H_report)) ntrunc = ntrunc + 1
endif
- enddo ; enddo ; enddo
+ enddo
+ CS%ntrunc = CS%ntrunc + ntrunc
endif
- endif
- if (len_trim(CS%v_trunc_file) > 0) then
- do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then
- ! Call a diagnostic reporting subroutines are called if unphysically large values are found.
- call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, &
- vel_report(i,J), forces%tauy(i,J), a=CS%a_v, hv=CS%h_v)
- endif ; enddo ; enddo
+ if (do_any_write) then
+ !$omp target update from(v_old, vel_report)
+ do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then
+ ! Call a diagnostic reporting subroutines are called if unphysically large values are found.
+ call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, &
+ vel_report(i,J), forces%tauy(i,J), a=CS%a_v, hv=CS%h_v)
+ endif ; enddo ; enddo
+ endif
+ else ! Do not report accelerations leading to large velocities.
+ ntrunc = 0
+ do concurrent (k=1:nz, J=Jsq:Jeq, i=is:ie) DO_LOCALITY(reduce(+: ntrunc))
+ if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0
+ elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then
+ v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J)))
+ if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. &
+ (CS%h_v(i,J,k) > H_report)) ntrunc = ntrunc + 1
+ elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then
+ v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J)))
+ if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. &
+ (CS%h_v(i,J,k) > H_report)) ntrunc = ntrunc + 1
+ endif
+ enddo
+ CS%ntrunc = CS%ntrunc + ntrunc
endif
+ !$omp target exit data map(release: u_old, v_old, dowrite, vel_report)
end subroutine vertvisc_limit_vel
+
!> Initialize the vertical friction module
subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, &
ntrunc, CS, fpmix)
@@ -2500,17 +3333,10 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, &
character(len=40) :: thickness_units
real :: Kv_mks ! KVML in MKS [m2 s-1]
- if (associated(CS)) then
- call MOM_error(WARNING, "vertvisc_init called with an associated "// &
- "control structure.")
- return
- endif
- allocate(CS)
-
CS%initialized = .true.
- if (GV%Boussinesq) then; thickness_units = "m"
- else; thickness_units = "kg m-2"; endif
+ if (GV%Boussinesq) then ; thickness_units = "m"
+ else ; thickness_units = "kg m-2" ; endif
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
@@ -2722,12 +3548,6 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, &
"near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//&
"defined but LINEAR_DRAG is not.", &
units="m", fail_if_missing=.true., scale=US%m_to_Z)
- call get_param(param_file, mdl, "MAXVEL", CS%maxvel, &
- "The maximum velocity allowed before the velocity components are truncated.", &
- units="m s-1", default=3.0e8, scale=US%m_s_to_L_T)
- call get_param(param_file, mdl, "CFL_BASED_TRUNCATIONS", CS%CFL_based_trunc, &
- "If true, base truncations on the CFL number, and not an absolute speed.", &
- default=.true.)
call get_param(param_file, mdl, "CFL_TRUNCATE", CS%CFL_trunc, &
"The value of the CFL number that will cause velocity "//&
"components to be truncated; instability can occur past 0.5.", &
@@ -2770,6 +3590,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, &
"1e-30 m/s, which is less than an Angstrom divided by "//&
"the age of the universe.", units="m s-1", default=0.0, scale=US%m_s_to_L_T)
+ !$omp target update to(CS)
+
ALLOC_(CS%a_u(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u(:,:,:) = 0.0
ALLOC_(CS%a_u_gl90(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u_gl90(:,:,:) = 0.0
ALLOC_(CS%h_u(IsdB:IedB,jsd:jed,nz)) ; CS%h_u(:,:,:) = 0.0
@@ -2777,6 +3599,11 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, &
ALLOC_(CS%a_v_gl90(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v_gl90(:,:,:) = 0.0
ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0
+ !$omp target enter data map(to: CS%a_u, CS%a_v)
+ !$omp target enter data map(to: CS%h_u, CS%h_v)
+ ! TODO: Conditional?
+ !$omp target enter data map(to: CS%a_u_gl90, CS%a_v_gl90)
+
CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, &
'Slow varying vertical viscosity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s)
@@ -2992,7 +3819,7 @@ subroutine updateCFLtruncationValue(Time, CS, US, activate)
endif
endif
if (.not.CS%CFLrampingIsActivated) return
- deltaTime = max( 0., US%s_to_T*time_type_to_real( Time - CS%rampStartTime ) )
+ deltaTime = max(0., time_minus_signed(Time, CS%rampStartTime, scale=US%s_to_T))
if (deltaTime >= CS%truncRampTime) then
CS%CFL_trunc = CS%CFL_truncE
CS%truncRampTime = 0. ! This turns off ramping after this call
@@ -3004,8 +3831,7 @@ subroutine updateCFLtruncationValue(Time, CS, US, activate)
CS%CFL_trunc = CS%CFL_truncS + wghtA * ( CS%CFL_truncE - CS%CFL_truncS )
endif
write(msg(1:12),'(es12.3)') CS%CFL_trunc
- call MOM_error(NOTE, "MOM_vert_friction: updateCFLtruncationValue set CFL"// &
- " limit to "//trim(msg))
+ call MOM_error(NOTE, "MOM_vert_friction: updateCFLtruncationValue set CFL limit to "//trim(msg))
end subroutine updateCFLtruncationValue
!> Clean up and deallocate the vertical friction module
@@ -3046,9 +3872,9 @@ end subroutine vertvisc_end
!! side. Both of these thickness estimates are second order
!! accurate. Above this the arithmetic mean thickness is used.
!!
-!! In addition, vertvisc truncates any velocity component that
-!! exceeds maxvel to truncvel. This basically keeps instabilities
-!! spatially localized. The number of times the velocity is
+!! In addition, vertvisc truncates any velocity component that exceeds a
+!! maximum CFL number to a fraction of this value. This basically keeps
+!! instabilities spatially localized. The number of times the velocity is
!! truncated is reported each time the energies are saved, and if
!! exceeds CS%Maxtrunc the model will stop itself and change the time
!! to a large value. This has proven very useful in (1) diagnosing
diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90
index 1b1fd85316..7ef2dee58c 100644
--- a/src/tracer/DOME_tracer.F90
+++ b/src/tracer/DOME_tracer.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A tracer package that is used as a diagnostic in the DOME experiments
module DOME_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux
use MOM_diag_mediator, only : diag_ctrl
use MOM_error_handler, only : MOM_error, FATAL, WARNING
@@ -127,8 +129,7 @@ function register_DOME_tracer(G, GV, US, param_file, CS, tr_Reg, restart_CS)
allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0)
do m=1,NTR
- if (m < 10) then ; write(name,'("tr_D",I1.1)') m
- else ; write(name,'("tr_D",I2.2)') m ; endif
+ write(name,'("tr_D",I0)') m
write(longname,'("Concentration of DOME Tracer ",I2.2)') m
CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl)
if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1"
diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90
index cc4dca16bc..f1a158fb90 100644
--- a/src/tracer/ISOMIP_tracer.F90
+++ b/src/tracer/ISOMIP_tracer.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Routines used to set up and use a set of (one for now)
!! dynamically passive tracers in the ISOMIP configuration.
!!
@@ -5,8 +9,6 @@
!! the sponge layer.
module ISOMIP_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
! Original sample tracer package by Robert Hallberg, 2002
! Adapted to the ISOMIP test case by Gustavo Marques, May 2016
@@ -112,8 +114,7 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS)
allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0)
do m=1,NTR
- if (m < 10) then ; write(name,'("tr_D",I1.1)') m
- else ; write(name,'("tr_D",I2.2)') m ; endif
+ write(name,'("tr_D",I0)') m
write(longname,'("Concentration of ISOMIP Tracer ",I2.2)') m
CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl)
if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1"
diff --git a/src/tracer/MARBL_forcing_mod.F90 b/src/tracer/MARBL_forcing_mod.F90
index 2705bc1d66..e8c64e53ab 100644
--- a/src/tracer/MARBL_forcing_mod.F90
+++ b/src/tracer/MARBL_forcing_mod.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module provides a common datatype to provide forcing for MARBL tracers
!! regardless of driver
module MARBL_forcing_mod
@@ -374,7 +378,7 @@ subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust
endwhere
fluxes%fracr_cat(i,j,:) = G%mask2dT(i,j) * fluxes%fracr_cat(i,j,:)
fluxes%qsw_cat(i,j,:) = (US%W_m2_to_QRZ_T * G%mask2dT(i,j)) * fluxes%qsw_cat(i,j,:)
- enddo; enddo
+ enddo ; enddo
endif
end subroutine convert_driver_fields_to_forcings
diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90
index 34899ab890..2b8a9d4849 100644
--- a/src/tracer/MARBL_tracers.F90
+++ b/src/tracer/MARBL_tracers.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A tracer package for tracers computed in the MARBL library
!!
!! Currently configured for use with marbl0.36.0
@@ -5,8 +9,6 @@
!! (clone entire repo into pkg/MARBL)
module MARBL_tracers
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type, root_PE, broadcast
use MOM_debugging, only : hchksum
use MOM_diag_mediator, only : diag_ctrl
@@ -431,7 +433,7 @@ subroutine configure_MARBL_tracers(GV, US, param_file, CS)
CS%sfo_cnt = CS%sfo_cnt + 1
else if (trim(field_source) == "interior_tendency") then
CS%ito_cnt = CS%ito_cnt + 1
- end if
+ endif
! Total 3D Chlorophyll
call MARBL_instances%add_output_for_GCM(num_elements=1, num_levels=nz, field_name="total_Chl", &
@@ -440,8 +442,8 @@ subroutine configure_MARBL_tracers(GV, US, param_file, CS)
CS%sfo_cnt = CS%sfo_cnt + 1
else if (trim(field_source) == "interior_tendency") then
CS%ito_cnt = CS%ito_cnt + 1
- end if
- end if
+ endif
+ endif
! (5) Initialize forcing fields
! i. store all surface forcing indices
@@ -1308,7 +1310,7 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV,
real, dimension(SZI_(G),SZJ_(G)) :: flux_from_salt_flux ! Surface tracer flux from salt flux
! [conc Z T-1 ~> conc m s-1].
real, dimension(SZI_(G),SZJ_(G)) :: ref_mask ! Mask for 2D MARBL diags using ref_depth [1]
- real, dimension(SZI_(G),SZJ_(G)) :: riv_flux_loc ! Local copy of CS%RIV_FLUXES*dt [mmol m-2 ~> conc H]
+ real, dimension(SZI_(G),SZJ_(G)) :: riv_flux_loc ! Local copy of CS%RIV_FLUXES*dt [conc H ~> mmol m-2]
real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2]
real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: bot_flux_to_tend ! Conversion factor for bottom tlux -> tend
! [Z-1 ~> m-1]
@@ -1502,7 +1504,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 +1547,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_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90
index f9aa421f86..2ce801c63a 100644
--- a/src/tracer/MOM_CFC_cap.F90
+++ b/src/tracer/MOM_CFC_cap.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Simulates CFCs using atmospheric pressure, wind speed and sea ice cover
!! provided via cap (only NUOPC cap is implemented so far).
module MOM_CFC_cap
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_debugging, only : hchksum
use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data
@@ -516,7 +518,7 @@ subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US
! Gas exchange/piston velocity parameter
!---------------------------------------------------------------------
! From a = 0.251 cm/hr s^2/m^2 in Wannikhof 2014
- ! = 6.97e-7 [m/s s^2/m^2] [Z T-1 T2 L-2] = [Z T L-2 ~> s / m]
+ ! = 6.97e-7 [m/s s^2/m^2] [Z T-1 T2 L-2] = [Z T L-2 ~> s m-1]
kw_coeff = (US%m_to_Z*US%s_to_T*US%L_to_m**2) * 6.97e-7
! set unit conversion factors
@@ -690,7 +692,7 @@ logical function CFC_cap_unit_tests(verbose)
if (.not. CFC_cap_unit_tests) write(stdout,'(2x,a)') "Passed "//test_name
test_name = 'Solubility function, SST = 1.0 C, and SSS = 10 psu'
- ta = max(0.01, (1.0 + 273.15) * 0.01); sal = 10.
+ ta = max(0.01, (1.0 + 273.15) * 0.01) ; sal = 10.
! cfc1 = 3.238 10-2 mol kg-1 atm-1
! cfc2 = 7.943 10-3 mol kg-1 atm-1
call get_solubility(dummy1, dummy2, ta, sal , 1.0)
@@ -702,7 +704,7 @@ logical function CFC_cap_unit_tests(verbose)
if (.not. CFC_cap_unit_tests) write(stdout,'(2x,a)')"Passed "//test_name
test_name = 'Solubility function, SST = 20.0 C, and SSS = 35 psu'
- ta = max(0.01, (20.0 + 273.15) * 0.01); sal = 35.
+ ta = max(0.01, (20.0 + 273.15) * 0.01) ; sal = 35.
! cfc1 = 0.881 10-2 mol kg-1 atm-1
! cfc2 = 2.446 10-3 mol kg-1 atm-1
call get_solubility(dummy1, dummy2, ta, sal , 1.0)
@@ -719,7 +721,7 @@ end function CFC_cap_unit_tests
logical function compare_values(verbose, test_name, calc, ans, limit)
logical, intent(in) :: verbose !< If true, write results to stdout
character(len=80), intent(in) :: test_name !< Brief description of the unit test
- real, intent(in) :: calc !< computed value in abitrary units [A]
+ real, intent(in) :: calc !< computed value in arbitrary units [A]
real, intent(in) :: ans !< correct value [A]
real, intent(in) :: limit !< value above which test fails [A]
diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90
index 0a80cfaf2f..ee6609903f 100644
--- a/src/tracer/MOM_OCMIP2_CFC.F90
+++ b/src/tracer/MOM_OCMIP2_CFC.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Simulates CFCs using the OCMIP2 protocols
module MOM_OCMIP2_CFC
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_coupler_types, only : extract_coupler_type_data, set_coupler_type_data
use MOM_coupler_types, only : atmos_ocn_coupler_flux
diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90
index 4a822592fb..40a2db5899 100644
--- a/src/tracer/MOM_hor_bnd_diffusion.F90
+++ b/src/tracer/MOM_hor_bnd_diffusion.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Calculates and applies diffusive fluxes as a parameterization of horizontal mixing (non-neutral) by
!! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean.
module MOM_hor_bnd_diffusion
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE
use MOM_checksums, only : hchksum
@@ -104,7 +106,7 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba
"This module implements horizontal diffusion of tracers near boundaries", &
all_default=.not.hor_bnd_diffusion_init)
call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, &
- "If true, enables the horizonal boundary tracer's diffusion module.", &
+ "If true, enables the horizontal boundary tracer's diffusion module.", &
default=.false.)
if (.not. hor_bnd_diffusion_init) return
@@ -234,7 +236,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 +292,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)
@@ -550,7 +552,7 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h)
n = (2*nk)+3
allocate(eta_all(n))
! compute and merge interfaces
- eta_L(:) = 0.0; eta_R(:) = 0.0; eta_all(:) = 0.0
+ eta_L(:) = 0.0 ; eta_R(:) = 0.0 ; eta_all(:) = 0.0
kk = 0
do k=2,nk+1
eta_L(k) = eta_L(k-1) + h_L(k-1)
@@ -810,7 +812,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_
htot_max = MIN(hbl_L, hbl_R)
endif
- tmp1 = 0.0; tmp2 = 0.0
+ tmp1 = 0.0 ; tmp2 = 0.0
do k = 1,ke
! apply flux_limiter
if (CS%limiter .and. F_layer(k) /= 0.) then
@@ -1021,7 +1023,7 @@ logical function near_boundary_unit_tests( verbose )
! All cases in this section have hbl which are equal to the column thicknesses
test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)'
- hbl_L = 2.; hbl_R = 2.
+ hbl_L = 2. ; hbl_R = 2.
h_L = (/2.,2./) ; h_R = (/2.,2./)
phi_L = (/0.,0./) ; phi_R = (/1.,1./)
khtr_u = (/1.,1.,1./)
@@ -1032,7 +1034,7 @@ logical function near_boundary_unit_tests( verbose )
test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.0,0.0/) )
test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)'
- hbl_L = 2.; hbl_R = 2.
+ hbl_L = 2. ; hbl_R = 2.
h_L = (/2.,2./) ; h_R = (/2.,2./)
phi_L = (/2.,1./) ; phi_R = (/1.,1./)
khtr_u = (/0.5,0.5,0.5/)
@@ -1043,7 +1045,7 @@ logical function near_boundary_unit_tests( verbose )
test_layer_fluxes( verbose, nk, test_name, F_layer, (/1.0,0.0/) )
test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2'
- hbl_L = 2; hbl_R = 2
+ hbl_L = 2 ; hbl_R = 2
h_L = (/1.,2./) ; h_R = (/1.,2./)
phi_L = (/0.,0./) ; phi_R = (/0.5,2./)
khtr_u = (/2.,2.,2./)
@@ -1055,7 +1057,7 @@ logical function near_boundary_unit_tests( verbose )
test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) )
test_name = 'Different hbl and different column thicknesses (zero gradient)'
- hbl_L = 12; hbl_R = 20
+ hbl_L = 12 ; hbl_R = 20
h_L = (/6.,6./) ; h_R = (/10.,10./)
phi_L = (/1.,1./) ; phi_R = (/1.,1./)
khtr_u = (/1.,1.,1./)
@@ -1067,7 +1069,7 @@ logical function near_boundary_unit_tests( verbose )
test_name = 'Different hbl and different column thicknesses (gradient from left to right)'
- hbl_L = 15; hbl_R = 10.
+ hbl_L = 15 ; hbl_R = 10.
h_L = (/10.,5./) ; h_R = (/10.,0./)
phi_L = (/1.,1./) ; phi_R = (/0.,0./)
khtr_u = (/1.,1.,1./)
diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90
index 6e9f9c9f06..a94c1cbe02 100644
--- a/src/tracer/MOM_neutral_diffusion.F90
+++ b/src/tracer/MOM_neutral_diffusion.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A column-wise toolbox for implementing neutral diffusion
module MOM_neutral_diffusion
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE
use MOM_domains, only : pass_var
@@ -189,13 +191,13 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS,
"the equation of state. If negative (default), local pressure is used.", &
units="Pa", default=-1., scale=US%Pa_to_RL2_T2)
call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, &
- "If true, only applies neutral diffusion in the ocean interior."//&
- "That is, the algorithm will exclude the surface and bottom"//&
+ "If true, only applies neutral diffusion in the ocean interior. "//&
+ "That is, the algorithm will exclude the surface and bottom "//&
"boundary layers.", default=.false.)
if (CS%interior_only) then
call get_param(param_file, mdl, "NDIFF_TAPERING", CS%tapering, &
"If true, neutral diffusion linearly decays to zero within "//&
- "a transition zone defined using boundary layer depths. "//&
+ "a transition zone defined using boundary layer depths. "//&
"Only applicable when NDIFF_INTERIOR_ONLY=True", default=.false.)
endif
call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", KhTh_use_ebt_struct, &
@@ -219,7 +221,7 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS,
"Values of 20240330 or below recover the answers from the original form of the "//&
"neutral diffusion code, while higher values use mathematically equivalent "//&
"expressions that recover rotational symmetry.", &
- default=20240101) !### Change this default later to default_answer_date.
+ default=default_answer_date)
! Initialize and configure remapping
if ( .not.CS%continuous_reconstruction ) then
@@ -399,7 +401,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, visc, CS, p_surf)
call boundary_k_range(SURFACE, G%ke, h(i,j,:), CS%hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), &
zeta_bot(i,j))
endif
- enddo; enddo
+ enddo ; enddo
! TODO: add similar code for BOTTOM boundary layer
endif
@@ -693,7 +695,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS)
(Coef_y(i,J-1,k)+Coef_y(i,J,k)))
enddo
endif
- enddo; enddo
+ enddo ; enddo
call pass_var(CS%Coef_h,G%Domain)
endif
@@ -1409,8 +1411,8 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS
ns = 2*nk+2
! Initialize variables for the search
- kr = 1 ;
- kl = 1 ;
+ kr = 1
+ kl = 1
lastP_right = 0.
lastP_left = 0.
lastK_right = 1
@@ -1695,10 +1697,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, &
if (PRESENT(hard_fail_heff)) fail_heff = hard_fail_heff
if (PRESENT(k_bot_L) .and. PRESENT(k_bot_R) .and. PRESENT(zeta_bot_L) .and. PRESENT(zeta_bot_R)) then
- k_init_L = k_bot_L; k_init_R = k_bot_R
- p_init_L = zeta_bot_L; p_init_R = zeta_bot_R
- lastP_left = zeta_bot_L; lastP_right = zeta_bot_R
- kl_left = k_bot_L; kl_right = k_bot_R
+ k_init_L = k_bot_L ; k_init_R = k_bot_R
+ p_init_L = zeta_bot_L ; p_init_R = zeta_bot_R
+ lastP_left = zeta_bot_L ; lastP_right = zeta_bot_R
+ kl_left = k_bot_L ; kl_right = k_bot_R
else
k_init_L = 1 ; k_init_R = 1
p_init_L = 0. ; p_init_R = 0.
@@ -1750,7 +1752,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, &
Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), &
Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), &
dRho)
- if (CS%debug) write(stdout,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') &
+ if (CS%debug) write(stdout,'(A,I0,A,E12.4,A,I0,A,I0,A,I0,A,I0)') &
"k_surface=",k_surface, " dRho=",CS%R_to_kg_m3*dRho, &
"kl_left=",kl_left, " ki_left=",ki_left, " kl_right=",kl_right, " ki_right=",ki_right
! Which column has the lighter surface for the current indexes, kr and kl
@@ -1783,8 +1785,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, &
KoL(k_surface) = kl_left
if (CS%debug) then
- write(stdout,'(A,I2)') "Searching left layer ", kl_left
- write(stdout,'(A,I2,1X,I2)') "Searching from right: ", kl_right, ki_right
+ write(stdout,'(A,I0)') "Searching left layer ", kl_left
+ write(stdout,'(A,I0,1X,I0)') "Searching from right: ", kl_right, ki_right
write(stdout,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right)
write(stdout,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1)
write(stdout,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2)
@@ -1806,8 +1808,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, &
KoR(k_surface) = kl_right
if (CS%debug) then
- write(stdout,'(A,I2)') "Searching right layer ", kl_right
- write(stdout,'(A,I2,1X,I2)') "Searching from left: ", kl_left, ki_left
+ write(stdout,'(A,I0)') "Searching right layer ", kl_right
+ write(stdout,'(A,I0,1X,I0)') "Searching from left: ", kl_left, ki_left
write(stdout,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left)
write(stdout,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1)
write(stdout,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2)
@@ -1819,7 +1821,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, &
else
stop 'Else what?'
endif
- if (CS%debug) write(stdout,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), &
+ if (CS%debug) write(stdout,'(A,I3,A,ES16.6,A,I0,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), &
" KoR:", KoR(k_surface), " PoR:", PoR(k_surface)
endif
! Effective thickness
@@ -2173,7 +2175,7 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly
z = a
return
endif
- c = a ; drho_c = drho_a;
+ c = a ; drho_c = drho_a
if (side == -1) drho_b = 0.5*drho_b
side = -1
elseif ( drho_b*drho_a > 0 ) then
@@ -2887,8 +2889,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
allocate(CS%EOS)
call EOS_manual_init(CS%EOS, form_of_EOS=EOS_LINEAR, dRho_dT=-1., dRho_dS=0.)
Sl(:) = 0. ; Sr(:) = 0. ; ; SiL(:,:) = 0. ; SiR(:,:) = 0.
- ppoly_T_l(:,:) = 0.; ppoly_T_r(:,:) = 0.
- ppoly_S_l(:,:) = 0.; ppoly_S_r(:,:) = 0.
+ ppoly_T_l(:,:) = 0. ; ppoly_T_r(:,:) = 0.
+ ppoly_S_l(:,:) = 0. ; ppoly_S_r(:,:) = 0.
! Intialize any control structures needed for unit tests
CS%ref_pres = -1.
@@ -2903,8 +2905,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
CS%delta_rho_form = 'mid_pressure'
CS%neutral_pos_method = 1
- TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /);
- TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /);
+ TiL(1,:) = (/ 22.00, 18.00 /) ; TiL(2,:) = (/ 18.00, 14.00 /) ; TiL(3,:) = (/ 14.00, 10.00 /)
+ TiR(1,:) = (/ 22.00, 18.00 /) ; TiR(2,:) = (/ 18.00, 14.00 /) ; TiR(3,:) = (/ 14.00, 10.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -2917,8 +2919,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff
'Identical Columns')
- TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /);
- TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /);
+ TiL(1,:) = (/ 22.00, 18.00 /) ; TiL(2,:) = (/ 18.00, 14.00 /) ; TiL(3,:) = (/ 14.00, 10.00 /)
+ TiR(1,:) = (/ 20.00, 16.00 /) ; TiR(2,:) = (/ 16.00, 12.00 /) ; TiR(3,:) = (/ 12.00, 8.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -2931,8 +2933,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff
'Right slightly cooler')
- TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /);
- TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /);
+ TiL(1,:) = (/ 20.00, 16.00 /) ; TiL(2,:) = (/ 16.00, 12.00 /) ; TiL(3,:) = (/ 12.00, 8.00 /)
+ TiR(1,:) = (/ 22.00, 18.00 /) ; TiR(2,:) = (/ 18.00, 14.00 /) ; TiR(3,:) = (/ 14.00, 10.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -2945,8 +2947,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff
'Left slightly cooler')
- TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /);
- TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /);
+ TiL(1,:) = (/ 22.00, 20.00 /) ; TiL(2,:) = (/ 18.00, 16.00 /) ; TiL(3,:) = (/ 14.00, 12.00 /)
+ TiR(1,:) = (/ 32.00, 24.00 /) ; TiR(2,:) = (/ 22.00, 14.00 /) ; TiR(3,:) = (/ 12.00, 4.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -2959,8 +2961,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff
'Right more strongly stratified')
- TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /);
- TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /);
+ TiL(1,:) = (/ 22.00, 18.00 /) ; TiL(2,:) = (/ 18.00, 14.00 /) ; TiL(3,:) = (/ 14.00, 10.00 /)
+ TiR(1,:) = (/ 14.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 14.00 /) ; TiR(3,:) = (/ 12.00, 8.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -2973,8 +2975,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff
'Deep Mixed layer on the right')
- TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /);
- TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /);
+ TiL(1,:) = (/ 14.00, 14.00 /) ; TiL(2,:) = (/ 14.00, 12.00 /) ; TiL(3,:) = (/ 10.00, 8.00 /)
+ TiR(1,:) = (/ 14.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 14.00 /) ; TiR(3,:) = (/ 14.00, 14.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -2987,8 +2989,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff
'Right unstratified column')
- TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /);
- TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /);
+ TiL(1,:) = (/ 14.00, 14.00 /) ; TiL(2,:) = (/ 14.00, 12.00 /) ; TiL(3,:) = (/ 10.00, 8.00 /)
+ TiR(1,:) = (/ 14.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 14.00 /) ; TiR(3,:) = (/ 12.00, 4.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -3001,8 +3003,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff
'Right unstratified column')
- TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /);
- TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /);
+ TiL(1,:) = (/ 14.00, 14.00 /) ; TiL(2,:) = (/ 14.00, 10.00 /) ; TiL(3,:) = (/ 10.00, 2.00 /)
+ TiR(1,:) = (/ 14.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 10.00 /) ; TiR(3,:) = (/ 10.00, 2.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -3015,8 +3017,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff
'Identical columns with mixed layer')
- TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /);
- TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /);
+ TiL(1,:) = (/ 14.00, 12.00 /) ; TiL(2,:) = (/ 10.00, 10.00 /) ; TiL(3,:) = (/ 8.00, 2.00 /)
+ TiR(1,:) = (/ 14.00, 12.00 /) ; TiR(2,:) = (/ 12.00, 8.00 /) ; TiR(3,:) = (/ 8.00, 2.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -3029,8 +3031,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff
'Left interior unstratified')
- TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /);
- TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /);
+ TiL(1,:) = (/ 12.00, 12.00 /) ; TiL(2,:) = (/ 12.00, 10.00 /) ; TiL(3,:) = (/ 10.00, 6.00 /)
+ TiR(1,:) = (/ 12.00, 10.00 /) ; TiR(2,:) = (/ 10.00, 12.00 /) ; TiR(3,:) = (/ 8.00, 4.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -3043,8 +3045,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff
'Left mixed layer, Right unstable interior')
- TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /);
- TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /);
+ TiL(1,:) = (/ 14.00, 14.00 /) ; TiL(2,:) = (/ 10.00, 10.00 /) ; TiL(3,:) = (/ 8.00, 6.00 /)
+ TiR(1,:) = (/ 10.00, 14.00 /) ; TiR(2,:) = (/ 16.00, 16.00 /) ; TiR(3,:) = (/ 12.00, 4.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -3057,8 +3059,8 @@ logical function ndiff_unit_tests_discontinuous(verbose)
(/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff
'Left thick mixed layer, Right unstable mixed')
- TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /);
- TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /);
+ TiL(1,:) = (/ 8.00, 12.00 /) ; TiL(2,:) = (/ 12.00, 10.00 /) ; TiL(3,:) = (/ 8.00, 4.00 /)
+ TiR(1,:) = (/ 10.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 12.00 /) ; TiR(3,:) = (/ 10.00, 6.00 /)
call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l )
call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r )
call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, &
@@ -3225,11 +3227,11 @@ logical function test_data1d(verbose, nk, Po, Ptrue, title)
do k = 1,nk
if (Po(k) /= Ptrue(k)) then
test_data1d = .true.
- write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15,1x,a)') &
+ write(stdunit,'(a,I0,2(1x,a,f20.16),1x,a,1pe22.15,1x,a)') &
'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!'
else
if (verbose) &
- write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15)') &
+ write(stdunit,'(a,I0,2(1x,a,f20.16),1x,a,1pe22.15)') &
'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k)
endif
enddo
@@ -3260,10 +3262,10 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title)
do k = 1,nk
if (Po(k) /= Ptrue(k)) then
test_data1di = .true.
- write(stdunit,'(a,i2,2(1x,a,i5),1x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!'
+ write(stdunit,'(a,I0,2(1x,a,i5),1x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!'
else
if (verbose) &
- write(stdunit,'(a,i2,2(1x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k)
+ write(stdunit,'(a,I0,2(1x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k)
endif
enddo
endif
diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90
index 4adf8de293..4ea3ee70cc 100644
--- a/src/tracer/MOM_offline_aux.F90
+++ b/src/tracer/MOM_offline_aux.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Contains routines related to offline transport of tracers. These routines are likely to be called from
!> the MOM_offline_main module
module MOM_offline_aux
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_debugging, only : check_column_integrals
use MOM_domains, only : pass_var, pass_vector, To_All
use MOM_diag_mediator, only : post_data
diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90
index b0537955ef..e97eb61373 100644
--- a/src/tracer/MOM_offline_main.F90
+++ b/src/tracer/MOM_offline_main.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The routines here implement the offline tracer algorithm used in MOM6. These are called from step_offline
!! Some routines called here can be found in the MOM_offline_aux module.
module MOM_offline_main
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_ALE, only : ALE_CS, ALE_regrid, ALE_offline_inputs
use MOM_ALE, only : pre_ALE_adjustments, ALE_update_regrid_weights
use MOM_ALE, only : ALE_remap_tracers
diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90
index ce9b75efc5..63b5107d19 100644
--- a/src/tracer/MOM_tracer_Z_init.F90
+++ b/src/tracer/MOM_tracer_Z_init.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Used to initialize tracers from a depth- (or z*-) space file.
module MOM_tracer_Z_init
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_grid, only : ocean_grid_type
@@ -636,7 +638,7 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start,
"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=.false., do_not_log=just_read)
call get_param(PF, mdl, "DETERMINE_TEMP_T_MIN", T_min, &
"The minimum temperature that can be found by determine_temperature.", &
diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90
index 13fc5499c3..613c5cc1c5 100644
--- a/src/tracer/MOM_tracer_advect.F90
+++ b/src/tracer/MOM_tracer_advect.F90
@@ -1,8 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
+#include
+
!> This module contains the subroutines that advect tracers along coordinate surfaces.
module MOM_tracer_advect
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE
use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl
@@ -111,9 +115,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
integer :: IsdB, IedB, JsdB, JedB
integer :: stencil_local ! Stencil for the local adection scheme
integer :: local_advect_scheme(Reg%ntr) ! contains the list of the advection for each tracer
+ integer :: domore_k_tmp
- domore_u(:,:) = .false.
- domore_v(:,:) = .false.
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
@@ -128,14 +131,27 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
if (.not. associated(Reg)) call MOM_error(FATAL, "MOM_tracer_advect: "// &
"register_tracer must be called before advect_tracer.")
if (Reg%ntr==0) return
+
+ !$omp target update to(uhtr, vhtr, h_end)
+
+ !$omp target enter data map(to: OBC, Reg, Reg%Tr(:)) map(alloc: domore_u, domore_v, uhr, vhr, uh_neglect, &
+ !$omp vh_neglect, hprev, local_advect_scheme)
+
+ do concurrent (k=1:nz, j=jsd:jed)
+ domore_u(j,k) = .false.
+ enddo
+ do concurrent (k=1:nz, j=jsdB:jedB)
+ domore_v(j,k) = .false.
+ enddo
+
call cpu_clock_begin(id_clock_advect)
x_first = (MOD(G%first_direction,2) == 0)
! Choose the maximum stencil from all the local advection scheme
- do m = 1,ntr
+ do concurrent (m = 1:ntr)
local_advect_scheme(m) = Reg%Tr(m)%advect_scheme
- if(local_advect_scheme(m) < 0) local_advect_scheme(m) = CS%default_advect_scheme
+ if (local_advect_scheme(m) < 0) local_advect_scheme(m) = CS%default_advect_scheme
if (local_advect_scheme(m) == ADVECT_PLM) then
stencil_local = 2
@@ -151,6 +167,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
stencil = max(stencil, stencil_local)
enddo
+ !$omp target update from(local_advect_scheme)
+
if (min(is-isd,ied-ie,js-jsd,jed-je) < stencil) then
call MOM_error(FATAL, "MOM_tracer_advect: "//&
"stencil is wider than the halo.")
@@ -168,24 +186,33 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
enddo
call cpu_clock_end(id_clock_pass)
- !$OMP parallel default(shared)
+ !!$omp target enter data map(to: local_advect_scheme)
! This initializes the halos of uhr and vhr because pass_vector might do
! calculations on them, even though they are never used.
- !$OMP do
- do k=1,nz
- do j=jsd,jed ; do I=IsdB,IedB ; uhr(I,j,k) = 0.0 ; enddo ; enddo
- do J=jsdB,jedB ; do i=Isd,Ied ; vhr(i,J,k) = 0.0 ; enddo ; enddo
- do j=jsd,jed ; do i=Isd,Ied ; hprev(i,j,k) = 0.0 ; enddo ; enddo
+ do concurrent (k=1:nz)
+ do concurrent (j=jsd:jed, I=IsdB:IedB)
+ uhr(I,j,k) = 0.0
+ enddo
+ do concurrent (J=jsdB:jedB, i=Isd:Ied)
+ vhr(i,J,k) = 0.0
+ enddo
+ do concurrent (j=jsd:jed, i=Isd:Ied)
+ hprev(i,j,k) = 0.0
+ enddo
domore_k(k)=1
! Put the remaining (total) thickness fluxes into uhr and vhr.
- do j=js,je ; do I=is-1,ie ; uhr(I,j,k) = uhtr(I,j,k) ; enddo ; enddo
- do J=js-1,je ; do i=is,ie ; vhr(i,J,k) = vhtr(i,J,k) ; enddo ; enddo
+ do concurrent (j=js:je, I=is-1:ie)
+ uhr(I,j,k) = uhtr(I,j,k)
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
+ vhr(i,J,k) = vhtr(i,J,k)
+ enddo
if (.not. present(vol_prev)) then
! This loop reconstructs the thickness field the last time that the
! tracers were updated, probably just after the diabatic forcing. A useful
! diagnostic could be to compare this reconstruction with that older value.
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
hprev(i,j,k) = max(0.0, G%areaT(i,j)*h_end(i,j,k) + &
((uhr(I,j,k) - uhr(I-1,j,k)) + (vhr(i,J,k) - vhr(i,J-1,k))))
! In the case that the layer is now dramatically thinner than it was previously,
@@ -193,68 +220,94 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
! non-conservation of tracers
hprev(i,j,k) = hprev(i,j,k) + &
max(0.0, 1.0e-13*hprev(i,j,k) - G%areaT(i,j)*h_end(i,j,k))
- enddo ; enddo
+ enddo
else
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
hprev(i,j,k) = vol_prev(i,j,k)
- enddo ; enddo
+ enddo
endif
enddo
-
- !$OMP do
- do j=jsd,jed ; do I=isd,ied-1
+ do concurrent (j=jsd:jed, I=isd:ied-1)
uh_neglect(I,j) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i+1,j))
- enddo ; enddo
- !$OMP do
- do J=jsd,jed-1 ; do i=isd,ied
+ enddo
+ do concurrent (J=jsd:jed-1, i=isd:ied)
vh_neglect(i,J) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i,j+1))
- enddo ; enddo
+ enddo
+
+ ! update GPU copy of Tr(:)%t
+ ! only update t because other members are zeroed
+ !$ do m=1,ntr
+ !$omp target enter data map(to: Reg%Tr(m)%t) &
+ !$omp map(alloc: Reg%Tr(m)%ad_x, Reg%Tr(m)%ad_y, Reg%Tr(m)%ad2d_x, Reg%Tr(m)%ad2d_y, &
+ !$omp Reg%Tr(m)%advection_xy)
+ !$ enddo
! initialize diagnostic fluxes and tendencies
- !$OMP do
- do m=1,ntr
- if (associated(Reg%Tr(m)%ad_x)) Reg%Tr(m)%ad_x(:,:,:) = 0.0
- if (associated(Reg%Tr(m)%ad_y)) Reg%Tr(m)%ad_y(:,:,:) = 0.0
- if (associated(Reg%Tr(m)%advection_xy)) Reg%Tr(m)%advection_xy(:,:,:) = 0.0
- if (associated(Reg%Tr(m)%ad2d_x)) Reg%Tr(m)%ad2d_x(:,:) = 0.0
- if (associated(Reg%Tr(m)%ad2d_y)) Reg%Tr(m)%ad2d_y(:,:) = 0.0
+ do concurrent (m=1:ntr)
+ if (associated(Reg%Tr(m)%ad_x)) then
+ do concurrent (k=1:nz, j=jsd:jed, I=IsdB:IedB)
+ Reg%Tr(m)%ad_x(i,j,k) = 0.0
+ enddo
+ endif
+ if (associated(Reg%Tr(m)%ad_y)) then
+ do concurrent (k=1:nz, j=JsdB:jedB, i=isd:ied)
+ Reg%Tr(m)%ad_y(i,j,k) = 0.0
+ enddo
+ endif
+ if (associated(Reg%Tr(m)%advection_xy)) then
+ do concurrent (k=1:nz, j=jsd:jed, i=isd:ied)
+ Reg%Tr(m)%advection_xy(i,j,k) = 0.0
+ enddo
+ endif
+ if (associated(Reg%Tr(m)%ad2d_x)) then
+ do concurrent (j=jsd:jed, I=IsdB:IedB)
+ Reg%Tr(m)%ad2d_x(i,j) = 0.0
+ enddo
+ endif
+ if (associated(Reg%Tr(m)%ad2d_y)) then
+ do concurrent (J=JsdB:JedB, i=isd:ied)
+ Reg%Tr(m)%ad2d_y(i,j) = 0.0
+ enddo
+ endif
enddo
- !$OMP end parallel
isv = is ; iev = ie ; jsv = js ; jev = je
+ nsten_halo = min(is - isd, ied - ie, js - jsd, jed - je) / stencil
do itt=1,max_iter
if (isv > is-stencil) then
- call do_group_pass(CS%pass_uhr_vhr_t_hprev, G%Domain, clock=id_clock_pass)
+ call do_group_pass(CS%pass_uhr_vhr_t_hprev, G%Domain, clock=id_clock_pass, omp_offload=.true.)
- nsten_halo = min(is-isd,ied-ie,js-jsd,jed-je)/stencil
- isv = is-nsten_halo*stencil ; jsv = js-nsten_halo*stencil
- iev = ie+nsten_halo*stencil ; jev = je+nsten_halo*stencil
+ isv = is - nsten_halo * stencil ; jsv = js - nsten_halo * stencil
+ iev = ie + nsten_halo * stencil ; jev = je + nsten_halo * stencil
! Reevaluate domore_u & domore_v unless the valid range is the same size as
! before. Also, do this if there is Strang splitting.
if ((nsten_halo > 1) .or. (itt==1)) then
- !$OMP parallel do default(shared)
- do k=1,nz ; if (domore_k(k) > 0) then
- do j=jsv,jev ; if (.not.domore_u(j,k)) then
+ do concurrent (k=1:nz, domore_k(k) > 0)
+ do concurrent (j=jsv:jev, .not.domore_u(j,k))
do i=isv+stencil-1,iev-stencil ; if (uhr(I,j,k) /= 0.0) then
domore_u(j,k) = .true. ; exit
endif ; enddo ! i-loop
- endif ; enddo
- do J=jsv+stencil-1,jev-stencil ; if (.not.domore_v(J,k)) then
+ enddo
+ do concurrent (J=jsv+stencil-1:jev-stencil, .not.domore_v(J,k))
do i=isv+stencil,iev-stencil ; if (vhr(i,J,k) /= 0.0) then
domore_v(J,k) = .true. ; exit
endif ; enddo ! i-loop
- endif ; enddo
+ enddo
! At this point, domore_k is global. Change it so that it indicates
! whether any work is needed on a layer on this processor.
- domore_k(k) = 0
- do j=jsv,jev ; if (domore_u(j,k)) domore_k(k) = 1 ; enddo
- do J=jsv+stencil-1,jev-stencil ; if (domore_v(J,k)) domore_k(k) = 1 ; enddo
-
- endif ; enddo ! k-loop
+ domore_k_tmp = 0
+ do concurrent (j=jsv:jev, domore_u(j,k)) DO_LOCALITY(reduce(max:domore_k_tmp))
+ domore_k_tmp = 1
+ enddo
+ do concurrent (J=jsv+stencil-1:jev-stencil, domore_v(J,k)) DO_LOCALITY(reduce(max:domore_k_tmp))
+ domore_k_tmp = 1
+ enddo
+ domore_k(k) = domore_k_tmp
+ enddo ! k-loop
endif
endif
@@ -268,11 +321,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
! for all the transport to happen. The sum over domore_k keeps the processors
! synchronized. This may not be very efficient, but it should be reliable.
- !$OMP parallel default(shared)
-
if (x_first) then
- !$OMP do ordered
do k=1,nz ; if (domore_k(k) > 0) then
! First, advect zonally.
call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
@@ -280,22 +330,25 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
local_advect_scheme)
endif ; enddo
- !$OMP do ordered
do k=1,nz ; if (domore_k(k) > 0) then
! Next, advect meridionally.
call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
isv, iev, jsv, jev, k, G, GV, US, local_advect_scheme)
! Update domore_k(k) for the next iteration
- domore_k(k) = 0
- do j=jsv-stencil,jev+stencil ; if (domore_u(j,k)) domore_k(k) = 1 ; enddo
- do J=jsv-1,jev ; if (domore_v(J,k)) domore_k(k) = 1 ; enddo
+ domore_k_tmp = 0
+ do concurrent (j=jsv-stencil:jev+stencil, domore_u(j,k)) DO_LOCALITY(reduce(max:domore_k_tmp))
+ domore_k_tmp = 1
+ enddo
+ do concurrent (J=jsv-1:jev, domore_v(J,k)) DO_LOCALITY(reduce(max:domore_k_tmp))
+ domore_k_tmp = 1
+ enddo
+ domore_k(k) = domore_k_tmp
endif ; enddo
else
- !$OMP do ordered
do k=1,nz ; if (domore_k(k) > 0) then
! First, advect meridionally.
call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
@@ -303,22 +356,24 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
local_advect_scheme)
endif ; enddo
- !$OMP do ordered
do k=1,nz ; if (domore_k(k) > 0) then
! Next, advect zonally.
call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
isv, iev, jsv, jev, k, G, GV, US, local_advect_scheme)
! Update domore_k(k) for the next iteration
- domore_k(k) = 0
- do j=jsv,jev ; if (domore_u(j,k)) domore_k(k) = 1 ; enddo
- do J=jsv-1,jev ; if (domore_v(J,k)) domore_k(k) = 1 ; enddo
+ domore_k_tmp = 0
+ do concurrent (j=jsv:jev, domore_u(j,k)) DO_LOCALITY(reduce(max:domore_k_tmp))
+ domore_k_tmp = 1
+ enddo
+ do concurrent (J=jsv-1:jev, domore_v(J,k)) DO_LOCALITY(reduce(max:domore_k_tmp))
+ domore_k_tmp = 1
+ enddo
+ domore_k(k) = domore_k_tmp
endif ; enddo
endif ! x_first
- !$OMP end parallel
-
! If the advection just isn't finishing after max_iter, move on.
if (itt >= max_iter) then
exit
@@ -339,12 +394,32 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first
enddo ! Iterations loop
- if (present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:)
- if (present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:)
+ !$ do m = 1, ntr
+ !$omp target exit data map(from: Reg%Tr(m)%t, Reg%Tr(m)%ad_x, Reg%Tr(m)%ad_y, Reg%Tr(m)%ad2d_x, &
+ !$omp Reg%Tr(m)%ad2d_y, Reg%Tr(m)%advection_xy)
+ !$ enddo
+
+ if (present(uhr_out)) then
+ do concurrent (k=1:nz, j=jsd:jed, i=isdB:iedB)
+ uhr_out(i,j,k) = uhr(i,j,k)
+ enddo
+ endif
+ if (present(vhr_out)) then
+ do concurrent (k=1:nz, j=jsdB:jedB, i=isd:ied)
+ vhr_out(i,j,k) = vhr(i,j,k)
+ enddo
+ endif
if (present(vol_prev) .and. present(update_vol_prev)) then
- if (update_vol_prev) vol_prev(:,:,:) = hprev(:,:,:)
+ if (update_vol_prev) then
+ do concurrent (k=1:nz, j=jsd:jed, i=isd:ied)
+ vol_prev(i,j,k) = hprev(i,j,k)
+ enddo
+ endif
endif
+ !$omp target exit data map(release: hprev, uhr, vhr, uh_neglect, vh_neglect, domore_u, &
+ !$omp domore_v, local_advect_scheme, OBC, Reg, Reg%Tr(:))
+
call cpu_clock_end(id_clock_advect)
end subroutine advect_tracer
@@ -408,7 +483,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
real :: mA ! Average of the reconstruction tracer edge values [conc]
real :: a6 ! Curvature of the reconstruction tracer values [conc]
logical :: do_i(SZI_(G),SZJ_(G)) ! If true, work on given points.
- logical :: usePLMslope
+ logical :: usePLMslope, domore_u_jk
integer :: i, j, m, n, i_up, stencil, ntr_id
type(OBC_segment_type), pointer :: segment=>NULL()
logical, dimension(SZJ_(G),SZK_(GV)) :: domore_u_initial
@@ -430,14 +505,18 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
tiny_h = tiny(min_h)
h_neglect = GV%H_subroundoff
- do I=is-1,ie ; CFL(I) = 0.0 ; enddo
+ ! do I=is-1,ie ; CFL(I) = 0.0 ; enddo
+ !$omp target enter data &
+ !$omp map(alloc: slope_x, T_tmp, uhh, CFL, hlst, Ihnew, do_i, flux_x)
+ !$omp target teams loop private(slope_x, T_tmp, uhh, CFL, hlst, Ihnew, Tp, dMx, dMn, m, i, n, &
+ !$omp ntr_id, hup, hlos, i_up, Tc, Tm, aL, aR, dA, mA, a6, domore_u_jk)
do j=js,je ; if (domore_u(j,k)) then
- domore_u(j,k) = .false.
+ domore_u_jk = .false.
! Calculate the i-direction profiles (slopes) of each tracer that is being advected.
if (usePLMslope) then
- do m=1,ntr ; do i=is-stencil,ie+stencil
+ do concurrent (m=1:ntr, i=is-stencil:ie+stencil)
!if (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) < &
! ABS(Tr(m)%t(i,j,k)-Tr(m)%t(i-1,j,k))) then
! maxslope = 4.0*(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k))
@@ -457,47 +536,44 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
dMn= Tc - min( Tp, Tc, Tm )
slope_x(i,m) = G%mask2dCu(I,j)*G%mask2dCu(I-1,j) * &
sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm )
- enddo ; enddo
+ enddo
endif ! usePLMslope
! make a copy of the tracers in case values need to be overridden for OBCs
- do m = 1,ntr
- do i=G%isd,G%ied
- T_tmp(i,m) = Tr(m)%t(i,j,k)
- enddo
+ do concurrent (m = 1:ntr, i=G%isd:G%ied)
+ T_tmp(i,m) = Tr(m)%t(i,j,k)
enddo
! loop through open boundaries and recalculate flux terms
if (associated(OBC)) then ; if (OBC%OBC_pe) then
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
- if (.not. associated(segment%tr_Reg)) cycle
- if (segment%is_E_or_W) then
- if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then
- I = segment%HI%IsdB
- do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values
- ntr_id = segment%tr_reg%Tr(m)%ntr_index
- if (allocated(segment%tr_Reg%Tr(m)%tres)) then
- if (segment%direction == OBC_DIRECTION_W) then
- T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k)
+ ! segment=>OBC%segment(n)
+ if (.not. associated(OBC%segment(n)%tr_Reg)) cycle
+ if (OBC%segment(n)%is_E_or_W) then
+ if (j>=OBC%segment(n)%HI%jsd .and. j<=OBC%segment(n)%HI%jed) then
+ I = OBC%segment(n)%HI%IsdB
+ do concurrent (m = 1:OBC%segment(n)%tr_Reg%ntseg) ! replace tracers with OBC values
+ ntr_id = OBC%segment(n)%tr_reg%Tr(m)%ntr_index
+ if (allocated(OBC%segment(n)%tr_Reg%Tr(m)%tres)) then
+ if (OBC%segment(n)%direction == OBC_DIRECTION_W) then
+ T_tmp(i,ntr_id) = OBC%segment(n)%tr_Reg%Tr(m)%tres(i,j,k)
else
- T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k)
+ T_tmp(i+1,ntr_id) = OBC%segment(n)%tr_Reg%Tr(m)%tres(i,j,k)
endif
else
- if (segment%direction == OBC_DIRECTION_W) then
- T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc
+ if (OBC%segment(n)%direction == OBC_DIRECTION_W) then
+ T_tmp(i,ntr_id) = OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc
else
- T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc
+ T_tmp(i+1,ntr_id) = OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc
endif
endif
enddo
- do m = 1,ntr ! Apply update tracer values for slope calculation
- do i=segment%HI%IsdB-1,segment%HI%IsdB+1
- Tp = T_tmp(i+1,m) ; Tc = T_tmp(i,m) ; Tm = T_tmp(i-1,m)
- dMx = max( Tp, Tc, Tm ) - Tc
- dMn= Tc - min( Tp, Tc, Tm )
- slope_x(i,m) = G%mask2dCu(I,j)*G%mask2dCu(I-1,j) * &
- sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm )
- enddo
+ ! Apply update tracer values for slope calculation
+ do concurrent (m = 1:ntr, i=OBC%segment(n)%HI%IsdB-1:OBC%segment(n)%HI%IsdB+1)
+ Tp = T_tmp(i+1,m) ; Tc = T_tmp(i,m) ; Tm = T_tmp(i-1,m)
+ dMx = max( Tp, Tc, Tm ) - Tc
+ dMn= Tc - min( Tp, Tc, Tm )
+ slope_x(i,m) = G%mask2dCu(I,j)*G%mask2dCu(I-1,j) * &
+ sign( min(0.5*abs(Tp-Tm), 2.0*dMx, 2.0*dMn), Tp-Tm )
enddo
endif
@@ -510,7 +586,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
! the minimum of the remaining mass flux (uhr) and the half the mass
! in the cell plus whatever part of its half of the mass flux that
! the flux through the other side does not require.
- do I=is-1,ie
+ do concurrent (I=is-1:ie) DO_LOCALITY(reduce(.or.:domore_u_jk))
if ((uhr(I,j,k) == 0.0) .or. &
((uhr(I,j,k) < 0.0) .and. (hprev(i+1,j,k) <= tiny_h)) .or. &
((uhr(I,j,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then
@@ -522,7 +598,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
if ((((hup - hlos) + uhr(I,j,k)) < 0.0) .and. &
((0.5*hup + uhr(I,j,k)) < 0.0)) then
uhh(I) = MIN(-0.5*hup, -hup+hlos, 0.0)
- domore_u(j,k) = .true.
+ domore_u_jk = .true.
else
uhh(I) = uhr(I,j,k)
endif
@@ -533,7 +609,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
if ((((hup - hlos) - uhr(I,j,k)) < 0.0) .and. &
((0.5*hup - uhr(I,j,k)) < 0.0)) then
uhh(I) = MAX(0.5*hup, hup-hlos, 0.0)
- domore_u(j,k) = .true.
+ domore_u_jk = .true.
else
uhh(I) = uhr(I,j,k)
endif
@@ -541,10 +617,12 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
endif
enddo
- do m=1,ntr
+ domore_u(j,k) = domore_u_jk
+
+ do concurrent (m=1:ntr)
if ((advect_schemes(m) == ADVECT_PPM) .or. (advect_schemes(m) == ADVECT_PPMH3)) then
- do I=is-1,ie
+ do concurrent (I=is-1:ie)
! centre cell depending on upstream direction
if (uhh(I) >= 0.0) then
i_up = i
@@ -585,7 +663,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
endif
enddo
else ! PLM
- do I=is-1,ie
+ do concurrent (I=is-1:ie)
if (uhh(I) >= 0.0) then
! Indirect implementation of PLM
!aL = Tr(m)%t(i,j,k) - 0.5 * slope_x(i,m)
@@ -610,22 +688,22 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
if (associated(OBC)) then ; if (OBC%OBC_pe) then
if (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally) then
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
- if (.not. associated(segment%tr_Reg)) cycle
- if (segment%is_E_or_W) then
- if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then
- I = segment%HI%IsdB
+ ! segment=>OBC%segment(n)
+ if (.not. associated(OBC%segment(n)%tr_Reg)) cycle
+ if (OBC%segment(n)%is_E_or_W) then
+ if (j>=OBC%segment(n)%HI%jsd .and. j<=OBC%segment(n)%HI%jed) then
+ I = OBC%segment(n)%HI%IsdB
! Tracer fluxes are set to prescribed values only for inflows from masked areas.
! Now changing to simply fixed inflows.
- if ((uhr(I,j,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_W) .or. &
- (uhr(I,j,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_E)) then
+ if ((uhr(I,j,k) > 0.0) .and. (OBC%segment(n)%direction == OBC_DIRECTION_W) .or. &
+ (uhr(I,j,k) < 0.0) .and. (OBC%segment(n)%direction == OBC_DIRECTION_E)) then
uhh(I) = uhr(I,j,k)
! should the reservoir evolve for this case Kate ?? - Nope
- do m=1,segment%tr_Reg%ntseg
- ntr_id = segment%tr_reg%Tr(m)%ntr_index
- if (allocated(segment%tr_Reg%Tr(m)%tres)) then
- flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k)
- else ; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif
+ do concurrent (m=1:OBC%segment(n)%tr_Reg%ntseg)
+ ntr_id = OBC%segment(n)%tr_reg%Tr(m)%ntr_index
+ if (allocated(OBC%segment(n)%tr_Reg%Tr(m)%tres)) then
+ flux_x(I,j,ntr_id) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%tres(I,j,k)
+ else ; flux_x(I,j,ntr_id) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif
enddo
endif
endif
@@ -635,21 +713,21 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
if (OBC%open_u_BCs_exist_globally) then
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
- I = segment%HI%IsdB
- if (segment%is_E_or_W .and. (j >= segment%HI%jsd .and. j<= segment%HI%jed)) then
- if (segment%specified) cycle
- if (.not. associated(segment%tr_Reg)) cycle
+ ! segment=>OBC%segment(n)
+ I = OBC%segment(n)%HI%IsdB
+ if (OBC%segment(n)%is_E_or_W .and. (j >= OBC%segment(n)%HI%jsd .and. j<= OBC%segment(n)%HI%jed)) then
+ if (OBC%segment(n)%specified) cycle
+ if (.not. associated(OBC%segment(n)%tr_Reg)) cycle
! Tracer fluxes are set to prescribed values only for inflows from masked areas.
if ((uhr(I,j,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. &
(uhr(I,j,k) < 0.0) .and. (G%mask2dT(i+1,j) < 0.5)) then
uhh(I) = uhr(I,j,k)
- do m=1,segment%tr_Reg%ntseg
- ntr_id = segment%tr_reg%Tr(m)%ntr_index
- if (allocated(segment%tr_Reg%Tr(m)%tres)) then
- flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k)
- else; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif
+ do concurrent (m=1:OBC%segment(n)%tr_Reg%ntseg)
+ ntr_id = OBC%segment(n)%tr_reg%Tr(m)%ntr_index
+ if (allocated(OBC%segment(n)%tr_Reg%Tr(m)%tres)) then
+ flux_x(I,j,ntr_id) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%tres(I,j,k)
+ else; flux_x(I,j,ntr_id) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc; endif
enddo
endif
endif
@@ -659,11 +737,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
! Calculate new tracer concentration in each cell after accounting
! for the i-direction fluxes.
- do I=is-1,ie
+ do concurrent (I=is-1:ie)
uhr(I,j,k) = uhr(I,j,k) - uhh(I)
if (abs(uhr(I,j,k)) < uh_neglect(I,j)) uhr(I,j,k) = 0.0
enddo
- do i=is,ie
+ do concurrent (i=is:ie)
if ((uhh(I) /= 0.0) .or. (uhh(I-1) /= 0.0)) then
do_i(i,j) = .true.
hlst(i) = hprev(i,j,k)
@@ -680,24 +758,20 @@ 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 (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally) then
- do i=is,ie-1 ; if (OBC%segnum_u(I,j) /= OBC_NONE) then
- if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then
- do_i(i+1,j) = .false.
- elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then
- do_i(i,j) = .false.
- endif
- endif ; enddo
- endif
+ if (.not.OBC%exterior_OBC_bug .and. OBC%OBC_pe &
+ .and. (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally)) then
+ ! OBC_DIRECTION_E / OBC_DIRECTION_W on the west / east edge
+ do concurrent (i=is:ie, OBC%segnum_u(I-1,j) > 0 .or. OBC%segnum_u(I,j) < 0)
+ do_i(i,j) = .false.
+ enddo
endif
endif
! update tracer concentration from i-flux and save some diagnostics
- do m=1,ntr
+ do concurrent (m=1:ntr)
! update tracer
- do i=is,ie
+ do concurrent (i=is:ie)
if (do_i(i,j)) then
if (Ihnew(i) > 0.0) then
Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - &
@@ -707,18 +781,20 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
enddo
! diagnostics
- if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then
- Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt
- endif ; enddo ; endif
+ if (associated(Tr(m)%ad_x)) then
+ do concurrent (I=is-1:ie, do_i(i,j) .or. do_i(i+1,j))
+ Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt
+ enddo
+ endif
! diagnose convergence of flux_x (do not use the Ihnew(i) part of the logic).
! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt.
if (associated(Tr(m)%advection_xy)) then
- do i=is,ie ; if (do_i(i,j)) then
+ do concurrent (i=is:ie, do_i(i,j))
Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - &
(flux_x(I,j,m) - flux_x(I-1,j,m)) * &
Idt * G%IareaT(i,j)
- endif ; enddo
+ enddo
endif
enddo
@@ -726,24 +802,24 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, &
endif ; enddo ! End of j-loop.
! Do user controlled underflow of the tracer concentrations.
- do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then
- do j=js,je ; do i=is,ie
+ do concurrent (m=1:ntr, Tr(m)%conc_underflow > 0.0)
+ do concurrent (j=js:je, i=is:ie)
if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0
- enddo ; enddo
- endif ; enddo
+ enddo
+ enddo
! compute ad2d_x diagnostic outside above j-loop so as to make the summation ordered when OMP is active.
- !$OMP ordered
do m=1,ntr ; if (associated(Tr(m)%ad2d_x)) then
- do j=js,je ; if (domore_u_initial(j,k)) then
- do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then
+ do concurrent (j=js:je, domore_u_initial(j,k))
+ do concurrent (I=is-1:ie, do_i(i,j) .or. do_i(i+1,j))
Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt
- endif ; enddo
- endif ; enddo
+ enddo
+ enddo
endif ; enddo ! End of m-loop.
- !$OMP end ordered
+ !$omp target exit data &
+ !$omp map(release: slope_x, T_tmp, uhh, CFL, hlst, Ihnew, do_i, flux_x)
end subroutine advect_x
!> This subroutine does 1-d flux-form advection using a monotonic piecewise
@@ -807,7 +883,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
logical :: usePLMslope
integer :: i, j, j2, m, n, j_up, stencil, ntr_id
type(OBC_segment_type), pointer :: segment=>NULL()
- logical :: domore_v_initial(SZJB_(G)) ! Initial state of domore_v
+ logical :: domore_v_initial(SZJB_(G)), domore_v_jk ! Initial state of domore_v
usePLMslope = .false.
! stencil for calculating slope values
@@ -822,6 +898,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
tiny_h = tiny(min_h)
h_neglect = GV%H_subroundoff
+ !$omp target enter data map(alloc: vhh, T_tmp, slope_y, flux_y, domore_v_initial, do_j_tr, do_i)
+
! We conditionally perform work on tracer points: calculating the PLM slope,
! and updating tracer concentration within a cell
! this depends on whether there is a flux which would affect this tracer point,
@@ -832,44 +910,52 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
! Note: this does lead to unnecessary work in updating tracer concentrations,
! since that doesn't need a wider stencil with the PPM advection scheme, but
! this would require an additional loop, etc.
- do_j_tr(:) = .false.
- do J=js-1,je
- if (domore_v(J,k)) then ; do j2=1-stencil,stencil ; do_j_tr(j+j2) = .true. ; enddo ; endif
+ do concurrent (j=SZJ_(G))
+ do_j_tr(j) = .false.
+ enddo
+ do concurrent (J=js-1:je, domore_v(J,k))
+ do concurrent (j2=1-stencil:stencil)
+ do_j_tr(j+j2) = .true.
+ enddo
+ enddo
+ do concurrent (j=SZJB_(G))
+ domore_v_initial(j) = domore_v(j,k)
enddo
- domore_v_initial(:) = domore_v(:,k)
! Calculate the j-direction profiles (slopes) of each tracer that
! is being advected.
if (usePLMslope) then
- do j=js-stencil,je+stencil ; if (do_j_tr(j)) then ; do m=1,ntr ; do i=is,ie
- !if (ABS(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k)) < &
- ! ABS(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k))) then
- ! maxslope = 4.0*(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k))
- !else
- ! maxslope = 4.0*(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k))
- !endif
- !if ((Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k))*(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k)) < 0.0) then
- ! slope_y(i,m,j) = 0.0
- !elseif (ABS(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j-1,k)) 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then
@@ -930,7 +1019,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
if ((((hup - hlos) + vhr(i,J,k)) < 0.0) .and. &
((0.5*hup + vhr(i,J,k)) < 0.0)) then
vhh(i,J) = MIN(-0.5*hup, -hup+hlos, 0.0)
- domore_v(J,k) = .true.
+ domore_v_jk = .true.
else
vhh(i,J) = vhr(i,J,k)
endif
@@ -941,7 +1030,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
if ((((hup - hlos) - vhr(i,J,k)) < 0.0) .and. &
((0.5*hup - vhr(i,J,k)) < 0.0)) then
vhh(i,J) = MAX(0.5*hup, hup-hlos, 0.0)
- domore_v(J,k) = .true.
+ domore_v_jk = .true.
else
vhh(i,J) = vhr(i,J,k)
endif
@@ -949,10 +1038,12 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
endif
enddo
- do m=1,ntr
+ domore_v(j,k) = domore_v_jk
+
+ do concurrent (m=1:ntr)
if ((advect_schemes(m) == ADVECT_PPM) .or. (advect_schemes(m) == ADVECT_PPMH3)) then
- do i=is,ie
+ do concurrent (i=is:ie)
! centre cell depending on upstream direction
if (vhh(i,J) >= 0.0) then
j_up = j
@@ -993,7 +1084,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
endif
enddo
else ! PLM
- do i=is,ie
+ do concurrent (i=is:ie)
if (vhh(i,J) >= 0.0) then
! Indirect implementation of PLM
!aL = Tr(m)%t(i,j,k) - 0.5 * slope_y(i,m,j)
@@ -1018,20 +1109,19 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
if (associated(OBC)) then ; if (OBC%OBC_pe) then
if (OBC%specified_v_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
- if (.not. segment%specified) cycle
- if (.not. associated(segment%tr_Reg)) cycle
+ if (.not. OBC%segment(n)%specified) cycle
+ if (.not. associated(OBC%segment(n)%tr_Reg)) cycle
if (OBC%segment(n)%is_N_or_S) then
- if (J >= segment%HI%JsdB .and. J<= segment%HI%JedB) then
- do i=segment%HI%isd,segment%HI%ied
+ if (J >= OBC%segment(n)%HI%JsdB .and. J<= OBC%segment(n)%HI%JedB) then
+ do i=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied
! Tracer fluxes are set to prescribed values only for inflows from masked areas.
! Now changing to simply fixed inflows.
- if ((vhr(i,J,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_S) .or. &
- (vhr(i,J,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_N)) then
+ if ((vhr(i,J,k) > 0.0) .and. (OBC%segment(n)%direction == OBC_DIRECTION_S) .or. &
+ (vhr(i,J,k) < 0.0) .and. (OBC%segment(n)%direction == OBC_DIRECTION_N)) then
vhh(i,J) = vhr(i,J,k)
- do m=1,segment%tr_Reg%ntseg
- ntr_id = segment%tr_reg%Tr(m)%ntr_index
- if (allocated(segment%tr_Reg%Tr(m)%tres)) then
+ do m=1,OBC%segment(n)%tr_Reg%ntseg
+ ntr_id = OBC%segment(n)%tr_reg%Tr(m)%ntr_index
+ if (allocated(OBC%segment(n)%tr_Reg%Tr(m)%tres)) then
flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k)
else
flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc
@@ -1046,20 +1136,19 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
if (OBC%open_v_BCs_exist_globally) then
do n=1,OBC%number_of_segments
- segment=>OBC%segment(n)
- if (segment%specified) cycle
- if (.not. associated(segment%tr_Reg)) cycle
- if (segment%is_N_or_S .and. (J >= segment%HI%JsdB .and. J<= segment%HI%JedB)) then
- do i=segment%HI%isd,segment%HI%ied
+ if (OBC%segment(n)%specified) cycle
+ if (.not. associated(OBC%segment(n)%tr_Reg)) cycle
+ if (OBC%segment(n)%is_N_or_S .and. (J >= OBC%segment(n)%HI%JsdB .and. J<= OBC%segment(n)%HI%JedB)) then
+ do i=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied
! Tracer fluxes are set to prescribed values only for inflows from masked areas.
if ((vhr(i,J,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. &
(vhr(i,J,k) < 0.0) .and. (G%mask2dT(i,j+1) < 0.5)) then
vhh(i,J) = vhr(i,J,k)
- do m=1,segment%tr_Reg%ntseg
- ntr_id = segment%tr_reg%Tr(m)%ntr_index
- if (allocated(segment%tr_Reg%Tr(m)%tres)) then
- flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k)
- else ; flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif
+ do m=1,OBC%segment(n)%tr_Reg%ntseg
+ ntr_id = OBC%segment(n)%tr_reg%Tr(m)%ntr_index
+ if (allocated(OBC%segment(n)%tr_Reg%Tr(m)%tres)) then
+ flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k)
+ else ; flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif
enddo
endif
enddo
@@ -1069,19 +1158,24 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, &
endif ; endif
else ! not domore_v.
- do i=is,ie ; vhh(i,J) = 0.0 ; enddo
- do m=1,ntr ; do i=is,ie ; flux_y(i,m,J) = 0.0 ; enddo ; enddo
+ do concurrent (i=is:ie)
+ vhh(i,J) = 0.0
+ enddo
+ do concurrent (m=1:ntr, i=is:ie)
+ flux_y(i,m,J) = 0.0
+ enddo
endif ; enddo ! End of j-loop
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
vhr(i,J,k) = vhr(i,J,k) - vhh(i,J)
if (abs(vhr(i,J,k)) < vh_neglect(i,J)) vhr(i,J,k) = 0.0
- enddo ; enddo
+ enddo
! Calculate new tracer concentration in each cell after accounting
! for the j-direction fluxes.
+ !$omp target teams loop private(hlst, Ihnew, i, m)
do j=js,je ; if (do_j_tr(j)) then
- do i=is,ie
+ do concurrent (i=is:ie)
if ((vhh(i,J) /= 0.0) .or. (vhh(i,J-1) /= 0.0)) then
do_i(i,j) = .true.
hlst(i) = hprev(i,j,k)
@@ -1096,69 +1190,60 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, 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 (OBC%specified_v_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then
- do i=is,ie
- if (OBC%segnum_v(i,J-1) /= OBC_NONE) then
- if (OBC%segment(OBC%segnum_v(i,J-1))%direction == OBC_DIRECTION_N) then
- do_i(i,j) = .false.
- endif
- endif
- if (OBC%segnum_v(i,J) /= OBC_NONE) then
- if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then
- do_i(i,j) = .false.
- endif
- endif
- enddo
- endif
+ if (.not.OBC%exterior_OBC_bug .and. OBC%OBC_pe &
+ .and. (OBC%specified_v_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) then
+ ! OBC_DIRECTION_N / OBC_DIRECTION_S on the south / north edge
+ do concurrent (i=is:ie, OBC%segnum_v(i,J-1) > 0 .or. OBC%segnum_v(i,J) < 0)
+ do_i(i,j) = .false.
+ enddo
endif
endif
! update tracer and save some diagnostics
- do m=1,ntr
- do i=is,ie ; if (do_i(i,j)) then
+ do concurrent (m=1:ntr)
+ do concurrent (i=is:ie, do_i(i,j))
Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - &
(flux_y(i,m,J) - flux_y(i,m,J-1))) * Ihnew(i)
- endif ; enddo
+ enddo
! diagnose convergence of flux_y and add to convergence of flux_x.
! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt.
if (associated(Tr(m)%advection_xy)) then
- do i=is,ie ; if (do_i(i,j)) then
+ do concurrent (i=is:ie, do_i(i,j))
Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - &
(flux_y(i,m,J) - flux_y(i,m,J-1))* Idt * &
G%IareaT(i,j)
- endif ; enddo
+ enddo
endif
enddo
endif ; enddo ! End of j-loop.
! Do user controlled underflow of the tracer concentrations.
- do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then
- do j=js,je ; do i=is,ie
- if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0
- enddo ; enddo
- endif ; enddo
+ do concurrent (m=1:ntr, Tr(m)%conc_underflow > 0.0)
+ do concurrent (j=js:je, i=is:ie, abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow)
+ Tr(m)%t(i,j,k) = 0.0
+ enddo
+ enddo
! compute ad_y and ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active.
- !$OMP ordered
do m=1,ntr ; if (associated(Tr(m)%ad_y)) then
- do J=js-1,je ; if (domore_v_initial(J)) then
- do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then
+ do concurrent (J=js-1:je, domore_v_initial(J))
+ do concurrent (i=is:ie, do_i(i,j) .or. do_i(i,j+1))
Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt
- endif ; enddo
- endif ; enddo
+ enddo
+ enddo
endif ; enddo ! End of m-loop.
do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then
- do J=js-1,je ; if (domore_v_initial(J)) then
- do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then
+ do concurrent (J=js-1:je, domore_v_initial(J))
+ do concurrent (i=is:ie, do_i(i,j) .or. do_i(i,j+1))
Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt
- endif ; enddo
- endif ; enddo
+ enddo
+ enddo
endif ; enddo ! End of m-loop.
- !$OMP end ordered
+
+ !$omp target exit data map(release: vhh, T_tmp, slope_y, flux_y, domore_v_initial, do_j_tr, do_i)
end subroutine advect_y
@@ -1206,6 +1291,8 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS)
default=.false.)
endif
+ !$omp target enter data map(to: CS)
+
id_clock_advect = cpu_clock_id('(Ocean advect tracer)', grain=CLOCK_MODULE)
id_clock_pass = cpu_clock_id('(Ocean tracer halo updates)', grain=CLOCK_ROUTINE)
id_clock_sync = cpu_clock_id('(Ocean tracer global synch)', grain=CLOCK_ROUTINE)
@@ -1216,6 +1303,7 @@ end subroutine tracer_advect_init
subroutine tracer_advect_end(CS)
type(tracer_advect_CS), pointer :: CS !< module control structure
+ !$omp target exit data map(delete: CS)
if (associated(CS)) deallocate(CS)
end subroutine tracer_advect_end
diff --git a/src/tracer/MOM_tracer_advect_schemes.F90 b/src/tracer/MOM_tracer_advect_schemes.F90
index 630f451cfa..2afe72ec46 100644
--- a/src/tracer/MOM_tracer_advect_schemes.F90
+++ b/src/tracer/MOM_tracer_advect_schemes.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains constants for the tracer advection schemes.
module MOM_tracer_advect_schemes
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_error, FATAL
implicit none ; public
diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90
index f18c14e105..ae6d98e3a7 100644
--- a/src/tracer/MOM_tracer_diabatic.F90
+++ b/src/tracer/MOM_tracer_diabatic.F90
@@ -1,10 +1,12 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains routines that implement physical fluxes of tracers (e.g. due
!! to surface fluxes or mixing). These are intended to be called from call_tracer_column_fns
!! in the MOM_tracer_flow_control module.
module MOM_tracer_diabatic
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_grid, only : ocean_grid_type
use MOM_verticalGrid, only : verticalGrid_type
use MOM_forcing_type, only : forcing
@@ -633,7 +635,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim
enddo
if (numberOfGroundings - maxGroundings > 0) then
- write(mesg, '(i4)') numberOfGroundings - maxGroundings
+ write(mesg, '(I0)') numberOfGroundings - maxGroundings
call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//&
trim(mesg) // " groundings remaining", all_print=.true.)
endif
diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90
index e058058bab..a5f11d1664 100644
--- a/src/tracer/MOM_tracer_flow_control.F90
+++ b/src/tracer/MOM_tracer_flow_control.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Orchestrates the registration and calling of tracer packages
module MOM_tracer_flow_control
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type, assignment(=), EFP_to_real, real_to_EFP, EFP_sum_across_PEs
use MOM_diag_mediator, only : time_type, diag_ctrl
use MOM_error_handler, only : MOM_error, FATAL, WARNING
@@ -345,7 +347,7 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag
call initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag, OBC, CS%MARBL_tracers_CSp, &
sponge_CSp)
if (CS%use_regional_dyes) &
- call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, sponge_CSp, tv)
+ call initialize_dye_tracer(restart, day, G, GV, US, h, diag, OBC, CS%dye_tracer_CSp, sponge_CSp, tv)
if (CS%use_oil) &
call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, sponge_CSp)
if (CS%use_advection_test_tracer) &
@@ -434,7 +436,7 @@ subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G
type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a
!! previous call to call_tracer_register.
- if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_set_forcing"// &
+ if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_set_forcing: "// &
"Module must be initialized via call_tracer_register before it is used.")
! if (CS%use_ideal_age) &
! call ideal_age_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, &
@@ -848,24 +850,24 @@ subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values,
integer :: n
if ((index > 0) .and. (ns > 0)) then
- write(ind_text,'(i8)') index
+ write(ind_text,'(I0)') index
if (ns > 1) then
call MOM_error(FATAL,"Tracer package "//trim(pkg_name)//&
- " is not permitted to return more than one value when queried"//&
- " for specific stock index "//trim(adjustl(ind_text))//".")
+ " is not permitted to return more than one value when queried "//&
+ "for specific stock index "//trim(ind_text)//".")
elseif (ns+ns_tot > 1) then
call MOM_error(FATAL,"Tracer packages "//trim(pkg_name)//" and "//&
- trim(set_pkg_name)//" both attempted to set values for"//&
- " specific stock index "//trim(adjustl(ind_text))//".")
+ trim(set_pkg_name)//" both attempted to set values for "//&
+ "specific stock index "//trim(ind_text)//".")
else
set_pkg_name = pkg_name
endif
endif
if (ns_tot+ns > max_ns) then
- write(ns_text,'(i8)') ns_tot+ns ; write(max_text,'(i8)') max_ns
+ write(ns_text,'(I0)') ns_tot+ns ; write(max_text,'(I0)') max_ns
call MOM_error(FATAL,"Attempted to return more tracer stock values (at least "//&
- trim(adjustl(ns_text))//") than the size "//trim(adjustl(max_text))//&
+ trim(ns_text)//") than the size "//trim(max_text)//&
"of the smallest value, name, or units array.")
endif
diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90
index 21b7e820dc..dc1f5edfc7 100644
--- a/src/tracer/MOM_tracer_hor_diff.F90
+++ b/src/tracer/MOM_tracer_hor_diff.F90
@@ -1,8 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+#include "do_concurrent_compat.h"
+
!> Main routine for lateral (along surface or neutral) diffusion of tracers
module MOM_tracer_hor_diff
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE
use MOM_diag_mediator, only : post_data, diag_ctrl
@@ -202,6 +205,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
call cpu_clock_begin(id_clock_diffuse)
+ !$omp target enter data map(to: Reg, Reg%Tr, CS) map(alloc: khdt_x, khdt_y, kh_u, kh_v)
+ !$ do m = 1, Reg%ntr
+ !$omp target enter data map(to: Reg%Tr(m)%t, Reg%Tr(m)%df_x, Reg%Tr(m)%df_y, Reg%Tr(m)%df2d_x, &
+ !$omp Reg%tr(m)%df2d_y)
+ !$ enddo
+
ntr = Reg%ntr
Idt = 1.0 / dt
h_neglect = GV%H_subroundoff
@@ -236,8 +245,9 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
if (do_online) then
if (use_VarMix) then
- !$OMP parallel do default(shared) private(Kh_loc,Rd_dx)
- do j=js,je ; do I=is-1,ie
+ !$omp target enter data map(to: VarMix, VarMix%SN_u, VarMix%L2u, VarMix%Res_fn_h, &
+ !$omp VarMix%Rd_dx_h, MEKE, MEKE%Kh)
+ do concurrent (j=js:je, I=is-1:ie)
Kh_loc = CS%KhTr
if (use_Eady) Kh_loc = Kh_loc + CS%KhTr_Slope_Cff*VarMix%L2u(I,j)*VarMix%SN_u(I,j)
if (allocated(MEKE%Kh)) &
@@ -252,9 +262,8 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max
Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min
endif
- enddo ; enddo
- !$OMP parallel do default(shared) private(Kh_loc,Rd_dx)
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
Kh_loc = CS%KhTr
if (use_Eady) Kh_loc = Kh_loc + CS%KhTr_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J)
if (allocated(MEKE%Kh)) &
@@ -269,16 +278,16 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max
Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min
endif
- enddo ; enddo
+ enddo
+ !$omp target exit data map(release: VarMix, VarMix%SN_u, VarMix%L2u, VarMix%SN_v, &
+ !$omp VarMix%L2v, VarMix%Res_fn_h, VarMix%Rd_dx_h, MEKE, MEKE%Kh)
- !$OMP parallel do default(shared)
- do j=js,je ; do I=is-1,ie
+ do concurrent (j=js:je, I=is-1:ie)
khdt_x(I,j) = dt*(Kh_u(I,j,1)*(G%dy_Cu(I,j)*G%IdxCu(I,j)))
- enddo ; enddo
- !$OMP parallel do default(shared)
- do J=js-1,je ; do i=is,ie
+ enddo
+ do concurrent (J=js-1:je, i=is:ie)
khdt_y(i,J) = dt*(Kh_v(i,J,1)*(G%dx_Cv(i,J)*G%IdyCv(i,J)))
- enddo ; enddo
+ enddo
elseif (Resoln_scaled) then
!$OMP parallel do default(shared) private(Res_fn)
do j=js,je ; do I=is-1,ie
@@ -292,6 +301,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
Kh_v(i,J,1) = max(CS%KhTr * Res_fn, CS%KhTr_min)
khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn
enddo ; enddo
+ !$omp target update to(khdt_x, khdt_y, Kh_u, Kh_v)
else ! Use a simple constant diffusivity.
if (CS%id_KhTr_u > 0) then
!$OMP parallel do default(shared)
@@ -317,9 +327,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J)))
enddo ; enddo
endif
+ !$omp target update to(khdt_x, khdt_y, Kh_u, Kh_v)
endif ! VarMix
if (CS%max_diff_CFL > 0.0) then
+ !$omp target update from(khdt_x, khdt_y, Kh_u, Kh_v)
if ((CS%id_KhTr_u > 0) .or. (CS%id_KhTr_h > 0)) then
!$OMP parallel do default(shared) private(khdt_max)
do j=js,je ; do I=is-1,ie
@@ -354,6 +366,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
khdt_y(i,J) = min(khdt_y(i,J), khdt_max)
enddo ; enddo
endif
+ !$omp target update to(khdt_x, khdt_y, Kh_u, Kh_v)
endif
else ! .not. do_online
@@ -366,6 +379,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
khdt_y(i,J) = read_khdt_y(i,J)
enddo ; enddo
call pass_vector(khdt_x, khdt_y, G%Domain)
+ !$omp target update to(khdt_x, khdt_y, Kh_u, Kh_v)
endif ! do_online
if (CS%check_diffusive_CFL) then
@@ -381,7 +395,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
call cpu_clock_end(id_clock_sync)
num_itts = max(1, ceiling(max_CFL - 4.0*EPSILON(max_CFL)))
I_numitts = 1.0 / (real(num_itts))
- if (CS%id_CFL > 0) call post_data(CS%id_CFL, CFL, CS%diag, mask=G%mask2dT)
+ if (CS%id_CFL > 0) call post_data(CS%id_CFL, CFL, CS%diag)
elseif (CS%max_diff_CFL > 0.0) then
num_itts = max(1, ceiling(CS%max_diff_CFL - 4.0*EPSILON(CS%max_diff_CFL)))
I_numitts = 1.0 / (real(num_itts))
@@ -394,24 +408,28 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
do k=1,nz ; do j=js,je ; do I=is-1,ie
Reg%Tr(m)%df_x(I,j,k) = 0.0
enddo ; enddo ; enddo
+ !$omp target update to(Reg%Tr(m)%df_x)
endif
if (associated(Reg%Tr(m)%df_y)) then
do k=1,nz ; do J=js-1,je ; do i=is,ie
Reg%Tr(m)%df_y(i,J,k) = 0.0
enddo ; enddo ; enddo
+ !$omp target update to(Reg%Tr(m)%df_y)
endif
if (associated(Reg%Tr(m)%df2d_x)) then
do j=js,je ; do I=is-1,ie ; Reg%Tr(m)%df2d_x(I,j) = 0.0 ; enddo ; enddo
+ !$omp target update to(Reg%Tr(m)%df2d_x)
endif
if (associated(Reg%Tr(m)%df2d_y)) then
do J=js-1,je ; do i=is,ie ; Reg%Tr(m)%df2d_y(i,J) = 0.0 ; enddo ; enddo
+ !$omp target update to(Reg%Tr(m)%df2d_y)
endif
enddo
if (CS%use_hor_bnd_diffusion) then
if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)")
-
+ !$omp target update from(khdt_x, khdt_y)
call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass)
do k=1,nz+1
@@ -541,9 +559,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
else ! following if not using neutral diffusion, but instead along-surface diffusion
if (CS%show_call_tree) call callTree_waypoint("Calculating horizontal diffusion (tracer_hordiff)")
+ !$omp target enter data map(alloc: dTr, Ihdxdy)
+ !$omp target enter data map(to: Coef_x, Coef_y) if(CS%use_hor_bnd_diffusion) ! copy from non-ported loops above
+ !$omp target enter data map(alloc: Coef_x, Coef_y) if(.not.CS%use_hor_bnd_diffusion)
do itt=1,num_itts
- call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass)
- !$OMP parallel do default(shared) private(scale,Coef_y,Coef_x,Ihdxdy,dTr)
+ call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass, omp_offload=.true.)
+ ! loop should probably be reordered
do k=1,nz
scale = I_numitts
if (CS%Diffuse_ML_interior) then
@@ -554,30 +575,30 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
if ((k>GV%nkml) .and. (k<=GV%nk_rho_varies)) cycle
endif
- do J=js-1,je ; do i=is,ie
+ do concurrent (J=js-1:je, i=is:ie)
Coef_y(i,J,1) = ((scale * khdt_y(i,J))*2.0*(h(i,j,k)*h(i,j+1,k))) / &
(h(i,j,k)+h(i,j+1,k)+h_neglect)
- enddo ; enddo
+ enddo
- do j=js,je
- do I=is-1,ie
+ do concurrent (j=js:je)
+ do concurrent (I=is-1:ie)
Coef_x(I,j,1) = ((scale * khdt_x(I,j))*2.0*(h(i,j,k)*h(i+1,j,k))) / &
(h(i,j,k)+h(i+1,j,k)+h_neglect)
enddo
- do i=is,ie
+ do concurrent (i=is:ie)
Ihdxdy(i,j) = G%IareaT(i,j) / (h(i,j,k)+h_neglect)
enddo
enddo
do m=1,ntr
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
dTr(i,j) = Ihdxdy(i,j) * &
( ((Coef_x(I-1,j,1) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k))) - &
(Coef_x(I,j,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)))) + &
((Coef_y(i,J-1,1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k))) - &
(Coef_y(i,J,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) )
- enddo ; enddo
+ enddo
if (associated(Reg%Tr(m)%df_x)) then ; do j=js,je ; do I=G%IscB,G%IecB
Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j,1) &
* (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt
@@ -594,23 +615,22 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J,1) &
* (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt
enddo ; enddo ; endif
- do j=js,je ; do i=is,ie
+ do concurrent (j=js:je, i=is:ie)
Reg%Tr(m)%t(i,j,k) = Reg%Tr(m)%t(i,j,k) + dTr(i,j)
- enddo ; enddo
+ enddo
enddo
enddo ! End of k loop.
! Do user controlled underflow of the tracer concentrations.
do m=1,ntr ; if (Reg%Tr(m)%conc_underflow > 0.0) then
- !$OMP parallel do default(shared)
- do k=1,nz ; do j=js,je ; do i=is,ie
- if (abs(Reg%Tr(m)%t(i,j,k)) < Reg%Tr(m)%conc_underflow) Reg%Tr(m)%t(i,j,k) = 0.0
- enddo ; enddo ; enddo
+ do concurrent (k=1:nz, j=js:je, i=is:ie, abs(Reg%Tr(m)%t(i,j,k)) < Reg%Tr(m)%conc_underflow)
+ Reg%Tr(m)%t(i,j,k) = 0.0
+ enddo
endif ; enddo
enddo ! End of "while" loop.
-
+ !$omp target exit data map(release: dTr, Ihdxdy, Coef_x, Coef_y)
endif ! endif for CS%use_neutral_diffusion
call cpu_clock_end(id_clock_diffuse)
@@ -624,11 +644,17 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
CS, tv, num_itts)
call cpu_clock_end(id_clock_epimix)
endif
+ !$ do m = 1, Reg%ntr
+ !$omp target exit data map(from: Reg%Tr(m)%t, Reg%Tr(m)%df_x, Reg%Tr(m)%df_y, &
+ !$omp Reg%Tr(m)%df2d_x, Reg%tr(m)%df2d_y)
+ !$ enddo
+ !$omp target exit data map(release: Reg%Tr, Reg)
if (CS%debug) call MOM_tracer_chksum("After tracer diffusion ", Reg, G)
! post diagnostics for 2d tracer diffusivity
if (CS%id_KhTr_u > 0) then
+ !$omp target exit data map(from: Kh_u)
do j=js,je ; do I=is-1,ie
Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1)
enddo ; enddo
@@ -641,10 +667,10 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
enddo
enddo
endif
- !call post_data(CS%id_KhTr_u, Kh_u, CS%diag, is_static=.false., mask=G%mask2dCu)
call post_data(CS%id_KhTr_u, Kh_u, CS%diag)
endif
if (CS%id_KhTr_v > 0) then
+ !$omp target exit data map(from: Kh_v)
do J=js-1,je ; do i=is,ie
Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1)
enddo ; enddo
@@ -657,10 +683,10 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
enddo
enddo
endif
- !call post_data(CS%id_KhTr_v, Kh_v, CS%diag, is_static=.false., mask=G%mask2dCv)
call post_data(CS%id_KhTr_v, Kh_v, CS%diag)
endif
if (CS%id_KhTr_h > 0) then
+ !$omp target exit data map(from: Kh_u, Kh_v)
Kh_h(:,:,:) = 0.0
do j=js,je ; do I=is-1,ie
Kh_u(I,j,1) = G%mask2dCu(I,j)*Kh_u(I,j,1)
@@ -681,10 +707,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_
enddo
endif
enddo ; enddo
- !call post_data(CS%id_KhTr_h, Kh_h, CS%diag, is_static=.false., mask=G%mask2dT)
call post_data(CS%id_KhTr_h, Kh_h, CS%diag)
endif
+ !$omp target exit data map(from: khdt_x, khdt_y) if(CS%debug .or. CS%id_khdt_x>0 .or. CS%id_khdt_y>0)
+ !$omp target exit data map(delete: khdt_x, khdt_y, Kh_u, Kh_v) map(release: CS)
+
if (CS%debug) then
call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, &
G%HI, haloshift=0, symmetric=.true., unscale=US%L_to_m**2, &
@@ -729,18 +757,15 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! The naming mnemonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point.
! These are 1-D arrays of pointers to 2-d arrays to minimize memory usage.
- type(p2d), dimension(SZJ_(G)) :: &
+ real, dimension(:,:,:), allocatable :: &
deep_wt_Lu, deep_wt_Ru, & ! The relative weighting of the deeper of a pair [nondim].
- hP_Lu, hP_Ru ! The total thickness on each side for each pair [H ~> m or kg m-2].
-
- type(p2d), dimension(SZJB_(G)) :: &
+ hP_Lu, hP_Ru, & ! The total thickness on each side for each pair [H ~> m or kg m-2].
deep_wt_Lv, deep_wt_Rv, & ! The relative weighting of the deeper of a pair [nondim].
hP_Lv, hP_Rv ! The total thickness on each side for each pair [H ~> m or kg m-2].
- type(p2di), dimension(SZJ_(G)) :: &
+ integer, dimension(:,:,:), allocatable :: &
k0b_Lu, k0a_Lu, & ! The original k-indices of the layers that participate
- k0b_Ru, k0a_Ru ! in each pair of mixing at u-faces.
- type(p2di), dimension(SZJB_(G)) :: &
+ k0b_Ru, k0a_Ru, & ! in each pair of mixing at u-faces.
k0b_Lv, k0a_Lv, & ! The original k-indices of the layers that participate
k0b_Rv, k0a_Rv ! in each pair of mixing at v-faces.
@@ -817,18 +842,18 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
right_set ! of the trio. If densities are exactly equal, both are true.
real :: tmp ! A temporary variable used in swaps [various]
- real :: p_ref_cv(SZI_(G)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa]
+ real :: p_ref_cv(SZI_(G),SZJ_(G)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa]
- integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state
+ integer, dimension(2,2) :: EOSdom ! The i-computational domain for the equation of state
integer :: k_max, k_min, k_test, itmp
integer :: i, j, k, k2, m, is, ie, js, je, nz, nkmb
- integer :: isd, ied, jsd, jed, IsdB, IedB, k_size
+ integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, k_size
integer :: kL, kR, kLa, kLb, kRa, kRb, nP, itt, ns, max_itt
integer :: PEmax_kRho
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
- IsdB = G%IsdB ; IedB = G%IedB
+ IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
Idt = 1.0 / dt
nkmb = GV%nk_rho_varies
@@ -838,30 +863,34 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
max_itt = num_itts ; I_maxitt = 1.0 / (real(max_itt))
endif
- do i=is-2,ie+2 ; p_ref_cv(i) = tv%P_Ref ; enddo
- EOSdom(:) = EOS_domain(G%HI,halo=2)
+ !$omp target enter data map(alloc: rho_coord, Rml_max, max_kRho, rho_srt, k0_srt, num_srt, &
+ !$omp h_srt, p_ref_cv, k_end_srt, max_srt)
- call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass)
+ do concurrent (j=jsd:jed, i=isd:ied)
+ p_ref_cv(i,j) = tv%P_Ref
+ enddo
+
+ call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass, omp_offload=.true.)
! Determine which layers the mixed- and buffer-layers map into...
!$OMP parallel do default(shared)
- do k=1,nkmb ; do j=js-2,je+2
- call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref_cv, rho_coord(:,j,k), &
- tv%eqn_of_state, EOSdom)
- enddo ; enddo
+ do k=1,nkmb
+ call calculate_density(tv%T(:,:,k), tv%S(:,:,k), p_ref_cv, rho_coord(:,:,k), &
+ tv%eqn_of_state)
+ enddo
+ !$omp target exit data map(release: p_ref_cv)
- do j=js-2,je+2 ; do i=is-2,ie+2
+ do concurrent (j=js-2:je+2, i=is-2:ie+2)
Rml_max(i,j) = rho_coord(i,j,1)
num_srt(i,j) = 0 ; max_kRho(i,j) = 0
+ enddo
+ do k=2,nkmb ; do concurrent (j=js-2:je+2, i=is-2:ie+2, Rml_max(i,j) < rho_coord(i,j,k))
+ Rml_max(i,j) = rho_coord(i,j,k)
enddo ; enddo
- do k=2,nkmb ; do j=js-2,je+2 ; do i=is-2,ie+2
- if (Rml_max(i,j) < rho_coord(i,j,k)) Rml_max(i,j) = rho_coord(i,j,k)
- enddo ; enddo ; enddo
! Use bracketing and bisection to find the k-level that the densest of the
! mixed and buffer layer corresponds to, such that:
! GV%Rlay(max_kRho-1) < Rml_max <= GV%Rlay(max_kRho)
- !$OMP parallel do default(shared) private(k_min,k_max,k_test)
- do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.0) then
+ do concurrent (j=js-2:je+2, i=is-2:ie+2, G%mask2dT(i,j) > 0.0)
if ((Rml_max(i,j) > GV%Rlay(nz)) .or. (nkmb+1 > nz)) then ; max_kRho(i,j) = nz+1
elseif ((Rml_max(i,j) <= GV%Rlay(nkmb+1)) .or. (nkmb+2 > nz)) then ; max_kRho(i,j) = nkmb+1
else
@@ -875,76 +904,78 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
if (k_min == k_max) then ; max_kRho(i,j) = k_max ; exit ; endif
enddo
endif
- endif ; enddo ; enddo
+ enddo
PEmax_kRho = 0
- do j=js-1,je+1 ; do i=is-1,ie+1
+ do concurrent (j=js-1:je+1, i=is-1:ie+1) DO_LOCALITY(reduce(max:PEmax_kRho))
k_end_srt(i,j) = max(max_kRho(i,j), max_kRho(i-1,j), max_kRho(i+1,j), &
max_kRho(i,j-1), max_kRho(i,j+1))
if (PEmax_kRho < k_end_srt(i,j)) PEmax_kRho = k_end_srt(i,j)
- enddo ; enddo
+ enddo
if (PEmax_kRho > nz) PEmax_kRho = nz ! PEmax_kRho could have been nz+1.
h_exclude = 10.0*(GV%Angstrom_H + GV%H_subroundoff)
- !$OMP parallel default(shared) private(ns,tmp,itmp)
- !$OMP do
- do j=js-1,je+1
- do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then
+ !$omp target update to(h)
+ do concurrent (j=js-1:je+1) DO_LOCALITY(local(k, ns))
+ do k=1,nkmb ; do concurrent (i=is-1:ie+1, G%mask2dT(i,j) > 0.0) DO_LOCALITY(local(ns))
if (h(i,j,k) > h_exclude) then
num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j)
k0_srt(i,ns,j) = k
rho_srt(i,ns,j) = rho_coord(i,j,k)
h_srt(i,ns,j) = h(i,j,k)
endif
- endif ; enddo ; enddo
- do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then
+ enddo ; enddo
+ do k=nkmb+1,PEmax_kRho ; do concurrent (i=is-1:ie+1, G%mask2dT(i,j) > 0.0) DO_LOCALITY(local(ns))
if ((k<=k_end_srt(i,j)) .and. (h(i,j,k) > h_exclude)) then
num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j)
k0_srt(i,ns,j) = k
rho_srt(i,ns,j) = GV%Rlay(k)
h_srt(i,ns,j) = h(i,j,k)
endif
- endif ; enddo ; enddo
+ enddo ; enddo
enddo
+ !$omp target exit data map(release: rho_coord, Rml_max, k_end_srt)
! Sort each column by increasing density. This should already be close,
! and the size of the arrays are small, so straight insertion is used.
- !$OMP do
- do j=js-1,je+1 ; do i=is-1,ie+1
+ do concurrent (j=js-1:je+1, i=is-1:ie+1)
do k=2,num_srt(i,j) ; if (rho_srt(i,k,j) < rho_srt(i,k-1,j)) then
! The last segment needs to be shuffled earlier in the list.
- do k2 = k,2,-1 ; if (rho_srt(i,k2,j) >= rho_srt(i,k2-1,j)) exit
+ do k2 = k,2,-1 ; if (rho_srt(i,k2,j) < rho_srt(i,k2-1,j)) then
itmp = k0_srt(i,k2-1,j) ; k0_srt(i,k2-1,j) = k0_srt(i,k2,j) ; k0_srt(i,k2,j) = itmp
tmp = rho_srt(i,k2-1,j) ; rho_srt(i,k2-1,j) = rho_srt(i,k2,j) ; rho_srt(i,k2,j) = tmp
tmp = h_srt(i,k2-1,j) ; h_srt(i,k2-1,j) = h_srt(i,k2,j) ; h_srt(i,k2,j) = tmp
- enddo
+ endif ; enddo
endif ; enddo
- enddo ; enddo
- !$OMP do
- do j=js-1,je+1
- max_srt(j) = 0
- do i=is-1,ie+1 ; max_srt(j) = max(max_srt(j), num_srt(i,j)) ; enddo
enddo
- !$OMP end parallel
-
- do j=js,je
- k_size = max(2*max_srt(j),1)
- allocate(deep_wt_Lu(j)%p(IsdB:IedB,k_size))
- allocate(deep_wt_Ru(j)%p(IsdB:IedB,k_size))
- allocate(hP_Lu(j)%p(IsdB:IedB,k_size))
- allocate(hP_Ru(j)%p(IsdB:IedB,k_size))
- allocate(k0a_Lu(j)%p(IsdB:IedB,k_size))
- allocate(k0a_Ru(j)%p(IsdB:IedB,k_size))
- allocate(k0b_Lu(j)%p(IsdB:IedB,k_size))
- allocate(k0b_Ru(j)%p(IsdB:IedB,k_size))
+ do concurrent (j=js-1:je+1) DO_LOCALITY(local(itmp))
+ ! max_srt(j) = 0
+ itmp = 0
+ ! nvfortran do concurrent cannot reduce array elements
+ do concurrent (i=is-1:ie+1) DO_LOCALITY(reduce(max:itmp))
+ itmp = max(itmp, num_srt(i,j))
+ enddo
+ max_srt(j) = itmp
enddo
-
-!$OMP parallel do default(none) shared(is,ie,js,je,G,num_srt,rho_srt,k0b_Lu,k0_srt, &
-!$OMP k0b_Ru,k0a_Lu,k0a_Ru,deep_wt_Lu,deep_wt_Ru, &
-!$OMP h_srt,nkmb,nPu,hP_Lu,hP_Ru) &
+ k_size = 1
+ do concurrent (j=js-1:je+1) DO_LOCALITY(reduce(max:k_size))
+ k_size = max(k_size, 2*max_srt(j))
+ enddo
+ allocate(k0a_Lu(IsdB:iedB,k_size,jsd:jed))
+ allocate(k0a_Ru(IsdB:iedB,k_size,jsd:jed))
+ allocate(k0b_Lu(IsdB:iedB,k_size,jsd:jed))
+ allocate(k0b_Ru(IsdB:iedB,k_size,jsd:jed))
+ allocate(deep_wt_Lu(IsdB:iedB,k_size,jsd:jed))
+ allocate(deep_wt_Ru(IsdB:iedB,k_size,jsd:jed))
+ allocate(hP_Lu(IsdB:iedB,k_size,jsd:jed))
+ allocate(hP_Ru(IsdB:iedB,k_size,jsd:jed))
+ !$omp target enter data map(alloc: deep_wt_Lu, deep_wt_Ru, hP_Lu, hP_Ru, k0a_Lu, k0a_Ru, k0b_Lu, &
+ !$omp k0b_Ru)
+ !$omp target enter data map(alloc: nPu)
+!$OMP target teams loop collapse(2) &
!$OMP private(h_demand_L,h_used_L,h_demand_R,h_used_R, &
!$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, &
!$OMP wt_b,left_set,right_set,h_supply_frac_R, &
-!$OMP h_supply_frac_L)
+!$OMP h_supply_frac_L, k)
do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then
! Set up the pairings for fluxes through the zonal faces.
@@ -974,14 +1005,14 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
nP = nP+1 ; k = nP
rho_pair = rho_srt(i+1,kR,j)
- k0b_Lu(j)%p(I,k) = k0_srt(i,kL,j) ; k0b_Ru(j)%p(I,k) = k0_srt(i+1,kR,j)
- k0a_Lu(j)%p(I,k) = k0_srt(i,kL-1,j) ; k0a_Ru(j)%p(I,k) = k0b_Ru(j)%p(I,k)
+ k0b_Lu(I,k,j) = k0_srt(i,kL,j) ; k0b_Ru(I,k,j) = k0_srt(i+1,kR,j)
+ k0a_Lu(I,k,j) = k0_srt(i,kL-1,j) ; k0a_Ru(I,k,j) = k0b_Ru(I,k,j)
kbs_Lp(k) = kL ; kbs_Rp(k) = kR
rho_a = rho_srt(i,kL-1,j) ; rho_b = rho_srt(i,kL,j)
wt_b = 1.0 ; if (abs(rho_a - rho_b) > abs(rho_pair - rho_a)) &
wt_b = (rho_pair - rho_a) / (rho_b - rho_a)
- deep_wt_Lu(j)%p(I,k) = wt_b ; deep_wt_Ru(j)%p(I,k) = 1.0
+ deep_wt_Lu(I,k,j) = wt_b ; deep_wt_Ru(I,k,j) = 1.0
h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i+1,kR,j) * wt_b
h_demand_L(kL-1) = h_demand_L(kL-1) + 0.5*h_srt(i+1,kR,j) * (1.0-wt_b)
@@ -991,15 +1022,15 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! The left point is lighter and defines the density for this trio.
nP = nP+1 ; k = nP
rho_pair = rho_srt(i,kL,j)
- k0b_Lu(j)%p(I,k) = k0_srt(i,kL,j) ; k0b_Ru(j)%p(I,k) = k0_srt(i+1,kR,j)
- k0a_Lu(j)%p(I,k) = k0b_Lu(j)%p(I,k) ; k0a_Ru(j)%p(I,k) = k0_srt(i+1,kR-1,j)
+ k0b_Lu(I,k,j) = k0_srt(i,kL,j) ; k0b_Ru(I,k,j) = k0_srt(i+1,kR,j)
+ k0a_Lu(I,k,j) = k0b_Lu(I,k,j) ; k0a_Ru(I,k,j) = k0_srt(i+1,kR-1,j)
kbs_Lp(k) = kL ; kbs_Rp(k) = kR
rho_a = rho_srt(i+1,kR-1,j) ; rho_b = rho_srt(i+1,kR,j)
wt_b = 1.0 ; if (abs(rho_a - rho_b) > abs(rho_pair - rho_a)) &
wt_b = (rho_pair - rho_a) / (rho_b - rho_a)
- deep_wt_Lu(j)%p(I,k) = 1.0 ; deep_wt_Ru(j)%p(I,k) = wt_b
+ deep_wt_Lu(I,k,j) = 1.0 ; deep_wt_Ru(I,k,j) = wt_b
h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j) * wt_b
h_demand_R(kR-1) = h_demand_R(kR-1) + 0.5*h_srt(i,kL,j) * (1.0-wt_b)
@@ -1008,10 +1039,10 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
elseif ((k0_srt(i,kL,j) <= nkmb) .or. (k0_srt(i+1,kR,j) <= nkmb)) then
! The densities are exactly equal and one layer is above the interior.
nP = nP+1 ; k = nP
- k0b_Lu(j)%p(I,k) = k0_srt(i,kL,j) ; k0b_Ru(j)%p(I,k) = k0_srt(i+1,kR,j)
- k0a_Lu(j)%p(I,k) = k0b_Lu(j)%p(I,k) ; k0a_Ru(j)%p(I,k) = k0b_Ru(j)%p(I,k)
+ k0b_Lu(I,k,j) = k0_srt(i,kL,j) ; k0b_Ru(I,k,j) = k0_srt(i+1,kR,j)
+ k0a_Lu(I,k,j) = k0b_Lu(I,k,j) ; k0a_Ru(I,k,j) = k0b_Ru(I,k,j)
kbs_Lp(k) = kL ; kbs_Rp(k) = kR
- deep_wt_Lu(j)%p(I,k) = 1.0 ; deep_wt_Ru(j)%p(I,k) = 1.0
+ deep_wt_Lu(I,k,j) = 1.0 ; deep_wt_Ru(I,k,j) = 1.0
h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i+1,kR,j)
h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j)
@@ -1043,27 +1074,27 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! Distribute the "exported" thicknesses proportionately.
do k=1,nPu(I,j)
kL = kbs_Lp(k) ; kR = kbs_Rp(k)
- hP_Lu(j)%p(I,k) = 0.0 ; hP_Ru(j)%p(I,k) = 0.0
+ hP_Lu(I,k,j) = 0.0 ; hP_Ru(I,k,j) = 0.0
if (left_set(k)) then ! Add the contributing thicknesses on the right.
- if (deep_wt_Ru(j)%p(I,k) < 1.0) then
- hP_Ru(j)%p(I,k) = 0.5*h_srt(i,kL,j) * min(h_supply_frac_R(kR), h_supply_frac_R(kR-1))
- wt_b = deep_wt_Ru(j)%p(I,k)
- h_used_R(kR-1) = h_used_R(kR-1) + (1.0 - wt_b)*hP_Ru(j)%p(I,k)
- h_used_R(kR) = h_used_R(kR) + wt_b*hP_Ru(j)%p(I,k)
+ if (deep_wt_Ru(I,k,j) < 1.0) then
+ hP_Ru(I,k,j) = 0.5*h_srt(i,kL,j) * min(h_supply_frac_R(kR), h_supply_frac_R(kR-1))
+ wt_b = deep_wt_Ru(I,k,j)
+ h_used_R(kR-1) = h_used_R(kR-1) + (1.0 - wt_b)*hP_Ru(I,k,j)
+ h_used_R(kR) = h_used_R(kR) + wt_b*hP_Ru(I,k,j)
else
- hP_Ru(j)%p(I,k) = 0.5*h_srt(i,kL,j) * h_supply_frac_R(kR)
- h_used_R(kR) = h_used_R(kR) + hP_Ru(j)%p(I,k)
+ hP_Ru(I,k,j) = 0.5*h_srt(i,kL,j) * h_supply_frac_R(kR)
+ h_used_R(kR) = h_used_R(kR) + hP_Ru(I,k,j)
endif
endif
if (right_set(k)) then ! Add the contributing thicknesses on the left.
- if (deep_wt_Lu(j)%p(I,k) < 1.0) then
- hP_Lu(j)%p(I,k) = 0.5*h_srt(i+1,kR,j) * min(h_supply_frac_L(kL), h_supply_frac_L(kL-1))
- wt_b = deep_wt_Lu(j)%p(I,k)
- h_used_L(kL-1) = h_used_L(kL-1) + (1.0 - wt_b)*hP_Lu(j)%p(I,k)
- h_used_L(kL) = h_used_L(kL) + wt_b*hP_Lu(j)%p(I,k)
+ if (deep_wt_Lu(I,k,j) < 1.0) then
+ hP_Lu(I,k,j) = 0.5*h_srt(i+1,kR,j) * min(h_supply_frac_L(kL), h_supply_frac_L(kL-1))
+ wt_b = deep_wt_Lu(I,k,j)
+ h_used_L(kL-1) = h_used_L(kL-1) + (1.0 - wt_b)*hP_Lu(I,k,j)
+ h_used_L(kL) = h_used_L(kL) + wt_b*hP_Lu(I,k,j)
else
- hP_Lu(j)%p(I,k) = 0.5*h_srt(i+1,kR,j) * h_supply_frac_L(kL)
- h_used_L(kL) = h_used_L(kL) + hP_Lu(j)%p(I,k)
+ hP_Lu(I,k,j) = 0.5*h_srt(i+1,kR,j) * h_supply_frac_L(kL)
+ h_used_L(kL) = h_used_L(kL) + hP_Lu(I,k,j)
endif
endif
enddo
@@ -1071,33 +1102,32 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! The left-over thickness (at least half the layer thickness) is now
! added to the thicknesses of the importing columns.
do k=1,nPu(I,j)
- if (left_set(k)) hP_Lu(j)%p(I,k) = hP_Lu(j)%p(I,k) + &
+ if (left_set(k)) hP_Lu(I,k,j) = hP_Lu(I,k,j) + &
(h_srt(i,kbs_Lp(k),j) - h_used_L(kbs_Lp(k)))
- if (right_set(k)) hP_Ru(j)%p(I,k) = hP_Ru(j)%p(I,k) + &
+ if (right_set(k)) hP_Ru(I,k,j) = hP_Ru(I,k,j) + &
(h_srt(i+1,kbs_Rp(k),j) - h_used_R(kbs_Rp(k)))
enddo
endif ; enddo ; enddo ! i- & j- loops over zonal faces.
- do J=js-1,je
- k_size = max(max_srt(j)+max_srt(j+1),1)
- allocate(deep_wt_Lv(J)%p(isd:ied,k_size))
- allocate(deep_wt_Rv(J)%p(isd:ied,k_size))
- allocate(hP_Lv(J)%p(isd:ied,k_size))
- allocate(hP_Rv(J)%p(isd:ied,k_size))
- allocate(k0a_Lv(J)%p(isd:ied,k_size))
- allocate(k0a_Rv(J)%p(isd:ied,k_size))
- allocate(k0b_Lv(J)%p(isd:ied,k_size))
- allocate(k0b_Rv(J)%p(isd:ied,k_size))
- enddo
+ allocate(deep_wt_Lv(isd:ied,k_size,JsdB:JedB))
+ allocate(deep_wt_Rv(isd:ied,k_size,JsdB:JedB))
+ allocate(hP_Lv(isd:ied,k_size,JsdB:JedB))
+ allocate(hP_Rv(isd:ied,k_size,JsdB:JedB))
+ allocate(k0a_Lv(isd:ied,k_size,JsdB:JedB))
+ allocate(k0a_Rv(isd:ied,k_size,JsdB:JedB))
+ allocate(k0b_Lv(isd:ied,k_size,JsdB:JedB))
+ allocate(k0b_Rv(isd:ied,k_size,JsdB:JedB))
+ !$omp target enter data map(alloc: deep_wt_Lv, deep_wt_Rv, hP_Lv, hP_Rv, k0a_Lv, k0a_Rv, k0b_Lv, &
+ !$omp k0b_Rv)
+
+ !$omp target enter data map(alloc: nPv)
-!$OMP parallel do default(none) shared(is,ie,js,je,G,num_srt,rho_srt,k0b_Lv,k0b_Rv, &
-!$OMP k0_srt,k0a_Lv,k0a_Rv,deep_wt_Lv,deep_wt_Rv, &
-!$OMP h_srt,nkmb,nPv,hP_Lv,hP_Rv) &
+!$OMP target teams loop collapse(2) &
!$OMP private(h_demand_L,h_used_L,h_demand_R,h_used_R, &
!$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, &
!$OMP wt_b,left_set,right_set,h_supply_frac_R, &
-!$OMP h_supply_frac_L)
+!$OMP h_supply_frac_L,k) map(to: num_srt)
do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then
! Set up the pairings for fluxes through the meridional faces.
@@ -1127,14 +1157,14 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
nP = nP+1 ; k = nP
rho_pair = rho_srt(i,kR,j+1)
- k0b_Lv(J)%p(i,k) = k0_srt(i,kL,j) ; k0b_Rv(J)%p(i,k) = k0_srt(i,kR,j+1)
- k0a_Lv(J)%p(i,k) = k0_srt(i,kL-1,j) ; k0a_Rv(J)%p(i,k) = k0b_Rv(J)%p(i,k)
+ k0b_Lv(i,k,J) = k0_srt(i,kL,j) ; k0b_Rv(i,k,J) = k0_srt(i,kR,j+1)
+ k0a_Lv(i,k,J) = k0_srt(i,kL-1,j) ; k0a_Rv(i,k,J) = k0b_Rv(i,k,J)
kbs_Lp(k) = kL ; kbs_Rp(k) = kR
rho_a = rho_srt(i,kL-1,j) ; rho_b = rho_srt(i,kL,j)
wt_b = 1.0 ; if (abs(rho_a - rho_b) > abs(rho_pair - rho_a)) &
wt_b = (rho_pair - rho_a) / (rho_b - rho_a)
- deep_wt_Lv(J)%p(i,k) = wt_b ; deep_wt_Rv(J)%p(i,k) = 1.0
+ deep_wt_Lv(I,k,J) = wt_b ; deep_wt_Rv(I,k,J) = 1.0
h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i,kR,j+1) * wt_b
h_demand_L(kL-1) = h_demand_L(kL-1) + 0.5*h_srt(i,kR,j+1) * (1.0-wt_b)
@@ -1144,15 +1174,15 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! The left point is lighter and defines the density for this trio.
nP = nP+1 ; k = nP
rho_pair = rho_srt(i,kL,j)
- k0b_Lv(J)%p(i,k) = k0_srt(i,kL,j) ; k0b_Rv(J)%p(i,k) = k0_srt(i,kR,j+1)
- k0a_Lv(J)%p(i,k) = k0b_Lv(J)%p(i,k) ; k0a_Rv(J)%p(i,k) = k0_srt(i,kR-1,j+1)
+ k0b_Lv(i,k,J) = k0_srt(i,kL,j) ; k0b_Rv(i,k,J) = k0_srt(i,kR,j+1)
+ k0a_Lv(i,k,J) = k0b_Lv(i,k,J) ; k0a_Rv(i,k,J) = k0_srt(i,kR-1,j+1)
kbs_Lp(k) = kL ; kbs_Rp(k) = kR
rho_a = rho_srt(i,kR-1,j+1) ; rho_b = rho_srt(i,kR,j+1)
wt_b = 1.0 ; if (abs(rho_a - rho_b) > abs(rho_pair - rho_a)) &
wt_b = (rho_pair - rho_a) / (rho_b - rho_a)
- deep_wt_Lv(J)%p(i,k) = 1.0 ; deep_wt_Rv(J)%p(i,k) = wt_b
+ deep_wt_Lv(I,k,J) = 1.0 ; deep_wt_Rv(I,k,J) = wt_b
h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j) * wt_b
h_demand_R(kR-1) = h_demand_R(kR-1) + 0.5*h_srt(i,kL,j) * (1.0-wt_b)
@@ -1161,10 +1191,10 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
elseif ((k0_srt(i,kL,j) <= nkmb) .or. (k0_srt(i,kR,j+1) <= nkmb)) then
! The densities are exactly equal and one layer is above the interior.
nP = nP+1 ; k = nP
- k0b_Lv(J)%p(i,k) = k0_srt(i,kL,j) ; k0b_Rv(J)%p(i,k) = k0_srt(i,kR,j+1)
- k0a_Lv(J)%p(i,k) = k0b_Lv(J)%p(i,k) ; k0a_Rv(J)%p(i,k) = k0b_Rv(J)%p(i,k)
+ k0b_Lv(i,k,J) = k0_srt(i,kL,j) ; k0b_Rv(i,k,J) = k0_srt(i,kR,j+1)
+ k0a_Lv(i,k,J) = k0b_Lv(i,k,J) ; k0a_Rv(i,k,J) = k0b_Rv(i,k,J)
kbs_Lp(k) = kL ; kbs_Rp(k) = kR
- deep_wt_Lv(J)%p(i,k) = 1.0 ; deep_wt_Rv(J)%p(i,k) = 1.0
+ deep_wt_Lv(I,k,J) = 1.0 ; deep_wt_Rv(I,k,J) = 1.0
h_demand_L(kL) = h_demand_L(kL) + 0.5*h_srt(i,kR,j+1)
h_demand_R(kR) = h_demand_R(kR) + 0.5*h_srt(i,kL,j)
@@ -1196,27 +1226,27 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! Distribute the "exported" thicknesses proportionately.
do k=1,nPv(i,J)
kL = kbs_Lp(k) ; kR = kbs_Rp(k)
- hP_Lv(J)%p(i,k) = 0.0 ; hP_Rv(J)%p(i,k) = 0.0
+ hP_Lv(I,k,J) = 0.0 ; hP_Rv(I,k,J) = 0.0
if (left_set(k)) then ! Add the contributing thicknesses on the right.
- if (deep_wt_Rv(J)%p(i,k) < 1.0) then
- hP_Rv(J)%p(i,k) = 0.5*h_srt(i,kL,j) * min(h_supply_frac_R(kR), h_supply_frac_R(kR-1))
- wt_b = deep_wt_Rv(J)%p(i,k)
- h_used_R(kR-1) = h_used_R(kR-1) + (1.0 - wt_b) * hP_Rv(J)%p(i,k)
- h_used_R(kR) = h_used_R(kR) + wt_b * hP_Rv(J)%p(i,k)
+ if (deep_wt_Rv(I,k,J) < 1.0) then
+ hP_Rv(I,k,J) = 0.5*h_srt(i,kL,j) * min(h_supply_frac_R(kR), h_supply_frac_R(kR-1))
+ wt_b = deep_wt_Rv(I,k,J)
+ h_used_R(kR-1) = h_used_R(kR-1) + (1.0 - wt_b) * hP_Rv(I,k,J)
+ h_used_R(kR) = h_used_R(kR) + wt_b * hP_Rv(I,k,J)
else
- hP_Rv(J)%p(i,k) = 0.5*h_srt(i,kL,j) * h_supply_frac_R(kR)
- h_used_R(kR) = h_used_R(kR) + hP_Rv(J)%p(i,k)
+ hP_Rv(I,k,J) = 0.5*h_srt(i,kL,j) * h_supply_frac_R(kR)
+ h_used_R(kR) = h_used_R(kR) + hP_Rv(I,k,J)
endif
endif
if (right_set(k)) then ! Add the contributing thicknesses on the left.
- if (deep_wt_Lv(J)%p(i,k) < 1.0) then
- hP_Lv(J)%p(i,k) = 0.5*h_srt(i,kR,j+1) * min(h_supply_frac_L(kL), h_supply_frac_L(kL-1))
- wt_b = deep_wt_Lv(J)%p(i,k)
- h_used_L(kL-1) = h_used_L(kL-1) + (1.0 - wt_b) * hP_Lv(J)%p(i,k)
- h_used_L(kL) = h_used_L(kL) + wt_b * hP_Lv(J)%p(i,k)
+ if (deep_wt_Lv(I,k,J) < 1.0) then
+ hP_Lv(I,k,J) = 0.5*h_srt(i,kR,j+1) * min(h_supply_frac_L(kL), h_supply_frac_L(kL-1))
+ wt_b = deep_wt_Lv(I,k,J)
+ h_used_L(kL-1) = h_used_L(kL-1) + (1.0 - wt_b) * hP_Lv(I,k,J)
+ h_used_L(kL) = h_used_L(kL) + wt_b * hP_Lv(I,k,J)
else
- hP_Lv(J)%p(i,k) = 0.5*h_srt(i,kR,j+1) * h_supply_frac_L(kL)
- h_used_L(kL) = h_used_L(kL) + hP_Lv(J)%p(i,k)
+ hP_Lv(I,k,J) = 0.5*h_srt(i,kR,j+1) * h_supply_frac_L(kL)
+ h_used_L(kL) = h_used_L(kL) + hP_Lv(I,k,J)
endif
endif
enddo
@@ -1224,37 +1254,47 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! The left-over thickness (at least half the layer thickness) is now
! added to the thicknesses of the importing columns.
do k=1,nPv(i,J)
- if (left_set(k)) hP_Lv(J)%p(i,k) = hP_Lv(J)%p(i,k) + &
+ if (left_set(k)) hP_Lv(I,k,J) = hP_Lv(I,k,J) + &
(h_srt(i,kbs_Lp(k),j) - h_used_L(kbs_Lp(k)))
- if (right_set(k)) hP_Rv(J)%p(i,k) = hP_Rv(J)%p(i,k) + &
+ if (right_set(k)) hP_Rv(I,k,J) = hP_Rv(I,k,J) + &
(h_srt(i,kbs_Rp(k),j+1) - h_used_R(kbs_Rp(k)))
enddo
endif ; enddo ; enddo ! i- & j- loops over meridional faces.
-
+ !$omp target exit data map(release: h_srt, k0_srt)
! The tracer-specific calculations start here.
+ !$omp target enter data map(alloc: Tr_flux_3d, Tr_adj_vert_L, Tr_adj_vert_R, tr_flux_N, &
+ !$omp tr_flux_S, tr_flux_E, tr_flux_W, tr_flux_conv)
+
do itt=1,max_itt
if (itt > 1) then ! The halos have already been filled if itt==1.
- call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass)
+ call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass, omp_offload=.true.)
endif
-
do m=1,ntr
! Zero out tracer tendencies.
if (CS%answer_date <= 20240330) then
- tr_flux_conv(:,:,:) = 0.0
+ do concurrent (k=1:nz, j=jsd:jed, i=isd:ied)
+ tr_flux_conv(i,j,k) = 0.0
+ enddo
else
- tr_flux_N(:,:,:) = 0.0 ; tr_flux_S(:,:,:) = 0.0
- tr_flux_E(:,:,:) = 0.0 ; tr_flux_W(:,:,:) = 0.0
+ do concurrent (k=1:nz, j=jsd:jed, i=isd:ied)
+ tr_flux_N(i,j,k) = 0.0 ; tr_flux_S(i,j,k) = 0.0
+ tr_flux_E(i,j,k) = 0.0 ; tr_flux_W(i,j,k) = 0.0
+ enddo
endif
- tr_flux_3d(:,:,:) = 0.0
- tr_adj_vert_R(:,:,:) = 0.0 ; tr_adj_vert_L(:,:,:) = 0.0
+ do concurrent (k=1:2*nz, J=JsdB:JedB, i=isd:ied)
+ tr_flux_3d(i,j,k) = 0.0
+ tr_adj_vert_R(i,j,k) = 0.0 ; tr_adj_vert_L(i,j,k) = 0.0
+ enddo
- !$OMP parallel do default(shared) private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb,Tr_La, &
- !$OMP Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R,h_L,h_R, &
- !$OMP Tr_flux,Tr_adj_vert,wt_a,vol)
+ ! collapse(2) is reproducible for CS%answer_date > 20240330 but not <= 20240330.
+ ! Do concurrent around j-loop doesn't seem to do the right thing.
+ !$omp target teams loop collapse(2) private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, &
+ !$omp Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, &
+ !$omp h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol)
do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then
! Determine the fluxes through the zonal faces.
@@ -1286,32 +1326,32 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! Include all points in diffusive pairings at this face.
do k=1,nPu(I,j)
- Tr_Lb = Tr(m)%t(i,j,k0b_Lu(j)%p(I,k))
- Tr_Rb = Tr(m)%t(i+1,j,k0b_Ru(j)%p(I,k))
+ Tr_Lb = Tr(m)%t(i,j,k0b_Lu(I,k,j))
+ Tr_Rb = Tr(m)%t(i+1,j,k0b_Ru(I,k,j))
Tr_La = Tr_Lb ; Tr_Ra = Tr_Rb
- if (deep_wt_Lu(j)%p(I,k) < 1.0) Tr_La = Tr(m)%t(i,j,k0a_Lu(j)%p(I,k))
- if (deep_wt_Ru(j)%p(I,k) < 1.0) Tr_Ra = Tr(m)%t(i+1,j,k0a_Ru(j)%p(I,k))
+ if (deep_wt_Lu(I,k,j) < 1.0) Tr_La = Tr(m)%t(i,j,k0a_Lu(I,k,j))
+ if (deep_wt_Ru(I,k,j) < 1.0) Tr_Ra = Tr(m)%t(i+1,j,k0a_Ru(I,k,j))
Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb)
Tr_max_face = max(Tr_max_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb)
enddo
endif
do k=1,nPu(I,j)
- kLb = k0b_Lu(j)%p(I,k) ; Tr_Lb = Tr(m)%t(i,j,kLb) ; Tr_av_L = Tr_Lb
- if (deep_wt_Lu(j)%p(I,k) < 1.0) then
- kLa = k0a_Lu(j)%p(I,k) ; Tr_La = Tr(m)%t(i,j,kLa)
- wt_b = deep_wt_Lu(j)%p(I,k)
+ kLb = k0b_Lu(I,k,j) ; Tr_Lb = Tr(m)%t(i,j,kLb) ; Tr_av_L = Tr_Lb
+ if (deep_wt_Lu(I,k,j) < 1.0) then
+ kLa = k0a_Lu(I,k,j) ; Tr_La = Tr(m)%t(i,j,kLa)
+ wt_b = deep_wt_Lu(I,k,j)
Tr_av_L = wt_b*Tr_Lb + (1.0-wt_b)*Tr_La
endif
- kRb = k0b_Ru(j)%p(I,k) ; Tr_Rb = Tr(m)%t(i+1,j,kRb) ; Tr_av_R = Tr_Rb
- if (deep_wt_Ru(j)%p(I,k) < 1.0) then
- kRa = k0a_Ru(j)%p(I,k) ; Tr_Ra = Tr(m)%t(i+1,j,kRa)
- wt_b = deep_wt_Ru(j)%p(I,k)
+ kRb = k0b_Ru(I,k,j) ; Tr_Rb = Tr(m)%t(i+1,j,kRb) ; Tr_av_R = Tr_Rb
+ if (deep_wt_Ru(I,k,j) < 1.0) then
+ kRa = k0a_Ru(I,k,j) ; Tr_Ra = Tr(m)%t(i+1,j,kRa)
+ wt_b = deep_wt_Ru(I,k,j)
Tr_av_R = wt_b*Tr_Rb + (1.0-wt_b)*Tr_Ra
endif
- h_L = hP_Lu(j)%p(I,k) ; h_R = hP_Ru(j)%p(I,k)
+ h_L = hP_Lu(I,k,j) ; h_R = hP_Ru(I,k,j)
if (CS%answer_date <= 20240330) then
Tr_flux = I_maxitt * khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R) * &
((2.0 * h_L * h_R) / (h_L + h_R))
@@ -1320,7 +1360,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R)
endif
- if (deep_wt_Lu(j)%p(I,k) >= 1.0) then
+ if (deep_wt_Lu(I,k,j) >= 1.0) then
if (CS%answer_date <= 20240330) then
tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux
else
@@ -1328,8 +1368,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
endif
else
Tr_adj_vert = 0.0
- wt_b = deep_wt_Lu(j)%p(I,k) ; wt_a = 1.0 - wt_b
- vol = hP_Lu(j)%p(I,k) * G%areaT(i,j)
+ wt_b = deep_wt_Lu(I,k,j) ; wt_a = 1.0 - wt_b
+ vol = hP_Lu(I,k,j) * G%areaT(i,j)
! Ensure that the tracer flux does not drive the tracer values
! outside of the range Tr_min_face <= Tr <= Tr_max_face, or if it
@@ -1364,7 +1404,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
endif
endif
- if (deep_wt_Ru(j)%p(I,k) >= 1.0) then
+ if (deep_wt_Ru(I,k,j) >= 1.0) then
if (CS%answer_date <= 20240330) then
tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + Tr_flux
else
@@ -1372,8 +1412,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
endif
else
Tr_adj_vert = 0.0
- wt_b = deep_wt_Ru(j)%p(I,k) ; wt_a = 1.0 - wt_b
- vol = hP_Ru(j)%p(I,k) * G%areaT(i+1,j)
+ wt_b = deep_wt_Ru(I,k,j) ; wt_a = 1.0 - wt_b
+ vol = hP_Ru(I,k,j) * G%areaT(i+1,j)
! Ensure that the tracer flux does not drive the tracer values
! outside of the range Tr_min_face <= Tr <= Tr_max_face, or if it
@@ -1412,9 +1452,10 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
enddo ! Loop over pairings at faces.
endif ; enddo ; enddo ! i- & j- loops over zonal faces.
- !$OMP parallel do default(shared) private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, &
- !$OMP Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, &
- !$OMP h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol)
+ ! this gives wrong result when using do concurrent on NVHPC 25.9
+ !$omp target teams loop collapse(2) private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, &
+ !$omp Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, &
+ !$omp h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol)
do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then
! Determine the fluxes through the meridional faces.
@@ -1446,39 +1487,39 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
! Include all points in diffusive pairings at this face.
do k=1,nPv(i,J)
- Tr_Lb = Tr(m)%t(i,j,k0b_Lv(J)%p(i,k)) ; Tr_Rb = Tr(m)%t(i,j+1,k0b_Rv(J)%p(i,k))
+ Tr_Lb = Tr(m)%t(i,j,k0b_Lv(i,k,J)) ; Tr_Rb = Tr(m)%t(i,j+1,k0b_Rv(i,k,J))
Tr_La = Tr_Lb ; Tr_Ra = Tr_Rb
- if (deep_wt_Lv(J)%p(i,k) < 1.0) Tr_La = Tr(m)%t(i,j,k0a_Lv(J)%p(i,k))
- if (deep_wt_Rv(J)%p(i,k) < 1.0) Tr_Ra = Tr(m)%t(i,j+1,k0a_Rv(J)%p(i,k))
+ if (deep_wt_Lv(I,k,J) < 1.0) Tr_La = Tr(m)%t(i,j,k0a_Lv(i,k,J))
+ if (deep_wt_Rv(I,k,J) < 1.0) Tr_Ra = Tr(m)%t(i,j+1,k0a_Rv(i,k,J))
Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb)
Tr_max_face = max(Tr_max_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb)
enddo
endif
do k=1,nPv(i,J)
- kLb = k0b_Lv(J)%p(i,k) ; Tr_Lb = Tr(m)%t(i,j,kLb) ; Tr_av_L = Tr_Lb
- if (deep_wt_Lv(J)%p(i,k) < 1.0) then
- kLa = k0a_Lv(J)%p(i,k) ; Tr_La = Tr(m)%t(i,j,kLa)
- wt_b = deep_wt_Lv(J)%p(i,k)
+ kLb = k0b_Lv(i,k,J) ; Tr_Lb = Tr(m)%t(i,j,kLb) ; Tr_av_L = Tr_Lb
+ if (deep_wt_Lv(I,k,J) < 1.0) then
+ kLa = k0a_Lv(i,k,J) ; Tr_La = Tr(m)%t(i,j,kLa)
+ wt_b = deep_wt_Lv(I,k,J)
Tr_av_L = wt_b * Tr_Lb + (1.0-wt_b) * Tr_La
endif
- kRb = k0b_Rv(J)%p(i,k) ; Tr_Rb = Tr(m)%t(i,j+1,kRb) ; Tr_av_R = Tr_Rb
- if (deep_wt_Rv(J)%p(i,k) < 1.0) then
- kRa = k0a_Rv(J)%p(i,k) ; Tr_Ra = Tr(m)%t(i,j+1,kRa)
- wt_b = deep_wt_Rv(J)%p(i,k)
+ kRb = k0b_Rv(i,k,J) ; Tr_Rb = Tr(m)%t(i,j+1,kRb) ; Tr_av_R = Tr_Rb
+ if (deep_wt_Rv(I,k,J) < 1.0) then
+ kRa = k0a_Rv(i,k,J) ; Tr_Ra = Tr(m)%t(i,j+1,kRa)
+ wt_b = deep_wt_Rv(I,k,J)
Tr_av_R = wt_b * Tr_Rb + (1.0-wt_b) * Tr_Ra
endif
- h_L = hP_Lv(J)%p(i,k) ; h_R = hP_Rv(J)%p(i,k)
+ h_L = hP_Lv(I,k,J) ; h_R = hP_Rv(I,k,J)
Tr_flux = I_maxitt * ((2.0 * h_L * h_R) / (h_L + h_R)) * &
khdt_epi_y(i,J) * (Tr_av_L - Tr_av_R)
Tr_flux_3d(i,J,k) = Tr_flux
- if (deep_wt_Lv(J)%p(i,k) < 1.0) then
+ if (deep_wt_Lv(I,k,J) < 1.0) then
Tr_adj_vert = 0.0
- wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b
- vol = hP_Lv(J)%p(i,k) * G%areaT(i,j)
+ wt_b = deep_wt_Lv(I,k,J) ; wt_a = 1.0 - wt_b
+ vol = hP_Lv(I,k,J) * G%areaT(i,j)
! Ensure that the tracer flux does not drive the tracer values
! outside of the range Tr_min_face <= Tr <= Tr_max_face.
@@ -1502,10 +1543,10 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
Tr_adj_vert_L(i,J,k) = Tr_adj_vert
endif
- if (deep_wt_Rv(J)%p(i,k) < 1.0) then
+ if (deep_wt_Rv(I,k,J) < 1.0) then
Tr_adj_vert = 0.0
- wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b
- vol = hP_Rv(J)%p(i,k) * G%areaT(i,j+1)
+ wt_b = deep_wt_Rv(I,k,J) ; wt_a = 1.0 - wt_b
+ vol = hP_Rv(I,k,J) * G%areaT(i,j+1)
! Ensure that the tracer flux does not drive the tracer values
! outside of the range Tr_min_face <= Tr <= Tr_max_face.
@@ -1533,95 +1574,95 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, &
enddo ! Loop over pairings at faces.
endif ; enddo ; enddo ! i- & j- loops over meridional faces.
- !$OMP parallel do default(shared) private(kLa,kLb,kRa,kRb,wt_b,wt_a)
- do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then
- ! The non-stride-1 loop order here is to facilitate openMP threading. However, it might be
- ! suboptimal when openMP threading is not used, at which point it might be better to fuse
- ! this loop with those that precede it and thereby eliminate the need for three 3-d arrays.
- if (CS%answer_date <= 20240330) then
- do k=1,nPv(i,J)
- kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k)
- if (deep_wt_Lv(J)%p(i,k) >= 1.0) then
- tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,J,k)
- else
- kLa = k0a_Lv(J)%p(i,k)
- wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b
- tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k))
- tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k))
- endif
- if (deep_wt_Rv(J)%p(i,k) >= 1.0) then
- tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,J,k)
- else
- kRa = k0a_Rv(J)%p(i,k)
- wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b
- tr_flux_conv(i,j+1,kRa) = tr_flux_conv(i,j+1,kRa) + &
- (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k))
- tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + &
- (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k))
- endif
- enddo
- else
+ ! The non-stride-1 loop order here is to facilitate openMP threading. However, it might be
+ ! suboptimal when openMP threading is not used, at which point it might be better to fuse
+ ! this loop with those that precede it and thereby eliminate the need for three 3-d arrays.
+ if (CS%answer_date <= 20240330) then
+ ! KRa/b aren't guaranteed to be unique and update of tr_flux_conv(:, j/j+1, :) means this
+ ! loop must be serial in both j and k. i can be paralellised.
+ do concurrent (i=is:ie) DO_LOCALITY(local(j, k, kLb, kRb, kLa, wt_b, wt_a, kRa))
+ do J=js-1,je ; if (G%mask2dCv(i,J) > 0.0) then
+ do k=1,nPv(i,J)
+ kLb = k0b_Lv(i,k,J) ; kRb = k0b_Rv(i,k,J)
+ if (deep_wt_Lv(I,k,J) >= 1.0) then
+ tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,J,k)
+ else
+ kLa = k0a_Lv(i,k,J)
+ wt_b = deep_wt_Lv(I,k,J) ; wt_a = 1.0 - wt_b
+ tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k))
+ tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k))
+ endif
+ if (deep_wt_Rv(I,k,J) >= 1.0) then
+ tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,J,k)
+ else
+ kRa = k0a_Rv(i,k,J)
+ wt_b = deep_wt_Rv(I,k,J) ; wt_a = 1.0 - wt_b
+ tr_flux_conv(i,j+1,kRa) = tr_flux_conv(i,j+1,kRa) + &
+ (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k))
+ tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + &
+ (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k))
+ endif
+ enddo
+ endif ; enddo
+ enddo
+ else
+ ! Update of tr_flux_N/S can be done independently so both i and j can be parallelised.
+ do concurrent (J=js-1:je, i=is:ie, G%mask2dCv(i,J) > 0.0) DO_LOCALITY(local(k, kLb, kRb, kLa, wt_b, wt_a, kRa))
do k=1,nPv(i,J)
- kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k)
- if (deep_wt_Lv(J)%p(i,k) >= 1.0) then
+ kLb = k0b_Lv(i,k,J) ; kRb = k0b_Rv(i,k,J)
+ if (deep_wt_Lv(I,k,J) >= 1.0) then
tr_flux_N(i,j,kLb) = tr_flux_N(i,j,kLb) + Tr_flux_3d(i,J,k)
else
- kLa = k0a_Lv(J)%p(i,k)
- wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b
+ kLa = k0a_Lv(i,k,J)
+ wt_b = deep_wt_Lv(I,k,J) ; wt_a = 1.0 - wt_b
tr_flux_N(i,j,kLa) = tr_flux_N(i,j,kLa) + (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k))
tr_flux_N(i,j,kLb) = tr_flux_N(i,j,kLb) + (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k))
endif
- if (deep_wt_Rv(J)%p(i,k) >= 1.0) then
+ if (deep_wt_Rv(I,k,J) >= 1.0) then
tr_flux_S(i,j+1,kRb) = tr_flux_S(i,j+1,kRb) + Tr_flux_3d(i,J,k)
else
- kRa = k0a_Rv(J)%p(i,k)
- wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b
+ kRa = k0a_Rv(i,k,J)
+ wt_b = deep_wt_Rv(I,k,J) ; wt_a = 1.0 - wt_b
tr_flux_S(i,j+1,kRa) = tr_flux_S(i,j+1,kRa) + (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k))
tr_flux_S(i,j+1,kRb) = tr_flux_S(i,j+1,kRb) + (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k))
endif
enddo
- endif
- endif ; enddo ; enddo
+ enddo
+ endif
if (CS%answer_date >= 20240331) then
- !$OMP parallel do default(shared)
- do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie
+ do concurrent (k=1:PEmax_kRho, j=js:je, i=is:ie)
tr_flux_conv(i,j,k) = ((tr_flux_W(i,j,k) - tr_flux_E(i,j,k)) + &
(tr_flux_S(i,j,k) - tr_flux_N(i,j,k)))
- enddo ; enddo ; enddo
+ enddo
endif
- !$OMP parallel do default(shared)
- do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie
- if ((G%mask2dT(i,j) > 0.0) .and. (h(i,j,k) > 0.0)) then
- Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / (h(i,j,k)*G%areaT(i,j))
- endif
- enddo ; enddo ; enddo
+ do concurrent (k=1:PEmax_kRho, j=js:je, i=is:ie, (G%mask2dT(i,j) > 0.0) .and. (h(i,j,k) > 0.0))
+ Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / (h(i,j,k)*G%areaT(i,j))
+ enddo
! Do user controlled underflow of the tracer concentrations.
if (Tr(m)%conc_underflow > 0.0) then
+ !$omp target update from(Tr(m)%t)
!$OMP parallel do default(shared)
do k=1,nz ; do j=js,je ; do i=is,ie
if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0
enddo ; enddo ; enddo
+ !$omp target update to(Tr(m)%t)
endif
enddo ! Loop over tracers
enddo ! Loop over iterations
- do j=js,je
- deallocate(deep_wt_Lu(j)%p) ; deallocate(deep_wt_Ru(j)%p)
- deallocate(Hp_Lu(j)%p) ; deallocate(Hp_Ru(j)%p)
- deallocate(k0a_Lu(j)%p) ; deallocate(k0a_Ru(j)%p)
- deallocate(k0b_Lu(j)%p) ; deallocate(k0b_Ru(j)%p)
- enddo
+ !$omp target exit data map(release: Tr_flux_3d, Tr_adj_vert_L, Tr_adj_vert_R, tr_flux_N, &
+ !$omp tr_flux_S, tr_flux_E, tr_flux_W, tr_flux_conv, nPv, nPu, max_kRho, rho_srt, num_srt, &
+ !$omp max_srt)
- do J=js-1,je
- deallocate(deep_wt_Lv(J)%p) ; deallocate(deep_wt_Rv(J)%p)
- deallocate(Hp_Lv(J)%p) ; deallocate(Hp_Rv(J)%p)
- deallocate(k0a_Lv(J)%p) ; deallocate(k0a_Rv(J)%p)
- deallocate(k0b_Lv(J)%p) ; deallocate(k0b_Rv(J)%p)
- enddo
+ !$omp target exit data map(release: deep_wt_Lu, deep_wt_Ru, hP_Lu, hP_Ru, k0a_Lu, k0a_Ru, &
+ !$omp k0b_Lu, k0b_Ru)
+
+ !$omp target exit data map(release: deep_wt_Lv, deep_wt_Rv, hP_Lv, hP_Rv, k0a_Lv, k0a_Rv, &
+ !$Omp k0b_Lv, k0b_Rv)
end subroutine tracer_epipycnal_ML_diff
@@ -1716,12 +1757,11 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic
"along-isopycnal mixed layer to interior mixing code, while higher values use "//&
"mathematically equivalent expressions that recover rotational symmetry "//&
"when DIFFUSE_ML_TO_INTERIOR is true.", &
- default=20240101, do_not_log=.not.CS%Diffuse_ML_interior)
- !### Change the default later to default_answer_date.
+ default=default_answer_date, do_not_log=.not.CS%Diffuse_ML_interior)
call get_param(param_file, mdl, "HOR_DIFF_LIMIT_BUG", CS%limit_bug, &
"If true and the answer date is 20240330 or below, use a rotational symmetry "//&
"breaking bug when limiting the tracer properties in tracer_epipycnal_ML_diff.", &
- default=.true., do_not_log=((.not.CS%Diffuse_ML_interior).or.(CS%answer_date>=20240331)))
+ default=.false., do_not_log=((.not.CS%Diffuse_ML_interior).or.(CS%answer_date>=20240331)))
CS%ML_KhTR_scale = 1.0
if (CS%Diffuse_ML_interior) then
call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, &
diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90
index 9c69a06c7c..c7d0d4a255 100644
--- a/src/tracer/MOM_tracer_registry.F90
+++ b/src/tracer/MOM_tracer_registry.F90
@@ -1,11 +1,13 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains subroutines that handle registration of tracers
!! and related subroutines. The primary subroutine, register_tracer, is
!! called to indicate the tracers advected and diffused.
!! It also makes public the types defined in MOM_tracer_types.
module MOM_tracer_registry
-! This file is part of MOM6. See LICENSE.md for the license.
-
! use MOM_diag_mediator, only : diag_ctrl
use MOM_coms, only : reproducing_sum
use MOM_debugging, only : hchksum
@@ -141,7 +143,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit
if (.not. associated(Reg)) call tracer_registry_init(param_file, Reg)
if (Reg%ntr>=MAX_FIELDS_) then
- write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for &
+ write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for &
&all the tracers being registered via register_tracer.")') Reg%ntr+1
call MOM_error(FATAL,"MOM register_tracer: "//mesg)
endif
@@ -235,7 +237,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit
if (present(diag_form)) Tr%diag_form = diag_form
Tr%advect_scheme = -1
- if(present(advect_scheme)) Tr%advect_scheme = advect_scheme
+ if (present(advect_scheme)) Tr%advect_scheme = advect_scheme
Tr%t => tr_ptr
@@ -715,7 +717,7 @@ subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt)
integer :: i, j, k, is, ie, js, je, nz, m
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
- Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval
+ Idt = 0. ; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval
! Tendency diagnostics need to be posted on the grid from the last call to this routine
call diag_save_grids(diag)
@@ -797,7 +799,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag)
enddo
exit
endif
- endif; enddo
+ endif ; enddo
do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then
Tr => Reg%Tr(m)
@@ -980,9 +982,9 @@ subroutine tracer_registry_init(param_file, Reg)
init_calls = init_calls + 1
if (init_calls > 1) then
- write(mesg,'("tracer_registry_init called ",I3, &
+ write(mesg,'("tracer_registry_init called ",I0, &
&" times with different registry pointers.")') init_calls
- if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer"//mesg)
+ if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer "//mesg)
endif
end subroutine tracer_registry_init
diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90
index 5bc7c7eda3..730a453695 100644
--- a/src/tracer/MOM_tracer_types.F90
+++ b/src/tracer/MOM_tracer_types.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the tracer_type and tracer_registry_type
module MOM_tracer_types
diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90
index 474fcb0c23..e0ab347ea5 100644
--- a/src/tracer/RGC_tracer.F90
+++ b/src/tracer/RGC_tracer.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This module contains the routines used to set up a
!! dynamically passive tracer.
!! Set up and use passive tracers requires the following:
@@ -11,8 +15,6 @@
module RGC_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl
use MOM_error_handler, only : MOM_error, FATAL, WARNING
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
@@ -119,8 +121,7 @@ function register_RGC_tracer(G, GV, param_file, CS, tr_Reg, restart_CS)
endif
do m=1,NTR
- if (m < 10) then ; write(name,'("tr_RGC",I1.1)') m
- else ; write(name,'("tr_RGC",I2.2)') m ; endif
+ write(name,'("tr_RGC",I0)') m
write(longname,'("Concentration of RGC Tracer ",I2.2)') m
CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl)
@@ -296,9 +297,9 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV,
if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then
do m=1,NTR
- do k=1,nz ;do j=js,je ; do i=is,ie
+ do k=1,nz ; do j=js,je ; do i=is,ie
h_work(i,j,k) = h_old(i,j,k)
- enddo ; enddo ; enddo;
+ enddo ; enddo ; enddo
call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, &
evap_CFL_limit, minimum_forcing_depth)
diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90
index dbf9180948..7a20967777 100644
--- a/src/tracer/advection_test_tracer.F90
+++ b/src/tracer/advection_test_tracer.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This tracer package is used to test advection schemes
module advection_test_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux
use MOM_diag_mediator, only : diag_ctrl
@@ -131,8 +133,7 @@ function register_advection_test_tracer(G, GV, param_file, CS, tr_Reg, restart_C
allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0)
do m=1,NTR
- if (m < 10) then ; write(name,'("tr",I1.1)') m
- else ; write(name,'("tr",I2.2)') m ; endif
+ write(name,'("tr",I0)') m
write(longname,'("Concentration of Tracer ",I2.2)') m
CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl)
if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1"
diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90
index 0698d7f9cc..6dd5127d94 100644
--- a/src/tracer/boundary_impulse_tracer.F90
+++ b/src/tracer/boundary_impulse_tracer.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Implements a boundary impulse response tracer to calculate Green's functions
module boundary_impulse_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux
use MOM_diag_mediator, only : diag_ctrl
diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90
index c1146e19f9..7cbeebd38f 100644
--- a/src/tracer/dye_example.F90
+++ b/src/tracer/dye_example.F90
@@ -1,11 +1,13 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A tracer package for using dyes to diagnose regional flows.
module regional_dyes
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux
-use MOM_diag_mediator, only : diag_ctrl
+use MOM_diag_mediator, only : diag_ctrl, post_data, register_diag_field
use MOM_error_handler, only : MOM_error, FATAL, WARNING
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
use MOM_forcing_type, only : forcing
@@ -59,6 +61,8 @@ module regional_dyes
integer, allocatable, dimension(:) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the
!! surface tracer concentrations are to be provided to the coupler.
+ integer, allocatable, dimension(:) :: id_tr_dia_diff !< Diagnostic IDs for vertical tracer fluxes (positive up)
+
type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to
!! regulate the timing of diagnostic output.
type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure
@@ -116,6 +120,8 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS)
CS%dye_source_maxdepth(CS%ntr))
allocate(CS%ind_tr(CS%ntr))
allocate(CS%tr_desc(CS%ntr))
+ allocate(CS%id_tr_dia_diff(CS%ntr))
+ CS%id_tr_dia_diff(:) = -1
CS%dye_source_minlon(:) = -1.e30
call get_param(param_file, mdl, "DYE_SOURCE_MINLON", CS%dye_source_minlon, &
@@ -204,12 +210,13 @@ end function register_dye_tracer
!> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:)
!! and it sets up the tracer output.
-subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp, tv)
+subroutine initialize_dye_tracer(restart, day, G, GV, US, h, diag, OBC, CS, sponge_CSp, tv)
logical, intent(in) :: restart !< .true. if the fields have already been
!! read from a restart file.
type(time_type), target, intent(in) :: day !< Time of the start of the run.
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
+ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]
type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output.
type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies
@@ -222,6 +229,7 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C
type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables
! Local variables
+ character(len=64) :: var_name, longname
real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m]
real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m]
real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m]
@@ -232,6 +240,14 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C
CS%diag => diag
+ ! Register vertical flux diagnostic
+ do m = 1, CS%ntr
+ write(var_name,'(A,I3.3,A)') "dye",m,"_dia_diff"
+ write(longname,'(A,I3.3,A)') "Vertical diffusive flux of dye ",m," (positive up)"
+ CS%id_tr_dia_diff(m) = register_diag_field('ocean_model', trim(var_name), &
+ diag%axesTi, day, trim(longname), 'conc H s-1', conversion=GV%H_to_MKS*US%s_to_T)
+ enddo
+
! Establish location of source
do j=G%jsc,G%jec
call thickness_to_dz(h, tv, dz, j, G, GV)
@@ -292,9 +308,12 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US
! Local variables
real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2]
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: vert_flux ! Vertical tracer flux positive upward
+ !! [conc H T-1 ~> conc m s-1]
real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m]
real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m]
real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m]
+ real :: Idt ! Inverse of timestep [T-1 ~> s-1]
integer :: i, j, k, is, ie, js, je, nz, m
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
@@ -302,6 +321,8 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US
if (.not.associated(CS)) return
if (CS%ntr < 1) return
+ Idt = 1.0 / dt
+
if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then
do m=1,CS%ntr
do k=1,nz ; do j=js,je ; do i=is,ie
@@ -310,10 +331,34 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US
call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, &
evap_CFL_limit, minimum_forcing_depth)
call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV)
+
+ ! Calculate net vertical flux from entrainment
+ ! Net flux = upward component - downward component
+ ! Upward (from below): eb(k) * tr(k+1), Downward (from above): ea(k+1) * tr(k)
+ do K=2,nz ; do j=js,je ; do i=is,ie
+ vert_flux(i,j,K) = (eb(i,j,k-1) * CS%tr(i,j,k,m) - ea(i,j,k) * CS%tr(i,j,k-1,m)) * Idt
+ enddo ; enddo ; enddo
+ do j=js,je ; do i=is,ie ; vert_flux(i,j,1) = 0.0 ; vert_flux(i,j,nz+1) = 0.0 ; enddo ; enddo
+
+ ! Post diagnostic
+ if (CS%id_tr_dia_diff(m) > 0) &
+ call post_data(CS%id_tr_dia_diff(m), vert_flux, CS%diag)
enddo
else
do m=1,CS%ntr
call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV)
+
+ ! Calculate net vertical flux from entrainment
+ ! Net flux = upward component - downward component
+ ! Upward (from below): eb(k) * tr(k+1), Downward (from above): ea(k+1) * tr(k)
+ do K=2,nz ; do j=js,je ; do i=is,ie
+ vert_flux(i,j,K) = (eb(i,j,k-1) * CS%tr(i,j,k,m) - ea(i,j,k) * CS%tr(i,j,k-1,m)) * Idt
+ enddo ; enddo ; enddo
+ do j=js,je ; do i=is,ie ; vert_flux(i,j,1) = 0.0 ; vert_flux(i,j,nz+1) = 0.0 ; enddo ; enddo
+
+ ! Post diagnostic
+ if (CS%id_tr_dia_diff(m) > 0) &
+ call post_data(CS%id_tr_dia_diff(m), vert_flux, CS%diag)
enddo
endif
diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90
index 4490c711f8..881d18eac0 100644
--- a/src/tracer/dyed_obc_tracer.F90
+++ b/src/tracer/dyed_obc_tracer.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> This tracer package dyes flow through open boundaries
module dyed_obc_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coupler_types, only : atmos_ocn_coupler_flux
use MOM_diag_mediator, only : diag_ctrl
use MOM_error_handler, only : MOM_error, FATAL, WARNING
@@ -20,7 +22,6 @@ module dyed_obc_tracer
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : surface
use MOM_verticalGrid, only : verticalGrid_type
-use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer
use MOM_tracer_registry, only : tracer_type
use MOM_tracer_registry, only : tracer_name_lookup
use MOM_tracer_advect_schemes, only : set_tracer_advect_scheme, TracerAdvectionSchemeDoc
@@ -93,7 +94,7 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS)
call log_version(param_file, mdl, version, "")
call get_param(param_file, mdl, "NUM_DYED_TRACERS", CS%ntr, &
"The number of dyed_obc tracers in this run. Each tracer "//&
- "should have a separate boundary segment."//&
+ "should have a separate boundary segment. "//&
"If not present, use NUM_DYE_TRACERS.", default=-1)
if (CS%ntr == -1) then
!for backward compatibility
diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90
index 147c48eebd..1543a93094 100644
--- a/src/tracer/ideal_age_example.F90
+++ b/src/tracer/ideal_age_example.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A tracer package of ideal age tracers
module ideal_age_example
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux
use MOM_diag_mediator, only : diag_ctrl
@@ -16,7 +18,7 @@ module ideal_age_example
use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS
use MOM_spatial_means, only : global_mass_int_EFP
use MOM_sponge, only : set_up_sponge_field, sponge_CS
-use MOM_time_manager, only : time_type, time_type_to_real
+use MOM_time_manager, only : time_type, time_to_real
use MOM_tracer_registry, only : register_tracer, tracer_registry_type
use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut
use MOM_tracer_Z_init, only : tracer_Z_init
@@ -177,7 +179,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS)
CS%BL_residence_num = 0
if (do_BL_residence) then
- CS%ntr = CS%ntr + 1 ; m = CS%ntr; CS%BL_residence_num = CS%ntr
+ CS%ntr = CS%ntr + 1 ; m = CS%ntr ; CS%BL_residence_num = CS%ntr
CS%tr_desc(m) = var_desc("BL_age", "yr", "BL Residence Time Tracer", caller=mdl)
CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0
CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0
@@ -371,7 +373,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G,
Isecs_per_year = 1.0 / (365.0*86400.0*US%s_to_T)
! Set the surface value of tracer 1 to increase exponentially
! with a 30 year time scale.
- year = US%s_to_T*time_type_to_real(CS%Time) * Isecs_per_year
+ year = time_to_real(CS%Time, scale=US%s_to_T) * Isecs_per_year
do m=1,CS%ntr
diff --git a/src/tracer/nw2_tracers.F90 b/src/tracer/nw2_tracers.F90
index f93c6d4c69..851cd96bc6 100644
--- a/src/tracer/nw2_tracers.F90
+++ b/src/tracer/nw2_tracers.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Ideal tracers designed to help diagnose a tracer diffusivity tensor in NeverWorld2
module nw2_tracers
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl
use MOM_error_handler, only : MOM_error, FATAL, WARNING
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
@@ -12,7 +14,7 @@ module nw2_tracers
use MOM_interface_heights, only : thickness_to_dz
use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc
use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS
-use MOM_time_manager, only : time_type, time_type_to_real
+use MOM_time_manager, only : time_type
use MOM_tracer_registry, only : register_tracer, tracer_registry_type
use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut
use MOM_unit_scaling, only : unit_scale_type
diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90
index 1260711347..9f6e263974 100644
--- a/src/tracer/oil_tracer.F90
+++ b/src/tracer/oil_tracer.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A tracer package to mimic dissolved oil.
module oil_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux
use MOM_diag_mediator, only : diag_ctrl
@@ -494,7 +496,7 @@ end subroutine oil_tracer_end
!!
!! This tracer package was central to the simulations used by Adcroft et al.,
!! GRL 2010, to prove that the Deepwater Horizon spill was an important regional
-!! event, with implications for dissolved oxygen levels in the Gulf of Mexico,
-!! but not one that would directly impact the East Coast of the U.S.
+!! event, with implications for dissolved oxygen levels in certains regions,
+!! see above reference for details.
end module oil_tracer
diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90
index b737dba5b7..4be887940a 100644
--- a/src/tracer/pseudo_salt_tracer.F90
+++ b/src/tracer/pseudo_salt_tracer.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A tracer package that mimics salinity
module pseudo_salt_tracer
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_debugging, only : hchksum
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90
index ff2812b8ee..14011d16b9 100644
--- a/src/tracer/tracer_example.F90
+++ b/src/tracer/tracer_example.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A sample tracer package that has striped initial conditions
module USER_tracer_example
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : EFP_type
use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux
use MOM_diag_mediator, only : diag_ctrl
@@ -116,8 +118,7 @@ function USER_register_tracer_example(G, GV, US, param_file, CS, tr_Reg, restart
allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0)
do m=1,NTR
- if (m < 10) then ; write(name,'("tr",I1.1)') m
- else ; write(name,'("tr",I2.2)') m ; endif
+ write(name,'("tr",I0)') m
write(longname,'("Concentration of Tracer ",I2.2)') m
CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl)
diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90
index 67381bfdc5..34b128522e 100644
--- a/src/user/BFB_initialization.F90
+++ b/src/user/BFB_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization of the boundary-forced-basing configuration
module BFB_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_get_input, only : directories
diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90
index fcbd66e1d8..2472c1182c 100644
--- a/src/user/BFB_surface_forcing.F90
+++ b/src/user/BFB_surface_forcing.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Surface forcing for the boundary-forced-basin (BFB) configuration
module BFB_surface_forcing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data, query_averaging_enabled
use MOM_diag_mediator, only : register_diag_field, diag_ctrl
use MOM_domains, only : pass_var, pass_vector, AGRID
@@ -205,7 +207,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS)
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "LFR_SLAT", CS%lfrslat, &
diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90
index 3903290212..96cb779eb5 100644
--- a/src/user/DOME2d_initialization.F90
+++ b/src/user/DOME2d_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization of the 2D DOME experiment with density water initialized on a coastal shelf.
module DOME2d_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL
diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90
index e608dbd1c2..3603555856 100644
--- a/src/user/DOME_initialization.F90
+++ b/src/user/DOME_initialization.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the model for the "DOME" experiment.
!! DOME = Dynamics of Overflows and Mixing Experiment
module DOME_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe
@@ -206,7 +208,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp)
"The largest damping rate in the DOME sponges.", &
default=10.0, units="day-1", scale=1.0/(86400.0*US%s_to_T))
call get_param(PF, mdl, "DOME_SPONGE_WIDTH", sponge_width, &
- "The width of the the DOME sponges.", &
+ "The width of the DOME sponges.", &
default=200.0, units="km", scale=1.0e3*US%m_to_L)
! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 wherever
@@ -259,8 +261,8 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp)
! The remaining calls to set_up_sponge_field can be in any order.
if ( associated(tv%T) ) then
temp(:,:,:) = 0.0
- call MOM_error(FATAL,"DOME_initialize_sponges is not set up for use with"//&
- " a temperatures defined.")
+ call MOM_error(FATAL, "DOME_initialize_sponges is not set up for use with "//&
+ "temperatures defined.")
! This should use the target values of T in temp.
call set_up_sponge_field(temp, tv%T, G, GV, nz, CSp)
! This should use the target values of S in temp.
@@ -504,8 +506,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg)
! All tracers but the first have 0 concentration in their inflows. As 0 is the
! default value for the inflow concentrations, the following calls are unnecessary.
do m=2,tr_Reg%ntr
- if (m < 10) then ; write(name,'("tr_D",I1.1)') m
- else ; write(name,'("tr_D",I2.2)') m ; endif
+ write(name,'("tr_D",I0)') m
call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name)
call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_scalar=0.0)
enddo
diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90
index 4bf7931856..d0697a2e49 100644
--- a/src/user/ISOMIP_initialization.F90
+++ b/src/user/ISOMIP_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the ISOMIP test case.
module ISOMIP_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge
use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge
use MOM_dyn_horgrid, only : dyn_horgrid_type
@@ -370,7 +372,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U
do j=js,je ; do i=is,ie
xi0 = 0.0
do k = 1,nz
- !T0(k) = T_Ref; S0(k) = S_Ref
+ !T0(k) = T_Ref ; S0(k) = S_Ref
xi1 = xi0 + 0.5 * h(i,j,k)
S0(k) = S_sur - dS_dz * xi1
T0(k) = T_sur - dT_dz * xi1
@@ -426,7 +428,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U
end select
! for debugging
- !i=G%iec; j=G%jec
+ !i = G%iec ; j = G%jec
!do k = 1,nz
! call calculate_density(T(i,j,k), S(i,j,k),0.0,rho_tmp,eqn_of_state, scale=US%kg_m3_to_R)
! write(mesg,*) 'k,h,T,S,rho,Rlay',k,US%Z_to_m*h(i,j,k),US%C_to_degC*T(i,j,k),US%S_to_ppt*S(i,j,k),rho_tmp,GV%Rlay(k)
@@ -435,9 +437,9 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U
end subroutine ISOMIP_initialize_temperature_salinity
-!> Sets up the the inverse restoration time (Idamp), and
-! the values towards which the interface heights and an arbitrary
-! number of tracers should be restored within each sponge.
+!> Sets up the inverse restoration time (Idamp), and
+!! the values towards which the interface heights and an arbitrary
+!! number of tracers should be restored within each sponge.
subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, ACSp)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
@@ -623,7 +625,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp,
enddo ; enddo
! for debugging
- !i=G%iec; j=G%jec
+ !i = G%iec ; j = G%jec
!do k = 1,nz
! call calculate_density(T(i,j,k), S(i,j,k), 0.0, rho_tmp, tv%eqn_of_state, scale=US%kg_m3_to_R)
! write(mesg,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k)
@@ -675,7 +677,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp,
call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain, scale=US%ppt_to_S)
! for debugging
- !i=G%iec; j=G%jec
+ !i = G%iec ; j = G%jec
!do k = 1,nz
! call calculate_density(T(i,j,k), S(i,j,k), 0.0, rho_tmp, tv%eqn_of_state, scale=US%kg_m3_to_R)
! write(mesg,*) 'Sponge - k,eta,T,S,rho,Rlay',k,eta(i,j,k),T(i,j,k),&
diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90
index d9d46f7d6e..9e83849a2c 100644
--- a/src/user/Idealized_Hurricane.F90
+++ b/src/user/Idealized_Hurricane.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Forcing for the idealized hurricane and SCM_idealized_hurricane examples.
module Idealized_hurricane
-! This file is part of MOM6. See LICENSE.md for the license.
-
! History
!--------
! November 2014: Origination.
@@ -22,7 +24,7 @@ module Idealized_hurricane
use MOM_forcing_type, only : allocate_mech_forcing
use MOM_grid, only : ocean_grid_type
use MOM_safe_alloc, only : safe_alloc_ptr
-use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real
+use MOM_time_manager, only : time_type, operator(+), operator(/), time_to_real
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : thermo_var_ptrs, surface
use MOM_verticalGrid, only : verticalGrid_type
@@ -226,7 +228,7 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS)
default=6.88, units="degrees")
call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_TR_SPEED", CS%P1_speed, &
"The translation speed dependence of the angle difference between the "//&
- "translation direction and the inflow direction"//&
+ "translation direction and the inflow direction "//&
"for the parametric idealized hurricane.", &
default=-9.60, units="degrees s m-1", scale=US%L_T_to_m_s)
@@ -242,7 +244,7 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS)
"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=.false., do_not_log=.not.CS%SCM_mode)
if (.not.CS%SCM_mode) CS%edge_taper_bug = .false.
call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%dy_from_center, &
"Y distance of station used in the SCM idealized hurricane wind profile.", &
@@ -308,7 +310,7 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS)
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.)
call get_param(param_file, mdl, "GUST_CONST", CS%gustiness, &
@@ -371,9 +373,9 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS)
endif
!> Compute storm center location
- XC = CS%Hurr_cen_X0 + (time_type_to_real(day)*US%s_to_T * CS%hurr_translation_spd * &
+ XC = CS%Hurr_cen_X0 + (time_to_real(day, scale=US%s_to_T) * CS%hurr_translation_spd * &
cos(CS%hurr_translation_dir))
- YC = CS%Hurr_cen_Y0 + (time_type_to_real(day)*US%s_to_T * CS%hurr_translation_spd * &
+ YC = CS%Hurr_cen_Y0 + (time_to_real(day, scale=US%s_to_T) * CS%hurr_translation_spd * &
sin(CS%hurr_translation_dir))
if (CS%BR_Bench) then
diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90
index a18c5bd136..36ccf6115e 100644
--- a/src/user/Kelvin_initialization.F90
+++ b/src/user/Kelvin_initialization.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the model for the Kelvin wave experiment.
!!
!! Kelvin = coastally-trapped Kelvin waves from the ROMS examples.
@@ -5,20 +9,17 @@
!! radiate out at the east.
module Kelvin_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_grid, only : ocean_grid_type
use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE
-use MOM_open_boundary, only : OBC_segment_type, register_OBC
-use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E
-use MOM_open_boundary, only : OBC_DIRECTION_S, OBC_DIRECTION_W
+use MOM_open_boundary, only : OBC_segment_type, register_OBC, rotate_OBC_segment_direction
+use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E, OBC_DIRECTION_S, OBC_DIRECTION_W
use MOM_open_boundary, only : OBC_registry_type
use MOM_unit_scaling, only : unit_scale_type
use MOM_verticalGrid, only : verticalGrid_type
-use MOM_time_manager, only : time_type, time_type_to_real
+use MOM_time_manager, only : time_type, time_to_real
implicit none ; private
@@ -48,6 +49,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 +59,15 @@ module Kelvin_initialization
contains
!> Add Kelvin wave to OBC registry.
-function register_Kelvin_OBC(param_file, CS, US, OBC_Reg)
+logical function register_Kelvin_OBC(param_file, CS, US, OBC_Reg)
type(param_file_type), intent(in) :: param_file !< parameter file.
type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure.
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry.
! Local variables
- logical :: register_Kelvin_OBC
+ logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
+ ! recreate the bugs, or if false bugs are only used if actively selected.
character(len=40) :: mdl = "register_Kelvin_OBC" !< This subroutine's name.
character(len=32) :: casename = "Kelvin wave" !< This case's name.
character(len=200) :: config
@@ -121,8 +125,12 @@ function register_Kelvin_OBC(param_file, CS, US, OBC_Reg)
"The timescale with which the inflowing open boundary velocities are nudged toward "//&
"their intended values with the Kelvin wave test case, or a negative value to keep "//&
"the value that is set when the OBC segments are initialized.", &
- units="s", default=1.0/(0.3*86400.), scale=US%s_to_T)
- !### Change the default nudging timescale to -1. or another value?
+ units="s", default=-1.0, scale=US%s_to_T)
+ call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
+ default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
+ call get_param(param_file, mdl, "KELVIN_SET_OBC_INDEXING_BUGS", CS%indexing_bugs, &
+ "If true, retain several horizontal indexing bugs that were in the original "//&
+ "version of Kelvin_set_OBC_data.", default=enable_bugs)
! Register the Kelvin open boundary.
call register_OBC(casename, param_file, OBC_Reg)
@@ -211,17 +219,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
@@ -232,9 +248,14 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time)
if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, 'Kelvin_initialization.F90: '// &
"Kelvin_set_OBC_data() is only set to work with Cartesian axis units.")
- time_sec = US%s_to_T*time_type_to_real(Time)
+ time_sec = time_to_real(Time, scale=US%s_to_T)
PI = 4.0*atan(1.0)
+ 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 +266,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,109 +277,164 @@ 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
- ! Baroclinic, not rotated yet (and apparently not working as intended yet).
+ ! Baroclinic, not rotated yet
segment%SSH(I,j) = 0.0
segment%normal_vel_bt(I,j) = 0.0
+ ! Use inside bathymetry
+ if (segment%direction == OBC_DIRECTION_W) then
+ depth_tot_vel = depth_tot(i+1,j)
+ elseif (segment%direction == OBC_DIRECTION_S) then
+ depth_tot_vel = depth_tot(i,j+1)
+ elseif (segment%direction == OBC_DIRECTION_E) then
+ depth_tot_vel = depth_tot(i,j)
+ elseif (segment%direction == OBC_DIRECTION_N) then
+ depth_tot_vel = depth_tot(i,j)
+ endif
! I suspect that the velocities in both of the following loops should instead be
- ! normal_vel(I,j,k) = CS%inflow_amp * CS%u_struct(k) * exp(-lambda * y) * cos(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
+ if (associated(segment%h_Reg)) then
+ if (allocated(segment%h_Reg%h)) then
+ do k=1,nz
+ segment%h_Reg%h(I,j,k) = depth_tot_vel / nz + &
+ ((CS%mode * PI) * CS%inflow_amp / (N0 * nz)) * &
+ cos(((PI * k) * CS%mode) / nz) * &
+ exp(-lambda * y) * cos_wt
+ enddo
+ endif
+ endif
endif
enddo ; enddo
- if (allocated(segment%tangential_vel)) then
- do J=JsdB+1,JedB-1 ; do I=IsdB,IedB
- x1 = 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 +443,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_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90
index 363a41f72f..dde4a2dd39 100644
--- a/src/user/MOM_controlled_forcing.F90
+++ b/src/user/MOM_controlled_forcing.F90
@@ -1,3 +1,7 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Use control-theory to adjust the surface heat flux and precipitation.
!!
!! Adjustments are based on the time-mean or periodically (seasonally) varying
@@ -6,8 +10,6 @@
!! The techniques behind this are described in Hallberg and Adcroft (2018, in prep.).
module MOM_controlled_forcing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data, query_averaging_enabled, enable_averages, disable_averaging
use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr
use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All
@@ -296,7 +298,7 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec
m_u2 = periodic_int(m_st - 3.0, CS%num_cycle)
m_u3 = periodic_int(m_st - 2.0, CS%num_cycle)
- ! These loops restore the units of the CS%avg variables to [degC] or [ppt]
+ ! These loops restore the units of the CS%avg variables to [C ~> degC] or [S ~> ppt]
if (CS%avg_time(m_u1) > 0.0) then
do j=js,je ; do i=is,ie
CS%avg_SST_anom(i,j,m_u1) = CS%avg_SST_anom(i,j,m_u1) / CS%avg_time(m_u1)
@@ -485,8 +487,7 @@ subroutine register_ctrl_forcing_restarts(G, US, param_file, CS, restart_CS)
allocate(CS%avg_SSS_anom(isd:ied,jsd:jed,CS%num_cycle), source=0.0)
allocate(CS%avg_SSS(isd:ied,jsd:jed,CS%num_cycle), source=0.0)
- write (period_str, '(i8)') CS%num_cycle
- period_str = trim('p ')//trim(adjustl(period_str))
+ write (period_str, '("p ",I0)') CS%num_cycle
call register_restart_field(CS%heat_cyc, "Ctrl_heat_cycle", .false., restart_CS, &
longname="Cyclical Control Heating", &
diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90
index dc34768182..23f4c8cb7d 100644
--- a/src/user/MOM_wave_interface.F90
+++ b/src/user/MOM_wave_interface.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Interface for surface waves
module MOM_wave_interface
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_data_override, only : data_override_init, data_override
use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc
use MOM_diag_mediator, only : diag_ctrl
@@ -16,6 +18,7 @@ module MOM_wave_interface
use MOM_io, only : file_exists, get_var_sizes, read_variable
use MOM_io, only : vardesc, var_desc
use MOM_safe_alloc, only : safe_alloc_ptr
+use MOM_spatial_means, only : global_area_mean
use MOM_time_manager, only : time_type, operator(+), operator(/)
use MOM_unit_scaling, only : unit_scale_type
use MOM_variables, only : thermo_var_ptrs, surface
@@ -66,6 +69,7 @@ module MOM_wave_interface
logical, public :: Stokes_DDT = .false. !< Developmental:
!! True if Stokes d/dt is used
logical, public :: Passive_Stokes_DDT = .false. !< Keeps Stokes_DDT on, but doesn't affect dynamics
+ logical :: Homogenize_Surfbands !< True to homogenize surface band Stokes drift in the horizontal
real, allocatable, dimension(:,:,:), public :: &
Us_x !< 3d zonal Stokes drift profile [L T-1 ~> m s-1]
@@ -335,8 +339,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag)
"\t >= 20230101 - More robust expressions for Update_Stokes_Drift\n"//&
"\t >= 20230102 - More robust expressions for get_StokesSL_LiFoxKemper\n"//&
"\t >= 20230103 - More robust expressions for ust_2_u10_coare3p5", &
- default=20221231, do_not_log=.not.GV%Boussinesq)
- !### In due course change the default to default=default_answer_date)
+ default=default_answer_date, do_not_log=.not.GV%Boussinesq)
if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701)
! Langmuir number Options
@@ -354,7 +357,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag)
if (.not.use_waves) return
else
CS%WaveMethod = NULL_WaveMethod
- end if
+ endif
! Wave modified physics
! Presently these are all in research mode
@@ -442,6 +445,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag)
"A layer thickness below which the cell-center Stokes drift is used instead of "//&
"the cell average. This is only used if WAVE_INTERFACE_ANSWER_DATE < 20230101.", &
units="m", default=0.1, scale=US%m_to_Z, do_not_log=(CS%answer_date>=20230101))
+ call get_param(param_file, mdl, "HOMOGENIZE_SURFBANDS", CS%Homogenize_Surfbands, &
+ "A logical which causes the code to horizontally homogenize the surface band "//&
+ "Stokes drift, which is needed in column mode to avoid round-off differences. "//&
+ "At present it only works with DATAOVERRIDE, and is not coded for COUPLER.",&
+ default=.false.)
call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, &
"Choice of SURFACE_BANDS data mode, valid options include: \n"//&
" DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"//&
@@ -449,8 +457,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag)
" INPUT - Testing with fixed values.", default=NULL_STRING)
select case (TRIM(TMPSTRING2))
case (NULL_STRING)! Default
- call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//&
- " but no SURFBAND_SOURCE.")
+ call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS "//&
+ "but no SURFBAND_SOURCE.")
case (DATAOVR_STRING)! Using Data Override
CS%DataSource = DATAOVR
call get_param(param_file, mdl, "SURFBAND_FILENAME", CS%SurfBandFileName, &
@@ -505,8 +513,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag)
case (DHH85_STRING) !Donelan et al., 1985 spectrum
CS%WaveMethod = DHH85
- call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//&
- " Stokes drift in x-direction.")
+ call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/ "//&
+ "Stokes drift in x-direction.")
call get_param(param_file, mdl, "DHH85_AGE_FP", CS%WaveAgePeakFreq, &
"Choose true to use waveage in peak frequency.", default=.false.)
call get_param(param_file, mdl, "DHH85_AGE", CS%WaveAge, &
@@ -539,8 +547,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag)
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=.false., do_not_log=.not.CS%LA_Misalignment)
call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, &
"A minimum value for all Langmuir numbers that is not physical, "//&
"but is likely only encountered when the wind is very small and "//&
@@ -1073,6 +1080,7 @@ subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS)
character(len=48) :: dim_name(4) ! The names of the dimensions of the variable.
character(len=20) :: varname ! The name of an input variable for data override.
real :: PI ! 3.1415926535... [nondim]
+ real :: avgx, avgy ! The global averages of temp_x and temp_y [L T-1 ~> m s-1]
logical :: wavenumber_exists
integer :: ndims, b, i, j
@@ -1153,6 +1161,14 @@ subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS)
endif
enddo
enddo
+ if (CS%Homogenize_Surfbands) then
+ avgx = global_area_mean(temp_x, G)
+ avgy = global_area_mean(temp_y, G)
+ do j = G%jsd,G%jed ; do i = G%Isd,G%Ied ; if (G%mask2dT(i,j) > 0.0) then
+ temp_y(i,j) = avgy
+ temp_x(i,j) = avgx
+ endif ; enddo ; enddo
+ endif
! Interpolate to u/v grids
do j = G%jsc,G%jec
@@ -1808,7 +1824,7 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS )
! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the
! Lagrangian velocity. This requires the wave acceleration terms to be activated together.
uE_l = 0.5*((u(I-1,j,k)-CS%Us_x(I-1,j,k))*G%mask2dCu(I-1,j) + &
- (u(I,j,k)-CS%Us_x(I-1,j,k))*G%mask2dCu(I,j))
+ (u(I,j,k)-CS%Us_x(I,j,k))*G%mask2dCu(I,j))
uE_r = 0.5*((u(I,j,k)-CS%Us_x(I,j,k))*G%mask2dCu(I,j) + &
(u(I+1,j,k)-CS%Us_x(I+1,j,k))*G%mask2dCu(I+1,j))
vE_l = 0.5*((v(i,J-1,k)-CS%Us_y(i,J-1,k))*G%mask2dCv(i,J-1) + &
@@ -1820,6 +1836,8 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS )
dP_Stokes_r_dz = 0.0
dP_Stokes_l = 0.0
dP_Stokes_r = 0.0
+ dP_lay_Stokes_l=0.0
+ dP_lay_Stokes_r=0.0
do l = 1, CS%numbands
@@ -1865,8 +1883,8 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS )
dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1))
dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1))
dP_Stokes_r_dz = dP_Stokes_r_dz + &
- ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR)
- dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR
+ ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_r*uS0_r+vS0_r*vS0_r)*iFourK*dexp4kzR)
+ dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_r*uS0_r+vS0_r*vS0_r)*dexp4kzR
else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers.
exp_top = exp(TwoK*zi_r(k))
dP_lay_Stokes_r = dP_lay_Stokes_r + &
@@ -1944,6 +1962,8 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS )
dP_Stokes_r_dz = 0.0
dP_Stokes_l = 0.0
dP_Stokes_r = 0.0
+ dP_lay_Stokes_l=0.0
+ dP_lay_Stokes_r=0.0
do l = 1, CS%numbands
@@ -1989,8 +2009,8 @@ subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS )
dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1))
dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1))
dP_Stokes_r_dz = dP_Stokes_r_dz + &
- ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzR)
- dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzR
+ ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_r*uS0_r+vS0_r*vS0_r)*iFourK*dexp4kzR)
+ dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_r*uS0_r+vS0_r*vS0_r)*dexp4kzR
else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers.
exp_top = exp(TwoK*zi_r(k))
dP_lay_Stokes_r = dP_lay_Stokes_r + &
diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90
index ba8263ca1c..c67237a048 100644
--- a/src/user/Neverworld_initialization.F90
+++ b/src/user/Neverworld_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization for the "Neverworld" configuration
module Neverworld_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90
index 4a115031e1..cf4690a24b 100644
--- a/src/user/Phillips_initialization.F90
+++ b/src/user/Phillips_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization for the "Phillips" channel configuration
module Phillips_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_file_parser, only : get_param, log_version, param_file_type
@@ -281,7 +283,7 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read)
end subroutine Phillips_initialize_velocity
-!> Sets up the the inverse restoration time (Idamp), and the values towards which the interface
+!> Sets up the inverse restoration time (Idamp), and the values towards which the interface
!! heights and an arbitrary number of tracers should be restored within each sponge for the Phillips
!! model test case
subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h)
diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90
index 1570cab7d3..de7727ee72 100644
--- a/src/user/RGC_initialization.F90
+++ b/src/user/RGC_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the models sponges for the Rotating Gravity Current (RGC) experiment.
module RGC_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
!***********************************************************************
!* By Elizabeth Yankovsky, May 2018 *
!***********************************************************************
@@ -35,7 +37,7 @@ module RGC_initialization
contains
-!> Sets up the the inverse restoration time, and the values towards which the interface heights,
+!> Sets up the inverse restoration time, and the values towards which the interface heights,
!! velocities and tracers should be restored within the sponges for the RGC test case.
subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, CSp, ACSp)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
@@ -72,7 +74,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
@@ -82,7 +84,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C
is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
- iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB
+ iscB = G%iscB ; iecB = G%iecB ; jscB = G%jscB ; jecB = G%jecB
! The variable min_thickness is unused, and can probably be eliminated.
call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', &
diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90
index 05a223cfb9..ffc7610391 100644
--- a/src/user/Rossby_front_2d_initialization.F90
+++ b/src/user/Rossby_front_2d_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initial conditions for the 2D Rossby front test
module Rossby_front_2d_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_get_input, only : directories
diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90
index def4c59568..708c17567a 100644
--- a/src/user/SCM_CVMix_tests.F90
+++ b/src/user/SCM_CVMix_tests.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initial conditions and forcing for the single column model (SCM) CVMix test set.
module SCM_CVMix_tests
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domains, only : pass_var, pass_vector, TO_ALL
use MOM_error_handler, only : MOM_error, FATAL
use MOM_file_parser, only : get_param, log_version, param_file_type
@@ -183,7 +185,7 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS)
call get_param(param_file, mdl, "RHO_0", CS%Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, &
@@ -251,7 +253,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS)
IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
if (CS%UseHeatFlux) then
- ! Note CVMix test inputs give Heat flux in [Z C T-1 ~> m K/s]
+ ! Note CVMix test inputs give Heat flux in [Z C T-1 ~> m K s-1]
! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying
! by Rho0*Cp
do J=Jsq,Jeq ; do i=is,ie
diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90
index 4a1d6c3d9f..246384bf38 100644
--- a/src/user/adjustment_initialization.F90
+++ b/src/user/adjustment_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the model for the geostrophic adjustment test case.
module adjustment_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_param, log_version, param_file_type
use MOM_get_input, only : directories
@@ -147,14 +149,14 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read
if (front_wave_length /= 0.) then
y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) )
yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width
- yy = min(1.0, yy); yy = max(-1.0, yy)
+ yy = min(1.0, yy) ; yy = max(-1.0, yy)
yy = yy * 2. * acos( 0. )
y_lat = front_wave_amp*sin(y) + front_wave_asym*sin(yy)
else
y_lat = 0.
endif
x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y_lat ) / adjustment_width
- x = min(1.0, x); x = max(-1.0, x)
+ x = min(1.0, x) ; x = max(-1.0, x)
x = x * acos( 0. )
delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) )
do k=2,nz
@@ -166,7 +168,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read
eta1D(k) = max( eta1D(k), -G%max_depth )
eta1D(k) = min( eta1D(k), 0. )
enddo
- eta1D(1) = 0.; eta1D(nz+1) = -G%max_depth
+ eta1D(1) = 0. ; eta1D(nz+1) = -G%max_depth
do k=nz,1,-1
if (eta1D(k) > 0.) then
eta1D(k) = max( eta1D(k+1) + min_thickness, 0. )
@@ -280,14 +282,14 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV,
if (front_wave_length /= 0.) then
y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) )
yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length
- yy = min(1.0, yy); yy = max(-1.0, yy)
+ yy = min(1.0, yy) ; yy = max(-1.0, yy)
yy = yy * 2. * acos( 0. )
y_lat = front_wave_amp*sin(y) + front_wave_asym*sin(yy)
else
y_lat = 0.
endif
x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y_lat ) / adjustment_width
- x = min(1.0, x); x = max(-1.0, x)
+ x = min(1.0, x) ; x = max(-1.0, x)
x = x * acos( 0. )
delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) )
do k=1,nz
diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90
index e2c6182231..f50c103583 100644
--- a/src/user/baroclinic_zone_initialization.F90
+++ b/src/user/baroclinic_zone_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initial conditions for an idealized baroclinic zone
module baroclinic_zone_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_file_parser, only : openParameterBlock, closeParameterBlock
use MOM_grid, only : ocean_grid_type
diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90
index 721b0b33cc..67afd0e6ba 100644
--- a/src/user/basin_builder.F90
+++ b/src/user/basin_builder.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> An idealized topography building system
module basin_builder
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90
index 333f53895e..6685c75305 100644
--- a/src/user/benchmark_initialization.F90
+++ b/src/user/benchmark_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization for the "bench mark" configuration
module benchmark_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90
index 98b5bd4705..26e26d0a44 100644
--- a/src/user/circle_obcs_initialization.F90
+++ b/src/user/circle_obcs_initialization.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the model for the "circle_obcs" experiment which tests
!! Open Boundary Conditions radiating an SSH anomaly.
module circle_obcs_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90
index fbff153e23..c8ee29f8f4 100644
--- a/src/user/dense_water_initialization.F90
+++ b/src/user/dense_water_initialization.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization routines for the dense water formation
!! and overflow experiment.
module dense_water_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_EOS, only : EOS_type
diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90
index 0ae9f35e78..df286716f0 100644
--- a/src/user/dumbbell_initialization.F90
+++ b/src/user/dumbbell_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the model for the idealized dumbbell test case.
module dumbbell_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domains, only : sum_across_PEs
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
@@ -115,7 +117,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 +157,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/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90
index 288ccd89fa..2501cb0db3 100644
--- a/src/user/dumbbell_surface_forcing.F90
+++ b/src/user/dumbbell_surface_forcing.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Surface forcing for the dumbbell test case
module dumbbell_surface_forcing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : post_data, query_averaging_enabled
use MOM_diag_mediator, only : register_diag_field, diag_ctrl
use MOM_domains, only : pass_var, pass_vector, AGRID
@@ -207,7 +209,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS)
call get_param(param_file, mdl, "RHO_0", Rho0, &
"The mean ocean density used with BOUSSINESQ true to "//&
"calculate accelerations and the mass for conservation "//&
- "properties, or with BOUSSINSEQ false to convert some "//&
+ "properties, or with BOUSSINESQ false to convert some "//&
"parameters from vertical units of m to kg m-2.", &
units="kg m-3", default=1035.0, scale=US%kg_m3_to_R)
call get_param(param_file, mdl, "DUMBBELL_SLP_AMP", CS%slp_amplitude, &
diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90
index 2dde65148b..2d34bbb59b 100644
--- a/src/user/dyed_channel_initialization.F90
+++ b/src/user/dyed_channel_initialization.F90
@@ -1,17 +1,20 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization for the dyed_channel configuration
module dyed_channel_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_get_input, only : directories
use MOM_grid, only : ocean_grid_type
use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE
+use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_DIRECTION_E
use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer
use MOM_open_boundary, only : OBC_registry_type, register_OBC
-use MOM_time_manager, only : time_type, time_type_to_real
+use MOM_time_manager, only : time_type, time_to_real
use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup
use MOM_tracer_registry, only : tracer_type
use MOM_unit_scaling, only : unit_scale_type
@@ -30,6 +33,9 @@ module dyed_channel_initialization
real :: zonal_flow = 8.57 !< Mean inflow [L T-1 ~> m s-1]
real :: tidal_amp = 0.0 !< Sloshing amplitude [L T-1 ~> m s-1]
real :: frequency = 0.0 !< Sloshing frequency [T-1 ~> s-1]
+ logical :: OBC_transport_bug !< If true and specified open boundary conditions are being
+ !! used, use a 1 m (if Boussienesq) or 1 kg m-2 layer thickness
+ !! instead of the actual thickness.
end type dyed_channel_OBC_CS
integer :: ntr = 0 !< Number of dye tracers
@@ -38,13 +44,15 @@ module dyed_channel_initialization
contains
!> Add dyed channel to OBC registry.
-function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg)
+logical function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg)
type(param_file_type), intent(in) :: param_file !< parameter file.
type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel control structure.
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry.
+
! Local variables
- logical :: register_dyed_channel_OBC
+ logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
+ ! recreate the bugs, or if false bugs are only used if actively selected.
character(len=32) :: casename = "dyed channel" ! This case's name.
character(len=40) :: mdl = "register_dyed_channel_OBC" ! This subroutine's name.
@@ -64,6 +72,12 @@ function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg)
call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, &
"Frequency of oscillating zonal flow.", &
units="s-1", default=0.0, scale=US%T_to_s)
+ call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
+ default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
+ call get_param(param_file, mdl, "CHANNEL_FLOW_OBC_TRANSPORT_BUG", CS%OBC_transport_bug, &
+ "If true and specified open boundary conditions are being used, use a 1 m "//&
+ "(if Boussienesq) or 1 kg m-2 layer thickness instead of the actual thickness.", &
+ default=enable_bugs)
! Register the open boundaries.
call register_OBC(casename, param_file, OBC_Reg)
@@ -131,7 +145,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg)
end subroutine dyed_channel_set_OBC_tracer_data
!> This subroutine updates the long-channel flow
-subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time)
+subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, h, Time)
type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies
!! whether, where, and what open boundary
!! conditions are used.
@@ -139,55 +153,103 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time)
type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
+ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2]
type(time_type), intent(in) :: Time !< model time.
+
! Local variables
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: '// &
'dyed_channel_update_flow() was called but OBC type was not initialized!')
- time_sec = US%s_to_T * time_type_to_real(Time)
+ time_sec = time_to_real(Time, scale=US%s_to_T)
PI = 4.0*atan(1.0)
- do l=1, OBC%number_of_segments
- segment => OBC%segment(l)
+ turns = modulo(G%HI%turns, 4)
+
+ do l_seg=1, OBC%number_of_segments
+ segment => OBC%segment(l_seg)
if (.not. segment%on_pe) cycle
if (segment%gradient) cycle
- if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle
+ if (segment%oblique .and. (.not. segment%nudged) .and. (.not. segment%Flather)) cycle
+
+ if (CS%frequency == 0.0) then
+ flow = CS%zonal_flow
+ else
+ flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec)
+ endif
+ if ((turns==2) .or. (turns==3)) flow = -1.0 * flow
+ isd = segment%HI%isd ; ied = segment%HI%ied
+ jsd = segment%HI%jsd ; jed = segment%HI%jed
+ IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
+ JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB
if (segment%is_E_or_W) then
- jsd = segment%HI%jsd ; jed = segment%HI%jed
- IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
- if (CS%frequency == 0.0) then
- flow = CS%zonal_flow
+ is = IsdB ; ie = IedB ; js = jsd ; je = jed
+ else
+ is = isd ; ie = ied ; js = JsdB ; je = JedB
+ endif
+ cross_channel = ((segment%is_E_or_W .and. ((turns==0) .or. (turns==2))) .or. &
+ (segment%is_N_or_S .and. ((turns==1) .or. (turns==3))))
+
+ if ((segment%specified .or. segment%nudged) .and. cross_channel) then
+ do k=1,GV%ke ; do j=js,je ; do I=is,ie
+ segment%normal_vel(I,j,k) = flow
+ enddo ; enddo ; enddo
+ endif
+
+ if (segment%specified .and. cross_channel) then
+ if (CS%OBC_transport_bug) then
+ fixed_thickness = 1.0 / GV%H_to_mks ! This replicates the prevoius answers without rescaling.
+ if ((segment%direction == OBC_DIRECTION_W) .or. (segment%direction == OBC_DIRECTION_E)) then
+ do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB
+ segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * fixed_thickness
+ enddo ; enddo ; enddo
+ elseif ((segment%direction == OBC_DIRECTION_S) .or. (segment%direction == OBC_DIRECTION_N)) then
+ do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied
+ segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * fixed_thickness
+ enddo ; enddo ; enddo
+ endif
else
- flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec)
+ if (segment%direction == OBC_DIRECTION_W) then
+ do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB
+ segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * h(i+1,j,k)
+ enddo ; enddo ; enddo
+ elseif (segment%direction == OBC_DIRECTION_E) then
+ do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB
+ segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * h(i,j,k)
+ enddo ; enddo ; enddo
+ elseif (segment%direction == OBC_DIRECTION_S) then
+ do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied
+ segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * h(i,j+1,k)
+ enddo ; enddo ; enddo
+ elseif (segment%direction == OBC_DIRECTION_N) then
+ do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied
+ segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * h(i,j,k)
+ enddo ; enddo ; enddo
+ endif
endif
- do k=1,GV%ke
- do j=jsd,jed ; do I=IsdB,IedB
- if (segment%specified .or. segment%nudged) then
- segment%normal_vel(I,j,k) = flow
- endif
- if (segment%specified) then
- segment%normal_trans(I,j,k) = flow * G%dyCu(I,j)
- endif
- enddo ; enddo
- enddo
- do j=jsd,jed ; do I=IsdB,IedB
+ endif
+
+ if (cross_channel) then
+ do j=js,je ; do I=is,ie
segment%normal_vel_bt(I,j) = flow
enddo ; enddo
else
- isd = segment%HI%isd ; ied = segment%HI%ied
- JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB
- do J=JsdB,JedB ; do i=isd,ied
+ do J=js,je ; do i=is,ie
segment%normal_vel_bt(i,J) = 0.0
enddo ; enddo
endif
+
enddo
end subroutine dyed_channel_update_flow
diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90
index ffa217e0b5..9d6abee421 100644
--- a/src/user/dyed_obcs_initialization.F90
+++ b/src/user/dyed_obcs_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Dyed open boundary conditions; OBC_USER_CONFIG="dyed_obcs"
module dyed_obcs_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
@@ -55,7 +57,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg)
call get_param(param_file, mdl, "NUM_DYED_TRACERS", ntr, &
"The number of dyed_obc tracers in this run. Each tracer "//&
- "should have a separate boundary segment."//&
+ "should have a separate boundary segment. "//&
"If not present, use NUM_DYE_TRACERS.", default=-1, do_not_log=.true.)
if (ntr == -1) then
!for backward compatibility
diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90
index 437edc49b2..552abe2f66 100644
--- a/src/user/external_gwave_initialization.F90
+++ b/src/user/external_gwave_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization for the "external gravity wave wave" configuration
module external_gwave_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_get_input, only : directories
diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90
index ab08d4068d..8f2297c730 100644
--- a/src/user/lock_exchange_initialization.F90
+++ b/src/user/lock_exchange_initialization.F90
@@ -1,9 +1,11 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization of the "lock exchange" experiment.
!! lock_exchange = A 2-d density driven hydraulic exchange flow.
module lock_exchange_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_get_input, only : directories
diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90
index 59709ecde7..77556f123a 100644
--- a/src/user/seamount_initialization.F90
+++ b/src/user/seamount_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the model for the idealized seamount test case.
module seamount_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domains, only : sum_across_PEs
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90
index df46a142f1..488ac2b211 100644
--- a/src/user/shelfwave_initialization.F90
+++ b/src/user/shelfwave_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the model for the idealized shelfwave test case.
module shelfwave_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domains, only : sum_across_PEs
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe
@@ -10,8 +12,8 @@ module shelfwave_initialization
use MOM_grid, only : ocean_grid_type
use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_W
use MOM_open_boundary, only : OBC_segment_type, register_OBC
-use MOM_open_boundary, only : OBC_registry_type
-use MOM_time_manager, only : time_type, time_type_to_real
+use MOM_open_boundary, only : OBC_registry_type, rotate_OBC_segment_direction
+use MOM_time_manager, only : time_type, time_to_real
use MOM_unit_scaling, only : unit_scale_type
use MOM_verticalGrid, only : verticalGrid_type
@@ -29,14 +31,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 +53,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 +70,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=.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 +154,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
- time_sec = US%s_to_T*time_type_to_real(Time)
+ turns = modulo(G%HI%turns, 4)
+ my_amp = CS%my_amp ; if ((turns==2) .or. (turns==3)) my_amp = -CS%my_amp
+
+ time_sec = time_to_real(Time, scale=US%s_to_T)
+ if (CS%shelfwave_correct_amplitude) then
+ ! This makes the units and edge value of normal_vel_bt the same as my_amp.
+ I_yscale = 1.0 / CS%kk
+ else ! This preserves the previous answers.
+ if (G%grid_unit_to_L == 0.0) call MOM_error(FATAL, &
+ "shelfwave_set_OBC_data requires the use of Cartesian coordinates.")
+ I_yscale = (1.0e3 * US%m_to_L) / G%grid_unit_to_L
+ endif
do n = 1, OBC%number_of_segments
segment => OBC%segment(n)
if (.not. segment%on_pe) cycle
- if (segment%direction /= OBC_DIRECTION_W) cycle
-
- IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
- jsd = segment%HI%jsd ; jed = segment%HI%jed
- do j=jsd,jed ; do I=IsdB,IedB
- x = G%geoLonCu(I,j) - G%west_lon
- y = G%geoLatCu(I,j) - G%south_lat
+ 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/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90
index 4381d42038..2fa18d5ee6 100644
--- a/src/user/sloshing_initialization.F90
+++ b/src/user/sloshing_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initialization for the "sloshing" internal waves configuration.
module sloshing_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domains, only : sum_across_PEs
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
@@ -106,7 +108,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file,
!z_inter(k) = (2.0**(n-1)) * (z_unif(k) + 0.5)**n - 0.5
! Thin pycnocline in the middle (piecewise linear profile)
- x1 = 0.30; y1 = 0.48; x2 = 0.70; y2 = 0.52
+ x1 = 0.30 ; y1 = 0.48 ; x2 = 0.70 ; y2 = 0.52
x = -z_unif(k)
diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90
index a734574995..569d6904aa 100644
--- a/src/user/soliton_initialization.F90
+++ b/src/user/soliton_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Initial conditions for the Equatorial Rossby soliton test (Boyd).
module soliton_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_get_input, only : directories
diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90
index ddb38a9cdf..9190151569 100644
--- a/src/user/supercritical_initialization.F90
+++ b/src/user/supercritical_initialization.F90
@@ -1,14 +1,17 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> The "super critical" configuration
module supercritical_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_grid, only : ocean_grid_type
-use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_segment_type
-use MOM_time_manager, only : time_type, time_type_to_real
+use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, rotate_OBC_segment_direction
+use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W
+use MOM_time_manager, only : time_type
use MOM_unit_scaling, only : unit_scale_type
use MOM_verticalGrid, only : verticalGrid_type
@@ -32,6 +35,8 @@ subroutine supercritical_set_OBC_data(OBC, G, GV, US, param_file)
! Local variables
character(len=40) :: mdl = "supercritical_set_OBC_data" ! This subroutine's name.
real :: zonal_flow ! Inflow speed [L T-1 ~> m s-1]
+ integer :: unrot_dir ! The unrotated direction of the segment
+ integer :: turns ! Number of index quarter turns
integer :: i, j, k, l
integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list
@@ -43,13 +48,18 @@ subroutine supercritical_set_OBC_data(OBC, G, GV, US, param_file)
"Constant zonal flow imposed at upstream open boundary.", &
units="m/s", default=8.57, scale=US%m_s_to_L_T)
+ turns = modulo(G%HI%turns, 4)
+
do l=1, OBC%number_of_segments
segment => OBC%segment(l)
if (.not. segment%on_pe) cycle
if (segment%gradient) cycle
if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle
- if (segment%is_E_or_W) then
+ unrot_dir = segment%direction
+ if (turns /= 0) unrot_dir = rotate_OBC_segment_direction(segment%direction, -turns)
+
+ if ((unrot_dir == OBC_DIRECTION_E) .or. (unrot_dir == OBC_DIRECTION_W)) then
jsd = segment%HI%jsd ; jed = segment%HI%jed
IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB
do k=1,GV%ke
diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90
index 5b300a4d05..58938c65c0 100644
--- a/src/user/tidal_bay_initialization.F90
+++ b/src/user/tidal_bay_initialization.F90
@@ -1,20 +1,22 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Configures the model for the "tidal_bay" experiment.
!! tidal_bay = Tidally resonant bay from Zygmunt Kowalik's class on tides.
module tidal_bay_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_coms, only : reproducing_sum
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type
use MOM_grid, only : ocean_grid_type
-use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE
+use MOM_open_boundary, only : ocean_OBC_type
use MOM_open_boundary, only : OBC_segment_type, register_OBC
use MOM_open_boundary, only : OBC_registry_type
use MOM_unit_scaling, only : unit_scale_type
use MOM_verticalGrid, only : verticalGrid_type
-use MOM_time_manager, only : time_type, time_type_to_real
+use MOM_time_manager, only : time_type, time_to_real
implicit none ; private
@@ -75,10 +77,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 +93,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)
+ time_sec = time_to_real(Time, scale=US%s_to_T)
cff_eta = CS%tide_ssh_amp * sin(2.0*PI*time_sec / CS%tide_period)
- 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
diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90
index 1a1881a42b..fcd94442a3 100644
--- a/src/user/user_change_diffusivity.F90
+++ b/src/user/user_change_diffusivity.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Increments the diapycnal diffusivity in a specified band of latitudes and densities.
module user_change_diffusivity
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_diag_mediator, only : diag_ctrl, time_type
use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE
use MOM_file_parser, only : get_param, log_version, param_file_type
diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90
index 207f009c9c..390b42bd84 100644
--- a/src/user/user_initialization.F90
+++ b/src/user/user_initialization.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> A template of a user to code up customized initial conditions.
module user_initialization
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe
use MOM_dyn_horgrid, only : dyn_horgrid_type
use MOM_file_parser, only : get_param, log_version, param_file_type
diff --git a/src/user/user_revise_forcing.F90 b/src/user/user_revise_forcing.F90
index ce767d7479..db0df72f19 100644
--- a/src/user/user_revise_forcing.F90
+++ b/src/user/user_revise_forcing.F90
@@ -1,8 +1,10 @@
+! This file is part of MOM6, the Modular Ocean Model version 6.
+! See the LICENSE file for licensing information.
+! SPDX-License-Identifier: Apache-2.0
+
!> Provides a template for users to code updating the forcing fluxes.
module user_revise_forcing
-! This file is part of MOM6. See LICENSE.md for the license.
-
use MOM_domains, only : pass_var, pass_vector, AGRID
use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe
use MOM_file_parser, only : get_param, log_version, param_file_type