diff --git a/.github/workflows/verify-linux.yml b/.github/workflows/verify-linux.yml index 2bc7a66255..1c356663e0 100644 --- a/.github/workflows/verify-linux.yml +++ b/.github/workflows/verify-linux.yml @@ -17,9 +17,7 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - name: Check white space (non-blocking) run: | @@ -53,14 +51,15 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 with symmetric indexing run: make -C .testing -j build/symmetric/MOM6 @@ -68,7 +67,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-symmetric.tar .testing/build/symmetric/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-symmetric-artifact path: mom6-symmetric.tar @@ -78,14 +77,15 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 with asymmetric indexing run: make -C .testing -j build/asymmetric/MOM6 @@ -93,7 +93,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-asymmetric.tar .testing/build/asymmetric/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-asymmetric-artifact path: mom6-asymmetric.tar @@ -103,14 +103,15 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - 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 @@ -118,7 +119,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-repro.tar .testing/build/repro/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-repro-artifact path: mom6-repro.tar @@ -128,14 +129,15 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 supporting OpenMP run: make -C .testing -j build/openmp/MOM6 @@ -143,7 +145,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-openmp.tar .testing/build/openmp/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-openmp-artifact path: mom6-openmp.tar @@ -154,13 +156,11 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile target FMS + - name: Compile target depedencies run: | make -C .testing \ DO_REGRESSION_TESTS=1 \ @@ -177,7 +177,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-target.tar .testing/build/target/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-target-artifact path: mom6-target.tar @@ -187,14 +187,15 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 with aggressive optimization run: make -C .testing -j build/opt/MOM6 @@ -209,7 +210,7 @@ jobs: .testing/build/opt/MOM6 \ .testing/build/timing/time_* - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-opt-artifact path: mom6-opt.tar @@ -220,13 +221,11 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile target FMS + - name: Compile target dependencies run: | make -C .testing \ DO_REGRESSION_TESTS=1 \ @@ -253,7 +252,7 @@ jobs: .testing/build/opt_target/MOM6 \ .testing/build/target_codebase/.testing/build/timing/time_* - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-opt-target-artifact path: mom6-opt-target.tar @@ -263,14 +262,15 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 with code coverage run: make -C .testing -j build/cov/MOM6 @@ -289,7 +289,7 @@ jobs: .testing/build/unit/test_* \ .testing/build/unit/*.gcno - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-coverage-artifact path: mom6-coverage.tar @@ -299,14 +299,15 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 for the GFDL coupled driver run: make -C .testing -j check_mom6_api_coupled @@ -320,19 +321,17 @@ jobs: - build-asymmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download symmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact - name: Download asymmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-asymmetric-artifact @@ -353,14 +352,12 @@ jobs: needs: build-symmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download Artifacts - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -378,14 +375,12 @@ jobs: needs: build-symmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download Artifacts - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -403,14 +398,12 @@ jobs: needs: build-symmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download Artifacts - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -428,14 +421,12 @@ jobs: needs: build-symmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download Artifacts - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -463,14 +454,12 @@ jobs: - {id: r, desc: "density"} steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download symmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -490,19 +479,17 @@ jobs: - build-openmp steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download symmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact - name: Download OpenMP MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-openmp-artifact @@ -525,19 +512,17 @@ jobs: - build-repro steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download DEBUG MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact - name: Download REPRO MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-repro-artifact @@ -561,19 +546,17 @@ jobs: - build-target steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download symmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact - name: Download target MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-target-artifact @@ -595,14 +578,12 @@ jobs: needs: build-coverage steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download unit coverage tests - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-coverage-artifact @@ -641,14 +622,12 @@ jobs: - build-opt steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup - name: Download timing tests - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-opt-artifact @@ -673,9 +652,7 @@ jobs: - build-opt-target steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/ubuntu-setup @@ -690,12 +667,12 @@ jobs: build/target_codebase - name: Download optimized MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-opt-artifact - name: Download optimized target MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-opt-target-artifact @@ -756,7 +733,7 @@ jobs: - run-coverage steps: - - uses: geekyeggo/delete-artifact@v5 + - uses: geekyeggo/delete-artifact@v6 with: name: | mom6-asymmetric-artifact @@ -784,7 +761,7 @@ jobs: - run-timings steps: - - uses: geekyeggo/delete-artifact@v5 + - uses: geekyeggo/delete-artifact@v6 with: name: | mom6-symmetric-artifact @@ -808,7 +785,7 @@ jobs: - compare-timings steps: - - uses: geekyeggo/delete-artifact@v5 + - uses: geekyeggo/delete-artifact@v6 with: name: | mom6-symmetric-artifact diff --git a/.github/workflows/verify-macos.yml b/.github/workflows/verify-macos.yml index 5ba0669b7a..b2c49b1f61 100644 --- a/.github/workflows/verify-macos.yml +++ b/.github/workflows/verify-macos.yml @@ -19,14 +19,15 @@ jobs: runs-on: macOS-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 with symmetric indexing run: make -C .testing -j build/symmetric/MOM6 @@ -34,7 +35,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-symmetric.tar .testing/build/symmetric/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-symmetric-artifact path: mom6-symmetric.tar @@ -44,14 +45,15 @@ jobs: runs-on: macOS-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 with asymmetric indexing run: make -C .testing -j build/asymmetric/MOM6 @@ -59,7 +61,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-asymmetric.tar .testing/build/asymmetric/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-asymmetric-artifact path: mom6-asymmetric.tar @@ -69,14 +71,15 @@ jobs: runs-on: macOS-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - 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 @@ -84,7 +87,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-repro.tar .testing/build/repro/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-repro-artifact path: mom6-repro.tar @@ -94,14 +97,15 @@ jobs: runs-on: macOS-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup/ - - name: Compile FMS - run: make -C .testing -j build/deps/lib/libFMS.a + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a - name: Compile MOM6 supporting OpenMP run: make -C .testing -j build/openmp/MOM6 @@ -109,7 +113,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-openmp.tar .testing/build/openmp/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-openmp-artifact path: mom6-openmp.tar @@ -120,13 +124,11 @@ jobs: runs-on: macOS-latest steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup/ - - name: Compile target FMS + - name: Compile target dependencies run: | make -C .testing \ DO_REGRESSION_TESTS=1 \ @@ -143,7 +145,7 @@ jobs: - name: Prepare artifact run: tar -cf mom6-target.tar .testing/build/target/MOM6 - - uses: actions/upload-artifact@v4 + - uses: actions/upload-artifact@v7 with: name: mom6-target-artifact path: mom6-target.tar @@ -158,19 +160,17 @@ jobs: - build-asymmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download symmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact - name: Download asymmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-asymmetric-artifact @@ -191,14 +191,12 @@ jobs: needs: build-symmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download Artifacts - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -216,14 +214,12 @@ jobs: needs: build-symmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download Artifacts - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -241,14 +237,12 @@ jobs: needs: build-symmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download Artifacts - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -266,14 +260,12 @@ jobs: needs: build-symmetric steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download Artifacts - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -301,14 +293,12 @@ jobs: - {id: r, desc: "density"} steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download symmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact @@ -328,19 +318,17 @@ jobs: - build-openmp steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download symmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact - name: Download OpenMP MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-openmp-artifact @@ -363,19 +351,17 @@ jobs: - build-repro steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download DEBUG MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact - name: Download REPRO MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-repro-artifact @@ -399,19 +385,17 @@ jobs: - build-target steps: - - uses: actions/checkout@v4 - with: - submodules: recursive + - uses: actions/checkout@v7 - uses: ./.github/actions/macos-setup - name: Download symmetric MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-symmetric-artifact - name: Download target MOM6 - uses: actions/download-artifact@v4 + uses: actions/download-artifact@v8 with: name: mom6-target-artifact @@ -440,7 +424,7 @@ jobs: - test-repro steps: - - uses: geekyeggo/delete-artifact@v5 + - uses: geekyeggo/delete-artifact@v6 with: name: | mom6-asymmetric-artifact @@ -467,7 +451,7 @@ jobs: - test-repro steps: - - uses: geekyeggo/delete-artifact@v5 + - uses: geekyeggo/delete-artifact@v6 with: name: | mom6-symmetric-artifact @@ -490,7 +474,7 @@ jobs: - test-regression steps: - - uses: geekyeggo/delete-artifact@v5 + - uses: geekyeggo/delete-artifact@v6 with: name: | mom6-symmetric-artifact diff --git a/.gitignore b/.gitignore index c57b950fc2..55902085e8 100644 --- a/.gitignore +++ b/.gitignore @@ -1,23 +1 @@ -# 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 +/configure diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh index a6948c765e..018e0e3a08 100755 --- a/.gitlab/pipeline-ci-tool.sh +++ b/.gitlab/pipeline-ci-tool.sh @@ -164,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/.readthedocs.yml b/.readthedocs.yml index 4fe8d6300d..c48ee502d8 100644 --- a/.readthedocs.yml +++ b/.readthedocs.yml @@ -8,6 +8,10 @@ build: os: ubuntu-22.04 tools: python: "3.11" + jobs: + build: + html: + - sphinx-build -M html docs $READTHEDOCS_OUTPUT -j auto # Extra formats # PDF generation is failing for now; disabled on 2020-12-02 diff --git a/.testing/Makefile b/.testing/Makefile index 4e6827da2f..84688293ab 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -75,7 +75,8 @@ 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 @@ -148,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*) @@ -262,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 @@ -303,33 +309,25 @@ $(BUILD)/opt_target: | $(TARGET_CODEBASE) .PHONY: FORCE -## Use autoconf to construct the Makefile for each target -# TODO: This could all be moved to a top-level MOM6 Makefile +# Use autoconf to construct the Makefile for each target + .PRECIOUS: $(BUILD)/%/Makefile -.PRECIOUS: $(BUILD)/%/Makefile.in -.PRECIOUS: $(BUILD)/%/configure .PRECIOUS: $(BUILD)/%/config.status -.PRECIOUS: $(BUILD)/%/configure.ac -.PRECIOUS: $(BUILD)/%/m4/ -$(BUILD)/%/Makefile: $(BUILD)/%/Makefile.in $(BUILD)/%/config.status +$(BUILD)/%/Makefile: $(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) \ +# NOTE: This assumes % is a single directory +$(BUILD)/%/config.status: \ + $(DEPS)/lib/libFMS.a \ + $(DEPS)/lib/libgsw.a \ + $(DEPS)/lib/libcvmix.a \ + ../configure | $(BUILD)/%/ + cd $(@D) && $(MOM_ENV) ../../../configure -n $(MOM_ACFLAGS) \ || (cat config.log && false) -$(BUILD)/%/Makefile.in: ../ac/Makefile.in | $(BUILD)/%/ - cp ../ac/Makefile.in $(@D) - -$(BUILD)/%/configure: $(BUILD)/%/configure.ac $(BUILD)/%/m4/ - autoreconf -if $(@D) - -$(BUILD)/%/configure.ac: ../ac/configure.ac | $(BUILD)/%/ - cp ../ac/configure.ac $(@D) - -$(BUILD)/%/m4/: ../ac/m4/ | $(BUILD)/%/ - cp -r ../ac/m4 $(@D) +../configure: + $(MAKE) -C ../ configure ALL_EXECS = symmetric asymmetric repro openmp opt opt_target coupled nuopc \ cov unit timing @@ -344,19 +342,18 @@ $(TARGET_CODEBASE): 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 @@ -364,6 +361,33 @@ $(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)/ diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input index eacf4143de..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 + 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 ff2dabe065..88a38a8fa8 100644 --- a/.testing/tc1.a/MOM_tc_variant +++ b/.testing/tc1.a/MOM_tc_variant @@ -1,2 +1,3 @@ -#override SPLIT=False -#override UNSPLIT_DT_VISC_BUG = True ! [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 878e582546..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 UNSPLIT_DT_VISC_BUG = True ! [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 ea16da62a8..c7add5d5b7 100644 --- a/.testing/tc1/MOM_input +++ b/.testing/tc1/MOM_input @@ -584,28 +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 -! Explicitly use the defaults from late 2024 -EQN_OF_STATE = "WRIGHT" ! default = "WRIGHT_FULL" -HOR_DIFF_ANSWER_DATE = 20240101 -HOR_DIFF_LIMIT_BUG = True +! 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 -! Explicitly use the defaults from early 2025 -VISC_REM_BUG = True -DRAG_DIFFUSIVITY_ANSWER_DATE = 20250101 -FRICTWORK_BUG = True -HOR_DIFF_ANSWER_DATE = 20240101 -HOR_DIFF_LIMIT_BUG = True -MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = False diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index 77a2a92678..fea7ca25d1 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -616,27 +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 -! Explicitly use the defaults from late 2024 +! Updated defaults reflecting the model status in late 2025 EQN_OF_STATE = "WRIGHT" ! default = "WRIGHT_FULL" -TIDES_ANSWER_DATE = 20230630 -NDIFF_ANSWER_DATE = 20240101 -BACKSCATTER_UNDERBOUND = True +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 -! Explicitly use the defaults from early 2025 -VISC_REM_BUG = True -DRAG_DIFFUSIVITY_ANSWER_DATE = 20250101 -FRICTWORK_BUG = True -NDIFF_ANSWER_DATE = 20240101 -MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = False + +BACKSCATTER_UNDERBOUND = True diff --git a/.testing/tc2/MOM_tc_variant b/.testing/tc2/MOM_tc_variant index 8cdbf69de8..fd7e20784d 100644 --- a/.testing/tc2/MOM_tc_variant +++ b/.testing/tc2/MOM_tc_variant @@ -10,3 +10,6 @@ TIDE_Q1 = True TIDE_MF = True TIDE_MM = True TIDE_SAL_SCALAR_VALUE = 1. +BT_STRONG_DRAG = True ! [Boolean] default = False +RESCALE_STRONG_DRAG = True ! [Boolean] default = False + diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index 41ccf286aa..0c6a503db4 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -473,15 +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 -! Explicitly use the defaults from early 2025 -VISC_REM_BUG = True -DRAG_DIFFUSIVITY_ANSWER_DATE = 20250101 -FRICTWORK_BUG = True +! 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 94ac6a7be8..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] @@ -412,11 +402,15 @@ DEBUG = True INTERPOLATE_RES_FN = True ! [Boolean] default = True GILL_EQUATORIAL_LD = 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 -! Explicitly use the defaults from early 2025 -VISC_REM_BUG = True -FRICTWORK_BUG = True -MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = 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/configure.ac b/.testing/tc4/configure.ac index d5dc142e85..2ec7e2af44 100644 --- a/.testing/tc4/configure.ac +++ b/.testing/tc4/configure.ac @@ -51,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/Makefile b/Makefile new file mode 100644 index 0000000000..477ebbbfc7 --- /dev/null +++ b/Makefile @@ -0,0 +1,71 @@ +# This 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 ?= build +FMS_BUILD ?= ac/deps/fms/build +MOM_MEMORY ?= + +.PHONY: all +all: $(BUILD)/MOM6 + +$(BUILD)/MOM6: $(BUILD)/Makefile $(FMS_BUILD)/libFMS.a + if test $(FMS_BUILD)/libFMS.a -nt $@ ; then \ + $(MAKE) -C $(BUILD) clean ; \ + fi + $(MAKE) -C $(BUILD) MOM6 + + +# Makefile setup + +$(BUILD)/Makefile: $(BUILD)/config.status ac/Makefile.in + cd $(BUILD) && ./config.status + +$(BUILD)/config.status: configure $(FMS_BUILD)/libFMS.a | $(BUILD) + cd $(BUILD) && \ + PATH="${PATH}:$(CURDIR)/ac" \ + $(CURDIR)/configure -n $(CONFIG_FLAGS) + + +# configure setup + +configure: ac/configure.ac ac/aclocal.m4 | ac/m4 + cd ac && autoconf -o $(abspath $@) + +ac/aclocal.m4: ac/configure.ac | ac/m4 + cd ac && aclocal + +$(BUILD): + mkdir -p $@ + + +# Dependencies + +# NOTE: If libFMS has changed, then we completely rebuild MOM6 +$(FMS_BUILD)/libFMS.a: FORCE + $(MAKE) -C ac/deps \ + BUILD=$(abspath $(FMS_BUILD)) \ + CODEBASE=$(abspath $(FMS_CODEBASE)) + +FORCE: + + +# Cleanup + +# Remove build output +.PHONY: clean +clean: + rm -rf $(BUILD) + $(MAKE) -C ac/deps clean + +# Remove generated autoconf output +.PHONY: ac-clean +ac-clean: + rm -f configure + rm -f configure~ + rm -f ac/aclocal.m4 + rm -rf ac/autom4te.cache/ + +# Remove all build products +.PHONY: maintainer-clean +maintainer-clean: clean ac-clean diff --git a/ac/.gitignore b/ac/.gitignore new file mode 100644 index 0000000000..df4b95eee5 --- /dev/null +++ b/ac/.gitignore @@ -0,0 +1,2 @@ +/aclocal.m4 +/autom4te.cache/ diff --git a/ac/Makefile.in b/ac/Makefile.in index da321067b2..1b02fa4a4f 100644 --- a/ac/Makefile.in +++ b/ac/Makefile.in @@ -18,8 +18,8 @@ CPPFLAGS = @CPPFLAGS@ FCFLAGS = @FCFLAGS@ LDFLAGS = @LDFLAGS@ LIBS = @LIBS@ -SRC_DIRS = @SRC_DIRS@ - +MAKEDEP_FLAGS = @MAKEDEP_FLAGS@ +MAKEDEP_DIRS = @MAKEDEP_DIRS@ -include Makefile.dep @@ -35,8 +35,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,$(MAKEDEP_DIRS),*.h *.c *.inc *.F90) + $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep $(MAKEDEP_FLAGS) $(MAKEDEP_DIRS) # Delete any files associated with configuration (including the Makefile). @@ -58,5 +58,5 @@ distclean: clean ac-clean: distclean rm -f @srcdir@/ac/aclocal.m4 rm -rf @srcdir@/ac/autom4te.cache - rm -f @srcdir@/ac/configure - rm -f @srcdir@/ac/configure~ + rm -f @srcdir@/configure + rm -f @srcdir@/configure~ diff --git a/ac/configure.ac b/ac/configure.ac index 201bb262c4..25af8d1a9b 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -4,46 +4,37 @@ # Autoconf configuration -# 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. - 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]) +# Validate srcdir +AC_CONFIG_SRCDIR([src/core/MOM.F90]) + +# Prevent builds in the top directory ($srcdir) +AS_IF([test "${srcdir}" = '.'], [ + AC_MSG_ERROR([Build directory cannot be set to the top directory]) +]) + +# Prevent builds in .testing/ +testdir=$(cd "${srcdir}/.testing" && pwd) +AS_IF([test "$(pwd)" = "${testdir}"], [ + AC_MSG_ERROR([Build directory cannot be set to .testing/]) +]) + + +# Macro configuration 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 @@ -55,7 +46,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'])] ) @@ -68,16 +59,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. @@ -142,31 +150,37 @@ 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"] +) # OpenMP configuration @@ -196,19 +210,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] + ) ] ) @@ -235,7 +252,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]) @@ -254,19 +297,38 @@ 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" +]) + +AS_IF([test "$with_cvmix" = yes], [ + MAKEDEP_FLAGS="${MAKEDEP_FLAGS} \\ + -s ${srcdir}/src/parameterizations/CVmix" +]) + +MAKEDEP_FLAGS="${MAKEDEP_FLAGS}" -# Generate source list and configure dependency command -AC_SUBST([SRC_DIRS], ["\\ +MAKEDEP_FLAGS="${MAKEDEP_FLAGS# }" +AC_SUBST([MAKEDEP_FLAGS]) + +MAKEDEP_DIRS="\\ ${srcdir}/src \\ ${MODEL_FRAMEWORK} \\ ${srcdir}/config_src/external \\ ${DRIVER_DIR} \\ - ${MOM_MEMORY_DIR}"] -) + ${MOM_MEMORY_DIR}" +AC_SUBST([MAKEDEP_DIRS]) + +# Add makedep to config.status AC_CONFIG_COMMANDS(Makefile.dep, [make depend]) @@ -307,7 +369,7 @@ AC_DEFINE_UNQUOTED([SIGSETJMP_NAME], ["${SIGSETJMP}"]) # Validate the siglongjmp symbol AX_FC_CHECK_BIND_C([siglongjmp], - [SIGLONGJMP="siglongjmp"], [SETJMP="siglongjmp_missing"] + [SIGLONGJMP="siglongjmp"], [SIGLONGJMP="siglongjmp_missing"] ) AC_DEFINE_UNQUOTED([SIGLONGJMP_NAME], ["${SIGLONGJMP}"]) @@ -327,5 +389,5 @@ AC_LANG_POP([C]) # Prepare output AC_SUBST([CPPFLAGS]) -AC_CONFIG_FILES([Makefile:${srcdir}/ac/Makefile.in]) +AC_CONFIG_FILES([Makefile:ac/Makefile.in]) AC_OUTPUT diff --git a/ac/deps/.gitignore b/ac/deps/.gitignore index 8cfaa6ebcb..49e1368ea3 100644 --- a/ac/deps/.gitignore +++ b/ac/deps/.gitignore @@ -1,5 +1,5 @@ -/bin/ /fms/ +/gsw/ +/cvmix/ /include/ /lib/ -/mkmf/ diff --git a/ac/deps/Makefile b/ac/deps/Makefile index 00aeedd238..e5654ed742 100644 --- a/ac/deps/Makefile +++ b/ac/deps/Makefile @@ -14,6 +14,12 @@ MAKEFLAGS += -R FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git FMS_COMMIT ?= 2023.03 +GSW_URL ?= https://github.com/mom-ocean/GSW-Fortran.git +GSW_COMMIT ?= 29e64d652786e1d076a05128c920f394202bfe10 + +CVMIX_URL ?= https://github.com/mom-ocean/CVMix-src.git +CVMIX_COMMIT ?= fce422195a0c58f15a55946b5ed517ba4365e232 + # List of source files to link this Makefile's dependencies to model Makefiles # Assumes a depth of two, and the following extensions: F90 inc c h @@ -22,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) + +$(2)/build: + mkdir -p $$@ +endef -fms/build/configure: fms/build/configure.ac $(FMS_SOURCE) | fms/src - autoreconf 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/configure.ac: configure.fms.ac m4 | fms/build - cp configure.fms.ac fms/build/configure.ac - cp -r m4 fms/build -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.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 8aef4eaccf..f00c4343e7 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -15,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 @@ -72,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 @@ -175,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/m4/ax_fc_check_lib.m4 b/ac/m4/ax_fc_check_lib.m4 deleted file mode 100644 index 4074b52e46..0000000000 --- a/ac/m4/ax_fc_check_lib.m4 +++ /dev/null @@ -1,57 +0,0 @@ -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]) -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 somewhat from AC_CHECK_LIB, since it includes two -dnl additional features: -dnl -dnl 1. The third argument (optional) allows us to specify a Fortran module, -dnl which may be required to access the library's functions. -dnl -dnl 2. The sixth argument (optional) allows specification of supplemental -dnl LDFLAGS arguments. This can be used, for example, to test for the -dnl library with different -L flags, or perhaps other ld configurations. -dnl -dnl Results are cached in the ax_fc_cv_lib_LIBRARY_FUNCTION variable. -dnl -AC_DEFUN([AX_FC_CHECK_LIB],[ - AS_VAR_PUSHDEF([ax_fc_Lib], [ax_fc_cv_lib_$1_$2]) - m4_ifval([$6], - [ax_fc_lib_msg_LDFLAGS=" with $6"], - [ax_fc_lib_msg_LDFLAGS=""] - ) - AC_CACHE_CHECK([for $2 in -l$1$ax_fc_lib_msg_LDFLAGS], [ax_fc_cv_lib_$1_$2],[ - ax_fc_check_lib_save_LDFLAGS=$LDFLAGS - LDFLAGS="$6 $LDFLAGS" - ax_fc_check_lib_save_LIBS=$LIBS - LIBS="-l$1 $7 $LIBS" - AS_IF([test -n "$3"], - [ax_fc_use_mod="use $3"], - [ax_fc_use_mod=""]) - AC_LINK_IFELSE([dnl -dnl Begin 7-column code block -AC_LANG_PROGRAM([], [dnl - $ax_fc_use_mod - call $2])dnl -dnl End code block - ], - [AS_VAR_SET([ax_fc_Lib], [yes])], - [AS_VAR_SET([ax_fc_Lib], [no])] - ) - LIBS=$ax_fc_check_lib_save_LIBS - LDFLAGS=$ax_fc_check_lib_save_LDFLAGS - ]) - AS_VAR_IF([ax_fc_Lib], [yes], - [m4_default([$4], [LIBS="-l$1 $LIBS"])], - [$5] - ) - AS_VAR_POPDEF([ax_fc_Lib]) -]) diff --git a/ac/m4/mom6_fc_check_lib.m4 b/ac/m4/mom6_fc_check_lib.m4 new file mode 100644 index 0000000000..ae751f37df --- /dev/null +++ b/ac/m4/mom6_fc_check_lib.m4 @@ -0,0 +1,86 @@ +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 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 m4_normalize([$9])"], + [mom6_fc_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$mom6_fc_lib_msg_LDFLAGS], + [mom6_fc_Lib],[ + mom6_fc_check_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$9 $LDFLAGS" + mom6_fc_check_lib_save_LIBS=$LIBS + LIBS="-l$1 $10 $LIBS" + AS_IF([test -n "$3"], + [mom6_fc_use_mod="use $3"], + [mom6_fc_use_mod=""] + ) + AS_IF([test -n "$5"], + [mom6_fc_proc="$5 = $2"], + [mom6_fc_proc="call $2"] + ) + AS_IF([test -n "$4"], + [mom6_fc_proc="${mom6_fc_proc}($4)"] + ) + AS_IF([test -n "$6"], + [mom6_fc_decls="$6"], + [mom6_fc_decls=""] + ) + AC_LANG_PUSH([Fortran]) + AC_LINK_IFELSE([dnl +dnl Begin 7-column code block +AC_LANG_PROGRAM([], [dnl + $mom6_fc_use_mod + $mom6_fc_decls + $mom6_fc_proc])dnl +dnl End code block + ], + [AS_VAR_SET([mom6_fc_Lib], [yes])], + [AS_VAR_SET([mom6_fc_Lib], [no])] + ) + AC_LANG_POP([Fortran]) + LIBS=$mom6_fc_check_lib_save_LIBS + LDFLAGS=$mom6_fc_check_lib_save_LDFLAGS + ] + ) + AS_VAR_IF([mom6_fc_Lib], [yes], + [m4_default([$7], [LIBS="-l$1 $LIBS"])], + [$8] + ) + AS_VAR_POPDEF([mom6_fc_Lib]) +]) diff --git a/ac/makedep b/ac/makedep index 4903d88274..5ab4e9ffe6 100755 --- a/ac/makedep +++ b/ac/makedep @@ -13,6 +13,9 @@ import sys # Fortran tokenization re_module = re.compile(r"^ *module +([a-z_0-9]+)") +re_submodule = re.compile( + r"^ *submodule *\( *([a-z_0-9]+) *(?:: *([a-z_0-9]+) *)?\) +([a-z_0-9]+)" +) re_use = re.compile(r"^ *use +([a-z_0-9]+)") re_cpp_define = re.compile(r"^ *# *define +[_a-zA-Z][_a-zA-Z0-9]") re_cpp_undef = re.compile(r"^ *# *undef +[_a-zA-Z][_a-zA-Z0-9]") @@ -150,17 +153,24 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, # maps object file to C source o2c = dict(zip([object_file(f) for f in c_files], c_files)) - o2mods, o2uses, o2h, o2inc, o2prg, prg2o, mod2o = {}, {}, {}, {}, {}, {}, {} + o2mods, o2uses, o2subdeps = {}, {}, {} + o2h, o2inc, o2prg, prg2o, mod2o = {}, {}, {}, {}, {} externals, all_modules = [], [] + parent2subobjs = {} for f in F90_files: - mods, used, cpp, inc, prg, has_externals = scan_fortran_file(f, defines) + mods, used, subdeps, cpp, inc, prg, has_externals = scan_fortran_file(f, defines) + obj = object_file(f) # maps object file to modules produced - o2mods[object_file(f)] = mods + o2mods[obj] = mods # maps module produced to object file for m in mods: - mod2o[m] = object_file(f) + mod2o[m] = obj # maps object file to modules used - o2uses[object_file(f)] = used + o2uses[obj] = used + # maps object file to ancestor modules/submodules + o2subdeps[obj] = subdeps + for m in subdeps: + parent2subobjs.setdefault(m, []).append(obj) # maps object file to .h files included o2h[object_file(f)] = cpp # maps object file to .inc files included @@ -184,8 +194,20 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, externals.append(object_file(f)) all_modules += mods + for smod in list(parent2subobjs.keys()): + if '@' in smod: + continue + + parent_mod = smod[:-5] + '.mod' + if parent_mod in mod2o: + parent_obj = mod2o[parent_mod] + if smod not in o2mods[parent_obj]: + o2mods[parent_obj].append(smod) + mod2o[smod] = parent_obj + all_modules.append(smod) + for f in c_files: - _, _, cpp, inc, _, _ = scan_fortran_file(f, defines) + _, _, _, cpp, inc, _, _ = scan_fortran_file(f, defines) # maps object file to .h files included o2h[object_file(f)] = cpp externals.append(object_file(f)) @@ -235,6 +257,9 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, found_deps = [ dep for pair in zip(found_mods, found_objs) for dep in pair ] + subdep_objs = sorted(set([ + mod2o[m] for m in o2subdeps[obj] if m in mod2o + ])) missing_mods = [m for m in o2uses[obj] if m not in all_modules] incs, inc_used = nested_inc(o2h[obj] + o2inc[obj], f2F, defines) @@ -254,6 +279,7 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, print("# uses:", ' '.join(o2uses[obj]), file=file) print("# found mods:", ' '.join(found_mods), file=file) print("# found objs:", ' '.join(found_objs), file=file) + print("# submodule objs:", ' '.join(subdep_objs), file=file) print("# missing:", ' '.join(missing_mods), file=file) print("# includes_all:", ' '.join(incs), file=file) print("# includes_pth:", ' '.join(incdeps), file=file) @@ -265,7 +291,7 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, print(' '.join(o2mods[obj]) + ':', obj, file=file) # Fortran object dependencies - obj_incs = ' '.join(inc_mods + incdeps + found_deps) + obj_incs = ' '.join(inc_mods + incdeps + found_deps + subdep_objs) print(obj + ':', o2F90[obj], obj_incs, file=file) # Fortran object build rule @@ -310,7 +336,7 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, for p in sorted(prg2o.keys()): o = prg2o[p] print(file=file) - print(p+':', ' '.join(link_obj(o, o2uses, mod2o, all_modules) + externals), file=file) + print(p+':', ' '.join(link_obj(o, o2uses, mod2o, all_modules, parent2subobjs, o2mods) + externals), file=file) print('\t$(LD) $(LDFLAGS) -o $@ $^ $(LIBS)', file=file) # Write rules for building libraries @@ -322,7 +348,7 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, # Write cleanup rules print(file=file) print("clean:", file=file) - print('\trm -f *.mod *.o', ' '.join(list(prg2o.keys()) + targ_libs), file=file) + print('\trm -f *.mod *.smod *.o', ' '.join(list(prg2o.keys()) + targ_libs), file=file) # Write re-generation rules print(file=file) @@ -330,11 +356,16 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, print('\t'+' '.join(sys.argv), file=file) -def link_obj(obj, o2uses, mod2o, all_modules): +def link_obj(obj, o2uses, mod2o, all_modules, parent2subobjs, o2mods): """List of all objects needed to link "obj",""" def recur(obj, depth=0): if obj not in olst: olst.append(obj) + # If this object defines modules, add their submodules + for m in o2mods.get(obj, []): + if m in parent2subobjs: + for subobj in parent2subobjs[m]: + recur(subobj, depth=depth+1) else: return uses = [m for m in o2uses[obj] if m in all_modules] @@ -343,9 +374,6 @@ def link_obj(obj, o2uses, mod2o, all_modules): for m in uses: o = mod2o[m] recur(o, depth=depth+1) - # if o not in olst: - # recur(o, depth=depth+1) - # olst.append(o) return return olst = [] @@ -363,7 +391,7 @@ def nested_inc(inc_files, f2F, defines): if hfile not in f2F.keys(): return - _, used, cpp, inc, _, _ = scan_fortran_file(f2F[hfile], defines) + _, used, _, cpp, inc, _, _ = scan_fortran_file(f2F[hfile], defines) # Record any module updates inside of include files used_mods.update(used) @@ -385,11 +413,14 @@ def nested_inc(inc_files, f2F, defines): def scan_fortran_file(src_file, defines=None): """Scan the Fortran file "src_file" and return lists of module defined, module used, and files included.""" - module_decl, used_modules, cpp_includes, f90_includes, programs = [], [], [], [], [] + module_decl, used_modules = [], [] + submodule_deps, cpp_includes, f90_includes, programs = [], [], [], [] 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 +485,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 @@ -476,14 +508,24 @@ def scan_fortran_file(src_file, defines=None): match = re_module.match(line.lower()) if match: - # Avoid "module procedure" statements - if match.group(1) not in 'procedure': - module_decl.append(match.group(1)) + # Avoid "module procedure", "module subroutine", "module function" statements + if match.group(1) not in ['procedure', 'subroutine', 'function']: + module_decl.append(module_file(match.group(1))) external_namespace = False + match = re_submodule.match(line.lower()) + if match: + # Submodule declaration: submodule (ancestor[:parent]) name + ancestor = match.group(1) + parent = match.group(2) + name = match.group(3) + module_decl.extend(submodule_files(ancestor, name)) + submodule_deps.extend(submodule_parent_files(ancestor, parent)) + external_namespace = False + match = re_use.match(line.lower()) if match: - used_modules.append(match.group(1)) + used_modules.append(module_file(match.group(1))) match = re_cpp_include.match(line) if match: @@ -511,8 +553,8 @@ def scan_fortran_file(src_file, defines=None): file_has_externals = True used_modules = [m for m in sorted(set(used_modules)) if m not in module_decl] - return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs, file_has_externals - # return add_suff(module_decl, '.mod'), add_suff(sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs + submodule_deps = sorted(set(submodule_deps)) + return module_decl, used_modules, submodule_deps, cpp_includes, f90_includes, programs, file_has_externals def object_file(src_file): @@ -521,6 +563,23 @@ def object_file(src_file): return os.path.splitext(os.path.basename(src_file))[0] + '.o' +def module_file(name): + """Return the compiler sidecar file for a Fortran module.""" + return name + '.mod' + + +def submodule_files(ancestor, name): + """Return known compiler sidecar files for a Fortran submodule.""" + return [ancestor + '@' + name + '.smod', ancestor + '-' + name + '.mod'] + + +def submodule_parent_files(ancestor, parent=None): + """Return known sidecar files needed by a descendant submodule.""" + if parent: + return submodule_files(ancestor, parent) + return [ancestor + '.smod', module_file(ancestor)] + + def find_files(src_dirs, skip_dirs): """Return sorted list of all source files starting from each directory in the list "src_dirs".""" @@ -547,11 +606,6 @@ def find_files(src_dirs, skip_dirs): return sorted(set(files)) -def add_suff(lst, suff): - """Add "suff" to each item in the list""" - return [f + suff for f in lst] - - def cpp_expr_eval(expr, macros=None): if macros is None: macros = {} 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 1a4981ccee..f9fee3dc72 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -111,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. @@ -133,7 +134,14 @@ module MOM_surface_forcing_gfdl !! for salinity restoring. real :: ice_salt_concentration !< Salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< If true, then mask SSS restoring in marginal seas + logical :: max_delta_srestore_file !< If true, apply a 2-dimensional maximum delta salinity + !! when restoring. The file should be + !! in inputdir/max_delta_srestore.nc and the field + !! should be named 'max_delta_srestore' + real, pointer, dimension(:,:) :: max_delta_srestore_2d => NULL() + !< Maximum delta salinity used for restoring [S ~> ppt] real :: max_delta_srestore !< Maximum delta salinity used for restoring [S ~> ppt] + real :: min_ratio_srestore !< Minimum fraction of restoring salinity to preserve [nondim] real :: max_delta_trestore !< Maximum delta sst used for restoring [C ~> degC] real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin [nondim] integer :: answer_date !< The vintage of the order of arithmetic and expressions in the @@ -191,6 +199,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] @@ -289,7 +298,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) @@ -378,7 +388,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) - delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + if (sfc_state%SSS(i,j) >= data_restore(i,j)*CS%min_ratio_srestore) then + if (.not. CS%max_delta_srestore_file) then + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + else + if (abs(delta_sss) > abs(CS%max_delta_srestore_2d(i,j))) then + if (CS%max_delta_srestore_2d(i,j) < 0.0) then + delta_sss = 0.0 !turn off restoring + else !clip restoring + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore_2d(i,j)) + endif + endif + endif !max_delta_srestore_file + endif !min_ratio_srestore fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const_salt)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) * delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo @@ -400,7 +422,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) - delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + if (sfc_state%SSS(i,j) >= data_restore(i,j)*CS%min_ratio_srestore) then + if (.not. CS%max_delta_srestore_file) then + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + else + if (abs(delta_sss) > abs(CS%max_delta_srestore_2d(i,j))) then + if (CS%max_delta_srestore_2d(i,j) < 0.0) then + delta_sss = 0.0 !turn off restoring + else !clip restoring + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore_2d(i,j)) + endif + endif + endif !max_delta_srestore_file + endif !min_ratio_srestore fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & (CS%rho_restore*CS%Flux_const_salt) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) @@ -505,6 +539,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) & @@ -1198,7 +1238,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) @@ -1248,7 +1288,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 @@ -1341,13 +1381,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. type(time_type) :: Time_frc - type(directories) :: dirs ! A structure containing relevant directory paths and input filenames. + type(directories) :: dirs ! A structure containing relevant directory paths and input filenames. character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=48) :: stagger - character(len=48) :: flnam + character(len=80) :: varnam + character(len=240) :: flnam character(len=240) :: basin_file integer :: i, j, isd, ied, jsd, jed @@ -1387,7 +1428,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, & @@ -1451,11 +1492,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.") @@ -1465,7 +1506,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 = "// & @@ -1502,9 +1543,30 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & "If true, the restoring of salinity is applied as a salt "//& "flux instead of as a freshwater flux.", default=.false.) - call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & - "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_FROM_FILE", CS%max_delta_srestore_file, & + "If true, read a file MAX_DELTA_SRESTORE_FILE containing the field "//& + "MAX_DELTA_SRESTORE_VARNAME for the maximum salinity difference used in "//& + "restoring terms. Where the field's value is negative turn off restoring when "//& + "the salinity difference magnitude exceeds abs(value).", default=.false.) + if (.not. CS%max_delta_srestore_file) then + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & + "The maximum salinity difference used in restoring terms.", & + units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) + else + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_FILE", flnam, & + "The path to the file containing the maximum salinity difference field.", & + default="max_delta_srestore.nc") + flnam = trim(CS%inputdir) // trim(flnam) + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_VARNAME", varnam, & + "The name of the maximum salinity difference variable in the input file.", & + default="max_delta_srestore") + CS%max_delta_srestore = 999.0 + call safe_alloc_ptr(CS%max_delta_srestore_2d,isd,ied,jsd,jed) + call MOM_read_data(flnam,varnam, CS%max_delta_srestore_2d, G%domain, timelevel=1) + endif + call get_param(param_file, mdl, "MIN_RATIO_SRESTORE", CS%min_ratio_srestore, & + "Turn off MAX_DELTA_SRESTORE where the ratio of SSS to restoring salinity "//& + "is less than this value.", units="nondim", default=0.0) call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", CS%mask_srestore_under_ice, & "If true, disables SSS restoring under sea-ice based on a frazil "//& "criteria (SST<=Tf). Only used when RESTORE_SALINITY is True.", & @@ -1612,13 +1674,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 @@ -1708,8 +1770,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 "//& @@ -1725,7 +1791,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) @@ -1735,7 +1801,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 110415c6e0..8bb87600ee 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -47,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 @@ -56,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 @@ -284,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, & @@ -342,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, & @@ -374,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, & @@ -386,6 +387,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas if (OS%use_ice_shelf) then call initialize_ice_shelf_fluxes(OS%ice_shelf_CSp, OS%grid, OS%US, OS%fluxes) + call initialize_ice_shelf_fluxes(OS%ice_shelf_CSp, OS%grid, OS%US, OS%flux_tmp) call initialize_ice_shelf_forces(OS%ice_shelf_CSp, OS%grid, OS%US, OS%forces) endif @@ -412,6 +414,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 @@ -493,7 +498,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 "// & @@ -655,7 +660,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) @@ -663,7 +668,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 @@ -681,6 +686,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) @@ -989,6 +998,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 6e1545efe1..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 @@ -53,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 @@ -135,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. @@ -334,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, & @@ -364,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) @@ -403,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 @@ -580,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 @@ -660,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) @@ -733,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 @@ -797,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) @@ -972,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 5df0d2a3f6..124fed779c 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 @@ -116,7 +116,14 @@ module MOM_surface_forcing_mct real :: ice_salt_concentration !< salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas + logical :: max_delta_srestore_file !< If true, apply a 2-dimensional maximum delta salinity + !! when restoring. The file should be + !! in inputdir/max_delta_srestore.nc and the field + !! should be named 'max_delta_srestore' + real, pointer, dimension(:,:) :: max_delta_srestore_2d => NULL() + !< Maximum delta salinity used for restoring [S ~> ppt] real :: max_delta_srestore !< maximum delta salinity used for restoring [S ~> ppt] + real :: min_ratio_srestore !< Minimim fraction of restoring salinity to preserve [nondim] real :: max_delta_trestore !< maximum delta sst used for restoring [C ~> degC] real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring by basin logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the @@ -364,7 +371,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + if (sfc_state%SSS(i,j) >= data_restore(i,j)*CS%min_ratio_srestore) then + if (.not. CS%max_delta_srestore_file) then + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + else + if (abs(delta_sss) > abs(CS%max_delta_srestore_2d(i,j))) then + if (CS%max_delta_srestore_2d(i,j) < 0.0) then + delta_sss = 0.0 !turn off restoring + else !clip restoring + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore_2d(i,j)) + endif + endif + endif !max_delta_srestore_file + endif !min_ratio_srestore fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo @@ -385,7 +404,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + if (sfc_state%SSS(i,j) >= data_restore(i,j)*CS%min_ratio_srestore) then + if (.not. CS%max_delta_srestore_file) then + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + else + if (abs(delta_sss) > abs(CS%max_delta_srestore_2d(i,j))) then + if (CS%max_delta_srestore_2d(i,j) < 0.0) then + delta_sss = 0.0 !turn off restoring + else !clip restoring + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore_2d(i,j)) + endif + endif + endif !max_delta_srestore_file + endif !min_ratio_srestore fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) @@ -420,7 +451,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)) & @@ -439,14 +470,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) @@ -641,7 +672,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 @@ -899,7 +930,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) @@ -949,7 +980,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 @@ -1036,7 +1067,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, # include "version_variable.h" character(len=40) :: mdl = "MOM_surface_forcing_mct" ! This module's name. character(len=48) :: stagger - character(len=48) :: flnam + character(len=80) :: varnam + character(len=240) :: flnam character(len=240) :: basin_file integer :: i, j, isd, ied, jsd, jed @@ -1068,7 +1100,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, & @@ -1148,9 +1180,27 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & "If true, the restoring of salinity is applied as a salt "//& "flux instead of as a freshwater flux.", default=.false.) - call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & - "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_FROM_FILE", CS%max_delta_srestore_file, & + "If true, read a file MAX_DELTA_SRESTORE_FILE containing the field "//& + "MAX_DELTA_SRESTORE_VARNAME for the maximum salinity difference used in "//& + "restoring terms. Where the field's value is negative turn off restoring when "//& + "the salinity difference magnitude exceeds abs(value).", default=.false.) + if (.not. CS%max_delta_srestore_file) then + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & + "The maximum salinity difference used in restoring terms.", & + units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) + else + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_FILE", flnam, & + "The path to the file containing the maximum salinity difference field.", & + default="max_delta_srestore.nc") + flnam = trim(CS%inputdir) // trim(flnam) + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_VARNAME", varnam, & + "The name of the maximum salinity difference variable in the input file.", & + default="max_delta_srestore") + CS%max_delta_srestore = 999.0 + call safe_alloc_ptr(CS%max_delta_srestore_2d,isd,ied,jsd,jed) + call MOM_read_data(flnam,varnam, CS%max_delta_srestore_2d, G%domain, timelevel=1) + endif call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & CS%mask_srestore_under_ice, & "If true, disables SSS restoring under sea-ice based on a frazil "//& @@ -1194,6 +1244,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "The maximum sst difference used in restoring terms.", & units="degC ", default=999.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "MIN_RATIO_SRESTORE", CS%min_ratio_srestore, & + "Turn off MAX_DELTA_SRESTORE where the ratio of SSS to restoring salinity "//& + "is less than this value.", units="nondim", default=0.0) + call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & "If true, read a file (temp_restore_mask) containing "//& "a mask for SST restoring.", default=.false.) @@ -1227,13 +1281,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 @@ -1327,7 +1381,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) @@ -1337,7 +1391,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) @@ -1403,7 +1457,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 a2d6ad29c8..372f4f32f0 100644 --- a/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 +++ b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 @@ -44,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 @@ -236,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 @@ -263,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 @@ -271,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 c7d758c8de..d55d70c116 100644 --- a/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 @@ -31,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 @@ -61,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 @@ -201,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 @@ -280,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. @@ -316,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) @@ -384,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) @@ -412,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 @@ -488,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 @@ -526,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) @@ -760,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 @@ -781,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/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index b12b1abd1a..f2d64fdaea 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -32,7 +32,7 @@ program Shelf_main use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid - use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe + use MOM_error_handler, only : MOM_set_verbosity, MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe 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_file_parser, only : close_param_file @@ -48,7 +48,7 @@ program Shelf_main 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 @@ -59,10 +59,12 @@ program Shelf_main use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS use MOM_forcing_type, only : forcing - use MOM_ice_shelf_initialize, only : initialize_ice_SMB + use MOM_ice_shelf, only : initialize_ice_SMB use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS - use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf + use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf, update_ice_SMB + use MOM_interp_infra, only : time_interp_extern_init + implicit none @@ -149,7 +151,7 @@ program Shelf_main character(len=9) :: month character(len=16) :: calendar = 'noleap' integer :: calendar_type=-1 - + integer :: verbosity integer :: unit, io_status, ierr logical :: symmetric @@ -172,6 +174,8 @@ program Shelf_main call MOM_infra_init() ; call io_infra_init() + call time_interp_extern_init() + ! These clocks are on the global pelist. initClock = cpu_clock_id( 'Initialization' ) mainClock = cpu_clock_id( 'Main loop' ) @@ -196,6 +200,9 @@ program Shelf_main ! Also calls the subroutine that opens run-time parameter files. call Get_MOM_Input(param_file, dirs) + call get_param(param_file, mod_name, "VERBOSITY", verbosity, default=5) + call MOM_set_verbosity(verbosity) + ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ice_solo.res')) then call open_ASCII_file(unit, trim(dirs%restart_input_dir)//'ice_solo.res', action=READONLY_FILE) @@ -205,11 +212,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 @@ -220,8 +227,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 @@ -292,7 +299,8 @@ program Shelf_main call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, & Start_time, dirs%output_directory, fluxes_in=fluxes, solo_ice_sheet_in=.true.) - call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) + + call initialize_ice_SMB(ice_shelf_CSp, fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) ! This is the end of the code that is the counterpart of MOM_initialization. call callTree_waypoint("End of ice shelf initialization.") @@ -303,8 +311,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) @@ -399,7 +407,7 @@ program Shelf_main ns = 1 ; ns_ice = 1 do while ((ns < nmax) .and. (Time < Time_end)) call callTree_enter("Main loop, Shelf_driver.F90", ns) - + call update_ice_SMB(ice_shelf_CSp, ocn_grid, fluxes%shelf_sfc_mass_flux, Time) ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time, fluxes_in=fluxes) @@ -413,12 +421,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 ae78956182..2396ab5813 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -105,7 +105,7 @@ module MOM_cap_mod #endif use mom_cap_profiling, only: cap_profiling_init, cap_profiling -implicit none; private +implicit none ; private public SetServices public SetVM @@ -433,7 +433,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, 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") @@ -508,7 +508,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (localPet == 0) call cap_profiling("mom", "InitializeAdvertise", "B") - if(write_runtimelog) timeiads = MPI_Wtime() + if (write_runtimelog) timeiads = MPI_Wtime() call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) @@ -573,7 +573,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 @@ -662,7 +662,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 @@ -947,7 +947,7 @@ 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") @@ -1046,7 +1046,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (localPet == 0) call cap_profiling("mom", "InitializeRealize", "B") - if(write_runtimelog) timeirls = MPI_Wtime() + if (write_runtimelog) timeirls = MPI_Wtime() call shr_log_setLogUnit (stdout) @@ -1255,7 +1255,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 @@ -1272,8 +1272,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 @@ -1299,7 +1299,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", & @@ -1344,8 +1344,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) @@ -1623,7 +1623,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (use_cdeps_inline) then call mom_inline_init(gcomp, clock, eMesh, localPet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + endif !--------------------------------- ! write out diagnostics @@ -1634,7 +1634,7 @@ 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") @@ -1671,7 +1671,7 @@ subroutine DataInitialize(gcomp, rc) if (localPet == 0) call cap_profiling("mom", "DataInitialize", "B") - if(write_runtimelog) timedis = MPI_Wtime() + 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) @@ -1733,7 +1733,7 @@ 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") @@ -1795,10 +1795,10 @@ subroutine ModelAdvance(gcomp, rc) if (localPet == 0) call cap_profiling("mom", "ModelAdvance", "B") - if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") - if(write_runtimelog) then + 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) @@ -1913,7 +1913,7 @@ subroutine ModelAdvance(gcomp, rc) 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 - end if + endif !--------------- ! Update MOM6 @@ -1958,7 +1958,7 @@ 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 @@ -1968,8 +1968,8 @@ subroutine ModelAdvance(gcomp, rc) ! turn off the alarm call ESMF_AlarmRingerOff(stop_alarm, rc=rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - end if + endif + endif #ifndef CESMCOUPLED call is_restart_fh(clock, restartfh_info, write_restartfh) @@ -2080,12 +2080,12 @@ 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") @@ -2319,7 +2319,7 @@ subroutine ocean_model_finalize(gcomp, rc) 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 @@ -2354,7 +2354,7 @@ subroutine ocean_model_finalize(gcomp, rc) 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 (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") diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index 2b686fcd52..a978b4906a 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -27,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 @@ -249,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) @@ -258,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) @@ -267,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) @@ -276,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) @@ -285,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) @@ -294,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) !---- @@ -302,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) @@ -391,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 @@ -545,9 +545,9 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, do i = isc, iec ig = i + ocean_grid%isc - isc !rotate - if(set_missing_stks_to_zero) then + 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 + 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 diff --git a/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90 b/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90 index ef62ac0cda..7b9b7595bd 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90 @@ -7,7 +7,7 @@ module MOM_cap_outputlog #ifdef CESMCOUPLED use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_SUCCESS -implicit none; private +implicit none ; private public :: outputlog_init, outputlog_run, outputlog_restart contains @@ -45,7 +45,7 @@ end subroutine outputlog_restart use shr_is_restart_fh_mod , only : log_restart_fh use netcdf -implicit none; private +implicit none ; private public :: outputlog_init, outputlog_run, outputlog_restart diff --git a/config_src/drivers/nuopc_cap/mom_cap_time.F90 b/config_src/drivers/nuopc_cap/mom_cap_time.F90 index f49ea133ff..3f5a303cc8 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_time.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_time.F90 @@ -22,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_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index b808228d2a..ef2c5d72fe 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -49,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 @@ -367,7 +368,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, & @@ -403,7 +404,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) @@ -444,11 +446,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 stochastic physics initialization call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & "If true, then stochastically perturb the thermodynamic "//& @@ -726,6 +735,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) @@ -1045,6 +1058,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 @@ -1180,7 +1196,7 @@ end subroutine get_ocean_grid !> Returns eps_omesh read from param file real function get_eps_omesh(OS) type(ocean_state_type), intent(in) :: OS - get_eps_omesh = OS%eps_omesh; return + get_eps_omesh = OS%eps_omesh end function !> Returns true if a stochastic restart file is needed 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 5d3bdc2462..88d802437e 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -126,7 +126,14 @@ module MOM_surface_forcing_nuopc !! criteria for salinity restoring. real :: ice_salt_concentration !< salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas + logical :: max_delta_srestore_file !< If true, apply a 2-dimensional maximum delta salinity + !! when restoring. The file should be + !! in inputdir/max_delta_srestore.nc and the field + !! should be named 'max_delta_srestore' + real, pointer, dimension(:,:) :: max_delta_srestore_2d => NULL() + !< Maximum delta salinity used for restoring [S ~> ppt] real :: max_delta_srestore !< maximum delta salinity used for restoring [S ~> ppt] + real :: min_ratio_srestore !< Minimum fraction of restoring salinity to preserve [nondim] real :: max_delta_trestore !< maximum delta sst used for restoring [C ~> degC] real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring by basin logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the @@ -414,7 +421,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + if (sfc_state%SSS(i,j) >= data_restore(i,j)*CS%min_ratio_srestore) then + if (.not. CS%max_delta_srestore_file) then + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + else + if (abs(delta_sss) > abs(CS%max_delta_srestore_2d(i,j))) then + if (CS%max_delta_srestore_2d(i,j) < 0.0) then + delta_sss = 0.0 !turn off restoring + else !clip restoring + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore_2d(i,j)) + endif + endif + endif !max_delta_srestore_file + endif !min_ratio_srestore fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 enddo ; enddo @@ -435,7 +454,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + if (sfc_state%SSS(i,j) >= data_restore(i,j)*CS%min_ratio_srestore) then + if (.not. CS%max_delta_srestore_file) then + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + else + if (abs(delta_sss) > abs(CS%max_delta_srestore_2d(i,j))) then + if (CS%max_delta_srestore_2d(i,j) < 0.0) then + delta_sss = 0.0 !turn off restoring + else !clip restoring + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore_2d(i,j)) + endif + endif + endif !max_delta_srestore_file + endif !min_ratio_srestore fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) @@ -626,7 +657,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 @@ -963,10 +994,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 @@ -1037,7 +1068,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) @@ -1086,7 +1117,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 @@ -1175,7 +1206,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, # include "version_variable.h" character(len=40) :: mdl = "MOM_surface_forcing_nuopc" ! This module's name. character(len=48) :: stagger - character(len=48) :: flnam + character(len=80) :: varnam + character(len=240) :: flnam character(len=240) :: basin_file integer :: i, j, isd, ied, jsd, jed @@ -1207,7 +1239,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, & @@ -1296,9 +1328,30 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & "If true, the restoring of salinity is applied as a salt "//& "flux instead of as a freshwater flux.", default=.false.) - call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & - "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_FROM_FILE", CS%max_delta_srestore_file, & + "If true, read a file MAX_DELTA_SRESTORE_FILE containing the field "//& + "MAX_DELTA_SRESTORE_VARNAME for the maximum salinity difference used in "//& + "restoring terms. Where the field's value is negative turn off restoring when "//& + "the salinity difference magnitude exceeds abs(value).", default=.false.) + if (.not. CS%max_delta_srestore_file) then + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & + "The maximum salinity difference used in restoring terms.", & + units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) + else + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_FILE", flnam, & + "The path to the file containing the maximum salinity difference field.", & + default="max_delta_srestore.nc") + flnam = trim(CS%inputdir) // trim(flnam) + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE_VARNAME", varnam, & + "The name of the maximum salinity difference variable in the input file.", & + default="max_delta_srestore") + CS%max_delta_srestore = 999.0 + call safe_alloc_ptr(CS%max_delta_srestore_2d,isd,ied,jsd,jed) + call MOM_read_data(flnam,varnam, CS%max_delta_srestore_2d, G%domain, timelevel=1) + endif + call get_param(param_file, mdl, "MIN_RATIO_SRESTORE", CS%min_ratio_srestore, & + "Turn off MAX_DELTA_SRESTORE where the ratio of SSS to restoring salinity "//& + "is less than this value.", units="nondim", default=0.0) call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & CS%mask_srestore_under_ice, & "If true, disables SSS restoring under sea-ice based on a frazil "//& @@ -1375,13 +1428,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 @@ -1492,7 +1545,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) @@ -1502,7 +1555,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) @@ -1568,7 +1621,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/time_utils.F90 b/config_src/drivers/nuopc_cap/time_utils.F90 index e2912206d1..b7fcce8393 100644 --- a/config_src/drivers/nuopc_cap/time_utils.F90 +++ b/config_src/drivers/nuopc_cap/time_utils.F90 @@ -20,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 7fee056ec6..b93a3fdb72 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -241,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 b1d1487bb1..a2cd327317 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -51,8 +51,8 @@ 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_initialize, only : initialize_ice_SMB + use MOM_ice_shelf, only : ice_shelf_query, adjust_ice_sheet_frazil + use MOM_ice_shelf, only : initialize_ice_SMB use MOM_interpolate, only : time_interp_external_init use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end @@ -60,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 @@ -254,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 @@ -308,7 +308,7 @@ program MOM6 if (override_shelf_fluxes) call data_override_init(Ocean_Domain_in=grid%domain%mpp_domain) call get_param(param_file, mod_name, "INITIALIZE_ICE_SHEET_SMB", & initialize_smb, "Read in a constant SMB for the ice sheet", default=.false.) - if (initialize_smb) call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, grid, US, param_file) + if (initialize_smb) call initialize_ice_SMB(ice_shelf_CSp, fluxes%shelf_sfc_mass_flux, grid, US, param_file) endif @@ -316,6 +316,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") @@ -347,8 +350,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) @@ -517,7 +520,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) @@ -526,7 +529,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 @@ -539,12 +542,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 @@ -628,10 +631,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) + ! This closes out the infrastructure, including clocks, I/O and message passing communicators. + call io_infra_end() ; call MOM_infra_end() + contains !> Write out the ocean solo restart file to the indicated path. diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 660f4d84e6..f474d3fb1a 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -36,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 @@ -283,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. @@ -1791,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, & @@ -2046,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/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index 109e0364ce..5caee49d57 100644 --- a/config_src/drivers/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -272,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 index dc079d4cff..dc7839a78f 100644 --- a/config_src/drivers/timing_tests/time_MOM_ANN.F90 +++ b/config_src/drivers/timing_tests/time_MOM_ANN.F90 @@ -26,9 +26,9 @@ program time_MOM_ANN 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 +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 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_reproducing_sum.F90 b/config_src/drivers/unit_tests/test_reproducing_sum.F90 index 2a9af42538..712c7e1e72 100644 --- a/config_src/drivers/unit_tests/test_reproducing_sum.F90 +++ b/config_src/drivers/unit_tests/test_reproducing_sum.F90 @@ -5,7 +5,7 @@ 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_coms, only : sum_across_PEs, max_across_PEs 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 @@ -95,13 +95,9 @@ program test_reproducing_sum 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 + 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. call MOM_mesg(mesg) endif diff --git a/config_src/external/database_comms/MOM_database_comms.F90 b/config_src/external/database_comms/MOM_database_comms.F90 index 90f866186a..4832b95e52 100644 --- a/config_src/external/database_comms/MOM_database_comms.F90 +++ b/config_src/external/database_comms/MOM_database_comms.F90 @@ -8,7 +8,7 @@ module MOM_database_comms 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 3997fe8baf..a20db2b2cb 100644 --- a/config_src/external/database_comms/database_client_interface.F90 +++ b/config_src/external/database_comms/database_client_interface.F90 @@ -6,7 +6,7 @@ module database_client_interface 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/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 2031487389..6be6e55d28 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -95,12 +95,12 @@ integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM !! describes the edges of this axis character(len=*), & optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 0 + !! by default. This is the index of the coarsening level. logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis !! id for use with scalars. - integer :: coarsening ! The degree of grid coarsening + integer :: coarsening ! The degree of grid coarsening, this is the index of an array of coarsening levels if (present(null_axis)) then ; if (null_axis) then ! Return the special null axis id for scalars @@ -109,17 +109,15 @@ integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM endif ; endif if (present(MOM_domain)) then - coarsening = 1 ; if (present(coarsen)) coarsening = coarsen - if (coarsening == 1) then + coarsening = 0 ; if (present(coarsen)) coarsening = coarsen + if (coarsening == 0) then MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & direction=direction, set_name=set_name, edges=edges, & domain2=MOM_domain%mpp_domain, domain_position=position) - elseif (coarsening == 2) then + else MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & direction=direction, set_name=set_name, edges=edges, & - domain2=MOM_domain%mpp_domain_d2, domain_position=position) - else - call MOM_error(FATAL, "diag_axis_init called with an invalid value of coarsen.") + domain2=MOM_domain%mpp_domain_d(coarsening), domain_position=position) endif else if (present(coarsen)) then ; if (coarsen /= 1) then diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 1031f07d56..97924ee065 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -135,7 +135,7 @@ module MOM_domain_infra character(len=64) :: name !< The name of this domain type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos !! on this processor, centered at h points. - type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos + type(domain2D), pointer :: mpp_domain_d(:) => NULL() !< A coarse FMS domain with halos !! on this processor, centered at h points. integer :: niglobal !< The total horizontal i-domain size. integer :: njglobal !< The total horizontal j-domain size. @@ -1215,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) @@ -1234,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) @@ -1253,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) @@ -1377,7 +1377,6 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_d2) endif MOM_dom%name = "MOM" ; if (present(domain_name)) MOM_dom%name = trim(domain_name) @@ -1445,12 +1444,6 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain) - !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. - !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get - !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 - ! call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, halo_size=(MOM_dom%nihalo/2), coarsen=2) - call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, coarsen=2) - end subroutine create_MOM_domain !> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type @@ -1460,6 +1453,7 @@ subroutine deallocate_MOM_domain(MOM_domain, cursory) logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated !! with the underlying infrastructure logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure + integer :: n invasive = .true. ; if (present(cursory)) invasive = .not.cursory @@ -1468,9 +1462,11 @@ subroutine deallocate_MOM_domain(MOM_domain, cursory) if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) deallocate(MOM_domain%mpp_domain) endif - if (associated(MOM_domain%mpp_domain_d2)) then - if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) - deallocate(MOM_domain%mpp_domain_d2) + if (associated(MOM_domain%mpp_domain_d)) then + if (invasive) then ; do n=1,size(MOM_domain%mpp_domain_d) + call mpp_deallocate_domain(MOM_domain%mpp_domain_d(n)) + enddo ; endif + deallocate(MOM_domain%mpp_domain_d) endif if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) deallocate(MOM_domain) @@ -1580,7 +1576,6 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_d2) endif ! Save the extra data for creating other domains of different resolution that overlay this domain @@ -1702,7 +1697,6 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain endif call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain, xextent=exni, yextent=exnj) - call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, domain_name=MOM_dom%name, coarsen=2) end subroutine clone_MD_to_MD @@ -1823,8 +1817,8 @@ subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This !! can be useful for some types of debugging with !! dynamic memory allocation. The default is 0. - integer, optional, intent(in) :: coarsen !< A factor by which the grid is coarsened. - !! The default is 1, for no coarsening. + integer, optional, intent(in) :: coarsen !< The index of the factor by which the grid is coarsened. + !! The default is 0, for no coarsening. ! Local variables integer :: isg_, ieg_, jsg_, jeg_ @@ -1834,20 +1828,18 @@ subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, local = .true. ; if (present(local_indexing)) local = local_indexing ind_off = 0 ; if (present(index_offset)) ind_off = index_offset - coarsen_lev = 1 ; if (present(coarsen)) coarsen_lev = coarsen + coarsen_lev = 0 ; if (present(coarsen)) coarsen_lev = coarsen - if (coarsen_lev == 1) then + if (coarsen_lev == 0) then call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) call mpp_get_global_domain(Domain%mpp_domain, isg_, ieg_, jsg_, jeg_) - elseif (coarsen_lev == 2) then - if (.not.associated(Domain%mpp_domain_d2)) call MOM_error(FATAL, & - "get_domain_extent called with coarsen=2, but Domain%mpp_domain_d2 is not associated.") - call mpp_get_compute_domain(Domain%mpp_domain_d2, isc, iec, jsc, jec) - call mpp_get_data_domain(Domain%mpp_domain_d2, isd, ied, jsd, jed) - call mpp_get_global_domain(Domain%mpp_domain_d2, isg_, ieg_, jsg_, jeg_) else - call MOM_error(FATAL, "get_domain_extent called with an unsupported level of coarsening.") + if (.not.associated(Domain%mpp_domain_d)) call MOM_error(FATAL, & + "get_domain_extent called with coarsen_lev, but Domain%mpp_domain_d(coarsen_lev) is not associated.") + call mpp_get_compute_domain(Domain%mpp_domain_d(coarsen_lev), isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain_d(coarsen_lev), isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain_d(coarsen_lev), isg_, ieg_, jsg_, jeg_) endif if (local) then diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index 3069f1c644..3ce0834534 100644 --- a/config_src/infra/FMS1/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -6,15 +6,14 @@ module MOM_interp_infra use MOM_domain_infra, only : MOM_domain_type, domain2d -use MOM_io, only : axis_info -use MOM_io, only : set_axis_info use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type use mpp_io_mod, only : axistype, mpp_get_axis_data, mpp_get_atts use time_interp_external_mod, only : time_interp_external use time_interp_external_mod, only : init_external_field, time_interp_external_init use time_interp_external_mod, only : get_external_field_size -use time_interp_external_mod, only : get_external_field_axes, get_external_field_missing +use time_interp_external_mod, only : get_external_field_axes +use time_interp_external_mod, only : get_external_field_missing implicit none ; private @@ -160,34 +159,13 @@ function get_extern_field_size(index) end function get_extern_field_size -!> get axes of an external field from field index -function get_extern_field_axes(index) result(axes) - - integer, intent(in) :: index !< FMS interpolation field index - type(axis_info) :: axes(4) !< MOM IO field axes handle - - type(axistype), dimension(4) :: fms_axes(4) - ! FMS axis handles - character(len=32) :: name - ! Axis name - real, allocatable :: points(:) - ! Axis line points - integer :: length - ! Axis line point length - integer :: i - ! Loop index - - fms_axes = get_external_field_axes(index) - - do i = 1, 4 - call mpp_get_atts(fms_axes(i), name=name, len=length) +!> get size of an external field from field index +function get_extern_field_axes(index) - allocate(points(length)) - call mpp_get_axis_data(fms_axes(i), points) - call set_axis_info(axes(i), name=name, ax_data=points) + integer, intent(in) :: index !< field index + type(axistype) :: get_extern_field_axes(4) !< field size - deallocate(points) - enddo + get_extern_field_axes = get_external_field_axes(index) end function get_extern_field_axes @@ -204,25 +182,27 @@ end function get_extern_field_missing !> Get information about the external fields. subroutine get_external_field_info(field, size, axes, missing) - type(external_field), intent(in) :: field !< Handle for time interpolated external - !! field returned from a previous - !! call to init_external_field() - integer, optional, intent(inout) :: size(4) !< Dimension sizes for the input data - type(axis_info), optional, intent(inout) :: axes(4) !< Axis types for the input data - real, optional, intent(inout) :: missing !< Missing value for the input data + type(external_field), intent(in) :: field + !< Handle for time interpolated external field returned from a previous + !! call to init_external_field() + integer, optional, intent(inout) :: size(4) + !< Dimension sizes for the input data + type(axistype), optional, intent(inout) :: axes(4) + !< Axis types for the input data + real, optional, intent(inout) :: missing + !< Missing value for the input data if (present(size)) then - size(1:4) = get_extern_field_size(field%id) + size(:) = get_extern_field_size(field%id) endif if (present(axes)) then - axes(1:4) = get_extern_field_axes(field%id) + axes(:) = get_extern_field_axes(field%id) endif if (present(missing)) then missing = get_extern_field_missing(field%id) endif - end subroutine get_external_field_info diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index 9bff64363a..e765918f9e 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -16,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 @@ -34,7 +35,8 @@ module MOM_io_infra public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix public :: read_field, read_vector, write_metadata, write_field -public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: field_exists, get_field_atts, get_field_size, read_field_chksum +public :: get_axis_size, get_axis_data, set_axis_data public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version public :: stdout_if_root ! These types are inherited from underlying infrastructure code, to act as containers for @@ -405,14 +407,47 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) end subroutine get_field_size -!> Extracts and returns the axis data stored in an axistype. -subroutine get_axis_data( axis, dat ) - type(axistype), intent(in) :: axis !< An axis type - real, dimension(:), intent(out) :: dat !< The data in the axis variable - call mpp_get_axis_data( axis, dat ) +!> Get the size of the axis +function get_axis_size(axis) result(axis_size) + type(axistype), intent(in) :: axis + !< Infra axis + integer :: axis_size + !< Axis size + + axis_size = mpp_get_axis_length(axis) +end function get_axis_size + + +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data(axis, axis_name, axis_data) + type(axistype), intent(in) :: axis + !< Infra axis + character(len=256), intent(out) :: axis_name + !< Axis name + real, dimension(:), intent(out) :: axis_data + !< Axis points + + call mpp_get_atts(axis, name=axis_name) + call mpp_get_axis_data(axis, axis_data) end subroutine get_axis_data + +! NOTE: Unused, but provided to match the FMS2 API + +!> Return a new axistype based on axis specs +subroutine set_axis_data(axis, axis_name, axis_data) + type(axistype), intent(inout) :: axis + !< Target axis + character(len=256), intent(in) :: axis_name + !< Target axis name + real, intent(in) :: axis_data(:) + !< Target axis values + + call MOM_error(FATAL, "set_axis_data in FMS1 is not yet implemented.") +end subroutine set_axis_data + + !> This routine uses the fms_io subroutine read_data to read a scalar named !! "fieldname" from a single or domain-decomposed file "filename". subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, & diff --git a/config_src/infra/FMS1/MOM_time_manager.F90 b/config_src/infra/FMS1/MOM_time_manager.F90 index 7ec71cc37c..c03390a4bf 100644 --- a/config_src/infra/FMS1/MOM_time_manager.F90 +++ b/config_src/infra/FMS1/MOM_time_manager.F90 @@ -19,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(<=) @@ -28,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 @@ -36,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) @@ -51,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_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index 2648900493..cf6aae9bf2 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -97,12 +97,12 @@ integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM !! describes the edges of this axis character(len=*), & optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 0 + !! by default. This is the index of the coarsening level. logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis !! id for use with scalars. - integer :: coarsening ! The degree of grid coarsening + integer :: coarsening ! The degree of grid coarsening, this is the index of an array of coarsening levels if (present(null_axis)) then ; if (null_axis) then ! Return the special null axis id for scalars @@ -111,17 +111,15 @@ integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM endif ; endif if (present(MOM_domain)) then - coarsening = 1 ; if (present(coarsen)) coarsening = coarsen - if (coarsening == 1) then + coarsening = 0 ; if (present(coarsen)) coarsening = coarsen + if (coarsening == 0) then MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & direction=direction, set_name=set_name, edges=edges, & domain2=MOM_domain%mpp_domain, domain_position=position) - elseif (coarsening == 2) then + else MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & direction=direction, set_name=set_name, edges=edges, & - domain2=MOM_domain%mpp_domain_d2, domain_position=position) - else - call MOM_error(FATAL, "diag_axis_init called with an invalid value of coarsen.") + domain2=MOM_domain%mpp_domain_d(coarsening), domain_position=position) endif else if (present(coarsen)) then ; if (coarsen /= 1) then diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 4065628635..bd524fa4a9 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -133,7 +133,7 @@ module MOM_domain_infra character(len=64) :: name !< The name of this domain type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos !! on this processor, centered at h points. - type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos + type(domain2D), pointer :: mpp_domain_d(:) => NULL() !< A coarse FMS domain with halos !! on this processor, centered at h points. integer :: niglobal !< The total horizontal i-domain size. integer :: njglobal !< The total horizontal j-domain size. @@ -1214,7 +1214,7 @@ subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1233,7 +1233,7 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1252,7 +1252,7 @@ subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1371,14 +1371,12 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. - integer :: xhalo_d2, yhalo_d2 character(len=200) :: mesg ! A string for use in error messages logical :: mask_table_exists ! Mask_table is present and the file it points to exists if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_d2) endif MOM_dom%name = "MOM" ; if (present(domain_name)) MOM_dom%name = trim(domain_name) @@ -1446,11 +1444,6 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain) - !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. - !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get - !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 - ! call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, halo_size=(MOM_dom%nihalo/2), coarsen=2) - call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, coarsen=2) end subroutine create_MOM_domain !> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type @@ -1460,6 +1453,7 @@ subroutine deallocate_MOM_domain(MOM_domain, cursory) logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated !! with the underlying infrastructure logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure + integer :: n invasive = .true. ; if (present(cursory)) invasive = .not.cursory @@ -1468,9 +1462,11 @@ subroutine deallocate_MOM_domain(MOM_domain, cursory) if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain) deallocate(MOM_domain%mpp_domain) endif - if (associated(MOM_domain%mpp_domain_d2)) then - if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2) - deallocate(MOM_domain%mpp_domain_d2) + if (associated(MOM_domain%mpp_domain_d)) then + if (invasive) then ; do n=1,size(MOM_domain%mpp_domain_d) + call mpp_deallocate_domain(MOM_domain%mpp_domain_d(n)) + enddo ; endif + deallocate(MOM_domain%mpp_domain_d) endif if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) deallocate(MOM_domain) @@ -1582,7 +1578,6 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_d2) endif ! Save the extra data for creating other domains of different resolution that overlay this domain @@ -1704,7 +1699,6 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain endif call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain, xextent=exni, yextent=exnj) - call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, domain_name=MOM_dom%name, coarsen=2) end subroutine clone_MD_to_MD @@ -1825,8 +1819,8 @@ subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This !! can be useful for some types of debugging with !! dynamic memory allocation. The default is 0. - integer, optional, intent(in) :: coarsen !< A factor by which the grid is coarsened. - !! The default is 1, for no coarsening. + integer, optional, intent(in) :: coarsen !< The index of the factor by which the grid is coarsened. + !! The default is 0, for no coarsening. ! Local variables integer :: isg_, ieg_, jsg_, jeg_ @@ -1836,20 +1830,18 @@ subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, local = .true. ; if (present(local_indexing)) local = local_indexing ind_off = 0 ; if (present(index_offset)) ind_off = index_offset - coarsen_lev = 1 ; if (present(coarsen)) coarsen_lev = coarsen + coarsen_lev = 0 ; if (present(coarsen)) coarsen_lev = coarsen - if (coarsen_lev == 1) then + if (coarsen_lev == 0) then call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) call mpp_get_global_domain(Domain%mpp_domain, isg_, ieg_, jsg_, jeg_) - elseif (coarsen_lev == 2) then - if (.not.associated(Domain%mpp_domain_d2)) call MOM_error(FATAL, & - "get_domain_extent called with coarsen=2, but Domain%mpp_domain_d2 is not associated.") - call mpp_get_compute_domain(Domain%mpp_domain_d2, isc, iec, jsc, jec) - call mpp_get_data_domain(Domain%mpp_domain_d2, isd, ied, jsd, jed) - call mpp_get_global_domain(Domain%mpp_domain_d2, isg_, ieg_, jsg_, jeg_) else - call MOM_error(FATAL, "get_domain_extent called with an unsupported level of coarsening.") + if (.not.associated(Domain%mpp_domain_d)) call MOM_error(FATAL, & + "get_domain_extent called with coarsen_lev, but Domain%mpp_domain_d(coarsen_lev) is not associated.") + call mpp_get_compute_domain(Domain%mpp_domain_d(coarsen_lev), isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain_d(coarsen_lev), isd, ied, jsd, jed) + call mpp_get_global_domain(Domain%mpp_domain_d(coarsen_lev), isg_, ieg_, jsg_, jeg_) endif if (local) then diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index 9b745ad001..3645e1db3a 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -6,10 +6,10 @@ module MOM_interp_infra use MOM_domain_infra, only : MOM_domain_type, domain2d -use MOM_io, only : axis_info -use MOM_io, only : get_var_axes_info +use MOM_io_infra, only : axistype +use MOM_io_infra, only : set_axis_data use MOM_time_manager, only : time_type -use MOM_error_handler, only : MOM_error, FATAL +use MOM_error_infra, only : MOM_error => MOM_err, FATAL use MOM_string_functions, only : lowercase use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type use netcdf_io_mod, only : FmsNetcdfFile_t, netcdf_file_open, netcdf_file_close @@ -19,6 +19,17 @@ module MOM_interp_infra use time_interp_external2_mod, only : get_external_field_size use time_interp_external2_mod, only : get_external_field_missing +! Use primitive netCDF, to replicate get_var_axes_info() +use netcdf, only : nf90_open +use netcdf, only : nf90_close +use netcdf, only : nf90_inq_varid +use netcdf, only : nf90_inquire_variable +use netcdf, only : nf90_inquire_dimension +use netcdf, only : nf90_get_var +use netcdf, only : NF90_NOWRITE +use netcdf, only : NF90_NOERR + + implicit none ; private public :: horiz_interp_type, horizontal_interp_init @@ -155,10 +166,115 @@ end function get_extern_field_size !> get axes of an external field from field index function get_extern_field_axes(field) result(axes) - type(external_field), intent(in) :: field !< Field handle - type(axis_info), dimension(4) :: axes !< Field axes + type(external_field), intent(in) :: field + !< Field handle + type(axistype), dimension(4) :: axes + !< Field axes + + integer :: ndims + ! Number of variable dimensions + integer, allocatable :: dims(:) + ! netCDF dimension IDs of variable + character(len=256) :: dim_name + ! Dimension name + integer :: dim_len + ! Dimension length + integer :: var_dim + ! netCDF ID of the variable associated with dimension of the same name + real, allocatable :: axis_points(:) + ! Axis values + + integer :: ncid + ! netCDF file ID + integer :: varid + ! netCDF variable ID + integer :: rc + ! netCDF return code + + ! netCDF requires the following to be length-1 arrays + integer :: nc_start(1) + ! netCDF start index + integer :: nc_count(1) + ! netCDF index count + + integer :: d + ! Dimension index + character(len=2) :: d_str + ! Display string of d + + ! This is a reimplementation of get_var_axes_info(), maybe it can be used + ! by the existing get_var_axes_info() ? + + ! Open field%filename + rc = nf90_open(trim(field%filename), NF90_NOWRITE, ncid) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error opening file " // trim(field%filename) // ".") + + ! Use field%label to get the netCDF varid + rc = nf90_inq_varid(ncid, trim(field%label), varid) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error finding variable " // trim(field%label) & + // " in " // trim(field%filename) // ".") + + ! Use the varid to get the number of dims (ndims) and their IDs (dims(:)) + ! Verify that ndims >= 3 + rc = nf90_inquire_variable(ncid, varid, ndims=ndims) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error querying variable " // trim(field%label) & + // " in " // trim(field%filename) // ".") + + if (ndims < 3) & + call MOM_error(FATAL, trim(field%label) // " in " // trim(field%filename) & + // " has too few dimensions to be read as a 3D array.") + + allocate(dims(ndims)) + + rc = nf90_inquire_variable(ncid, varid, dimids=dims) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error querying variable " // trim(field%label) & + // " in " // trim(field%filename) // ".") + + do d=1,ndims + ! Determine the name of each dimension + rc = nf90_inquire_dimension(ncid, dims(d), dim_name, len=dim_len) + if (rc /= NF90_NOERR) then + write(d_str, '(i0)') d + call MOM_error(FATAL, "Error querying dimension " // trim(d_str) & + // " of " // trim(field%label) // " in " // trim(field%filename) & + // ".") + endif + + ! Now locate a variable with the same name as the dimension (e.g. "x") + rc = nf90_inq_varid(ncid, dim_name, var_dim) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error finding dimension variable " & + // trim(dim_name) // " of " // trim(field%label) // " in " & + // trim(field%filename)) + + allocate(axis_points(dim_len)) + + ! Get the dimensional axis values + nc_start(1) = 1 + nc_count(1) = dim_len + rc = nf90_get_var(ncid, var_dim, axis_points, nc_start, nc_count) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error reading dimension " // trim(dim_name) & + // " axis data of " // trim(field%label) // " in " & + // trim(field%filename)) + + ! write via set_axis_info() equivalent for axistype + call set_axis_data(axes(d), dim_name, axis_points) + + deallocate(axis_points) + enddo + + deallocate(dims) + + ! Close external file + rc = nf90_close(ncid) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error closing file "//trim(field%filename)//".") - call get_var_axes_info(field%filename, field%label, axes) end function get_extern_field_axes @@ -175,25 +291,27 @@ end function get_extern_field_missing !> Get information about the external fields. subroutine get_external_field_info(field, size, axes, missing) - type(external_field), intent(in) :: field !< Handle for time interpolated external - !! field returned from a previous - !! call to init_external_field() - integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data - type(axis_info), dimension(4), optional, intent(inout) :: axes !< Axis types for the input data - real, optional, intent(inout) :: missing !< Missing value for the input data + type(external_field), intent(in) :: field + !< handle for time interpolated external field returned from a previous + !! call to init_external_field() + integer, optional, intent(inout) :: size(4) + !< Dimension sizes for the input data + type(axistype), optional, intent(inout) :: axes(4) + !< Axis types for the input data + real, optional, intent(inout) :: missing + !< Missing value for the input data if (present(size)) then - size(1:4) = get_extern_field_size(field%id) + size(:) = get_extern_field_size(field%id) endif if (present(axes)) then - axes(1:4) = get_extern_field_axes(field) + axes(:) = get_extern_field_axes(field) endif if (present(missing)) then missing = get_extern_field_missing(field%id) endif - end subroutine get_external_field_info diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 3e69d110ff..c16e34e2e3 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -8,8 +8,6 @@ module MOM_io_infra use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE -use MOM_string_functions, only : lowercase - use fms2_io_mod, only : fms2_open_file => open_file, check_if_open, fms2_close_file => close_file use fms2_io_mod, only : fms2_flush_file => flush_file use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data @@ -48,7 +46,8 @@ module MOM_io_infra public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix public :: read_field, read_vector, write_metadata, write_field -public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: field_exists, get_field_atts, get_field_size, read_field_chksum +public :: get_axis_size, get_axis_data, set_axis_data public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version public :: stdout_if_root ! These types act as containers for information about files, fields and axes, respectively, @@ -717,21 +716,62 @@ function find_index(vec) result(loc) end function find_index +!> Get the axis size from an axistype +function get_axis_size(axis) result(axis_size) + type(axistype), intent(in) :: axis + !< Infra axis + integer :: axis_size + !< Axis size + + axis_size = size(axis%ax_data) +end function get_axis_size + + !> Extracts and returns the axis data stored in an axistype. -subroutine get_axis_data( axis, dat ) - type(axistype), intent(in) :: axis !< An axis type - real, dimension(:), intent(out) :: dat !< The data in the axis variable +subroutine get_axis_data(axis, axis_name, axis_data) + type(axistype), intent(in) :: axis + !< Infra axis + character(len=256), intent(out) :: axis_name + !< Axis name + real, dimension(:), intent(out) :: axis_data + !< Axis points integer :: i - ! This routine might not be needed for MOM6. if (allocated(axis%ax_data)) then - if (size(axis%ax_data) > size(dat)) call MOM_error(FATAL, & - "get_axis_data called with too small of an output data array for "//trim(axis%name)) - do i=1,size(axis%ax_data) ; dat(i) = axis%ax_data(i) ; enddo + if (size(axis%ax_data) > size(axis_data)) & + call MOM_error(FATAL, "get_axis_data called with too small of an " & + // "output data array for " // trim(axis%name) // ".") + do i=1,size(axis%ax_data) + axis_data(i) = axis%ax_data(i) + enddo endif + + axis_name = axis%name end subroutine get_axis_data + +!> Return a new axistype based on axis specs +subroutine set_axis_data(axis, axis_name, axis_data) + type(axistype), intent(inout) :: axis + !< Target axis + character(len=256), intent(in) :: axis_name + !< Target axis name + real, intent(in) :: axis_data(:) + !< Target axis values + + axis%name = axis_name + + if (allocated(axis%ax_data)) deallocate(axis%ax_data) + allocate(axis%ax_data(size(axis_data))) + + axis%ax_data(:) = axis_data(:) + + ! NOTE: We do not yet consider domain-decomposed axes. + axis%domain_decomposed = .false. +end subroutine set_axis_data + + !> This routine uses the fms_io subroutine read_data to read a scalar named !! "fieldname" from a single or domain-decomposed file "filename". subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, & @@ -2038,4 +2078,25 @@ function find_unlimited_dimension_name(fileobj) result(label) label = '' end function find_unlimited_dimension_name +! NOTE: `lowercase is duplicated from `src/framework/MOM_string_functions.F90` +! in order to avoid any dependency of the infra on the framework. + +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. +function lowercase(input_string) + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: lowercase !< The modified output string +! This function returns a string in which all uppercase letters have been +! replaced by their lowercase counterparts. It is loosely based on the +! lowercase function in mpp_util.F90. + integer, parameter :: co=iachar('a')-iachar('A') ! case offset + integer :: k + + lowercase = input_string + do k=1, len_trim(input_string) + if (lowercase(k:k) >= 'A' .and. lowercase(k:k) <= 'Z') & + lowercase(k:k) = achar(ichar(lowercase(k:k))+co) + enddo +end function lowercase + end module MOM_io_infra diff --git a/config_src/infra/FMS2/MOM_time_manager.F90 b/config_src/infra/FMS2/MOM_time_manager.F90 index 7ec71cc37c..c03390a4bf 100644 --- a/config_src/infra/FMS2/MOM_time_manager.F90 +++ b/config_src/infra/FMS2/MOM_time_manager.F90 @@ -19,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(<=) @@ -28,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 @@ -36,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) @@ -51,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/docs/.gitignore b/docs/.gitignore index e8b6a0513b..a9246f1e36 100644 --- a/docs/.gitignore +++ b/docs/.gitignore @@ -16,3 +16,8 @@ xml # Citation output bib*.aux citelist.doc* + + +# Python bytecode cache from the vendored _ext/autodoc_doxygen extension +__pycache__ +*.pyc diff --git a/docs/Doxyfile_rtd b/docs/Doxyfile_rtd index b389f1aeb7..33585285c7 100644 --- a/docs/Doxyfile_rtd +++ b/docs/Doxyfile_rtd @@ -873,7 +873,8 @@ RECURSIVE = YES # Note that relative paths are relative to the directory from which doxygen is # run. -EXCLUDE = ../src/equation_of_state/TEOS10 +EXCLUDE = ../src/equation_of_state/TEOS10 \ + ../src/parameterizations/CVmix # The EXCLUDE_SYMLINKS tag can be used to select whether or not files or # directories that are symbolic links (a Unix file system feature) are excluded @@ -1955,7 +1956,7 @@ XML_OUTPUT = xml # The default value is: YES. # This tag requires that the tag GENERATE_XML is set to YES. -XML_PROGRAMLISTING = NO +XML_PROGRAMLISTING = YES #--------------------------------------------------------------------------- # Configuration options related to the DOCBOOK output diff --git a/docs/Makefile b/docs/Makefile index 5729f73d90..69f4fddf1c 100644 --- a/docs/Makefile +++ b/docs/Makefile @@ -25,7 +25,7 @@ endif # Internal variables. PAPEROPT_a4 = -D latex_paper_size=a4 PAPEROPT_letter = -D latex_paper_size=letter -ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . +ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) # the i18n builder cannot share the environment and doctrees with the others I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . @@ -65,38 +65,45 @@ $(BUILDDIR): mkdir -p $@ html: $(DOXYGENBIN) $(BUILDDIR) - $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html + $(SPHINXBUILD) -M html . $(BUILDDIR) $(ALLSPHINXOPTS) -j auto +# Optional equation post-processing (was a patch in jr3cermak/sphinx@v3.2.1mom6.4 +# applied to sphinx/cmd/build.py); now invoked from the Makefile so we can run +# against stock upstream Sphinx. The nortd target below has the same hook. +ifeq ($(UPDATEHTMLEQS), Y) + @echo "Post processing equations." + @python3 ./postProcessEquations.py -d $(BUILDDIR) -p html -b sphinx -s index.html $(UPDATEHTMLEQSVERBOSE) +endif @echo @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." dirhtml: - $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml + $(SPHINXBUILD) -M dirhtml . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." singlehtml: - $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml + $(SPHINXBUILD) -M singlehtml . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." pickle: - $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle + $(SPHINXBUILD) -M pickle . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; now you can process the pickle files." json: - $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json + $(SPHINXBUILD) -M json . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; now you can process the JSON files." htmlhelp: - $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp + $(SPHINXBUILD) -M htmlhelp . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; now you can run HTML Help Workshop with the" \ ".hhp project file in $(BUILDDIR)/htmlhelp." qthelp: - $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp + $(SPHINXBUILD) -M qthelp . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; now you can run "qcollectiongenerator" with the" \ ".qhcp project file in $(BUILDDIR)/qthelp, like this:" @@ -105,7 +112,7 @@ qthelp: @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/MOM6.qhc" devhelp: - $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp + $(SPHINXBUILD) -M devhelp . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished." @echo "To view the help file:" @@ -114,48 +121,48 @@ devhelp: @echo "# devhelp" epub: - $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub + $(SPHINXBUILD) -M epub . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The epub file is in $(BUILDDIR)/epub." latex: $(DOXYGENBIN) $(BUILDDIR) - $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + $(SPHINXBUILD) -M latex . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." @echo "Run \`make' in that directory to run these through (pdf)latex" \ "(use \`make latexpdf' here to do that automatically)." latexpdf: $(DOXYGENBIN) $(BUILDDIR) - $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + $(SPHINXBUILD) -M latex . $(BUILDDIR) $(ALLSPHINXOPTS) @echo "Running LaTeX files through pdflatex..." $(MAKE) -C $(BUILDDIR)/latex LATEXMKOPTS="-f -silent" all-pdf @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." latexpdfja: - $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + $(SPHINXBUILD) -M latex . $(BUILDDIR) $(ALLSPHINXOPTS) @echo "Running LaTeX files through platex and dvipdfmx..." $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." text: - $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text + $(SPHINXBUILD) -M text . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The text files are in $(BUILDDIR)/text." man: - $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man + $(SPHINXBUILD) -M man . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The manual pages are in $(BUILDDIR)/man." texinfo: - $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo + $(SPHINXBUILD) -M texinfo . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo." @echo "Run \`make' in that directory to run these through makeinfo" \ "(use \`make info' here to do that automatically)." info: - $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo + $(SPHINXBUILD) -M texinfo . $(BUILDDIR) $(ALLSPHINXOPTS) @echo "Running Texinfo files through makeinfo..." make -C $(BUILDDIR)/texinfo info @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo." @@ -166,28 +173,28 @@ gettext: @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale." changes: - $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes + $(SPHINXBUILD) -M changes . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "The overview file is in $(BUILDDIR)/changes." linkcheck: - $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck + $(SPHINXBUILD) -M linkcheck . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Link check complete; look for any errors in the above output " \ "or in $(BUILDDIR)/linkcheck/output.txt." doctest: - $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest + $(SPHINXBUILD) -M doctest . $(BUILDDIR) $(ALLSPHINXOPTS) @echo "Testing of doctests in the sources finished, look at the " \ "results in $(BUILDDIR)/doctest/output.txt." xml: - $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml + $(SPHINXBUILD) -M xml . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The XML files are in $(BUILDDIR)/xml." pseudoxml: - $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml + $(SPHINXBUILD) -M pseudoxml . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml." diff --git a/docs/README.md b/docs/README.md index 6467aa06ab..de7b66531e 100644 --- a/docs/README.md +++ b/docs/README.md @@ -250,9 +250,11 @@ added to the RTD administrative interface if you want to trigger post processing If `UPDATEHTMLEQSVERBOSE` is set to `-v` this will turn on verbose printing for the post processor. -NOTE: These options affect solo doxygen html processing only for the `make nortd` option. For sphinx, they are -utilized in the sphinx python module to handle post processing and are not part of the Makefile. This was done -as RTD runs sphinx processing directly using `sphinx-build` and not the Makefile. +The post-processing hook is invoked from the `Makefile` for both the +`make nortd` (doxygen html) and `make html` (sphinx html) targets. RTD, +which runs `sphinx-build` directly without using this Makefile, will not +trigger the hook automatically; if equation post-processing is desired +on RTD it must be run as a separate step from the RTD build configuration. ##### PAPER @@ -317,18 +319,27 @@ pip install -r requirements.txt You may need to use `pip3` to install requirements for python3. -Requirements: -- sphinx -- sphinx-rtd-theme -- sphinx-bibtex -- sphinx-fortran -- sphinxcontrib\_autodox-doxygen -- flint -- lxml -- numpy -- future - -For machines that need to build future, numpy or lxml, these packages are required: +The full pinned set lives in `requirements.txt`. The current toolchain +uses stock upstream Sphinx 8.x from PyPI: + +- `sphinx>=8,<9` +- `sphinx-rtd-theme` +- `sphinxcontrib-bibtex` +- `lxml` (used by the vendored `_ext/autodoc_doxygen` extension to + parse the Doxygen XML output) +- `numpy` +- `sphinx-fortran` from the upstream `VACUMM/sphinx-fortran` repository, + pinned to a specific commit (upstream has not cut a PyPI release past + 1.1.1 but the master branch has continued fixes) +- `six`, still required at module load time by the pinned `sphinx-fortran` + commit + +The `sphinxcontrib-autodoc_doxygen` Sphinx extension that was previously +pulled in as a separate fork is now vendored in-tree under +`docs/_ext/autodoc_doxygen/`; nothing extra needs to be installed for it. + +For machines that need to build numpy or lxml from source, these packages +are required: - Cython - wheel @@ -343,8 +354,8 @@ PDF generation requires the following packages ### doxygen You may choose to download the [source](https://www.doxygen.nl/download.html). - -Latest is `doxygen-1.8.20.src.tar.gz`. +The example below uses `1.8.20` but you can substitute any compatible +release tarball. ```bash tar xzf doxygen-1.8.20.src.tar.gz @@ -357,15 +368,17 @@ sudo make install ``` The makefile for doxygen attempts to install the compiled version into /usr/local/bin. -You can link to a specific executable within the virtual environment. At this point we -also recommend renaming `doxygen` to `doxygen-1.8.20` within `/usr/local/bin`. +You can link to a specific executable within the virtual environment. -NOTE: The makefile for the documentation framework will attempt to compile a local doxygen -binary of version 1.8.13 if a binary cannot be found in the `$PATH`. +NOTE: If a doxygen binary is not found in `$PATH`, the documentation Makefile +will attempt to clone and compile its own copy of doxygen from source. The +default release pulled in this fallback path is set by `DOXYGEN_RELEASE` in +the Makefile (currently `Release_1_8_13`); pass a different value to override. #### Testing -A lot of manual testing has been completed using the following versions: +The toolchain is known to work with doxygen versions in the 1.8.x and 1.9.x +series. Older manual testing was performed against: * 1.8.13 * 1.8.14 * 1.8.19 @@ -377,7 +390,9 @@ The [Read the Docs](https://readthedocs.org/) (RTD) site uses a virtual machine (VM) for processing documentation. The VM architecture is type x86\_64. The default version for doxygen is 1.8.13 on the RTD VM. -NOTE: Using modified python modules on RTD is possible through careful crafting of the requirements.txt file. It is impossible to replace system binaries or compile code on RTD. It is possible to ship replacement binaries that can be run from the repo. For security reasons, a binary cannot be included in the MOM6 repository. +NOTE: It is impossible to replace system binaries or compile code on RTD. +It is possible to ship replacement binaries that can be run from the repo. +For security reasons, a binary cannot be included in the MOM6 repository. #### Logfiles @@ -388,19 +403,37 @@ Most websites force download of `*.log` files. # Credits +## 2026 +The documentation toolchain was modernized to run against stock upstream +Sphinx 8.x. The four-fork chain that the build had been carrying since +2020 was reduced to: + +- A vendored copy of the Doxygen-to-Sphinx bridge under + `docs/_ext/autodoc_doxygen/`, originally derived from the `0.7.13` + release of `jr3cermak/sphinxcontrib-autodoc_doxygen`. The vendored + version is ported to the Sphinx 8 API and lives in-tree where it can + be debugged and edited like any other project source. +- A pinned commit of upstream `VACUMM/sphinx-fortran` master. +- A small monkey-patch in `conf.py` for `sphinx.util.math.wrap_displaymath` + that suppresses Sphinx's default outer wrapping when the source already + supplies its own LaTeX environment, replacing the only functional change + the previous Sphinx fork carried. +- A small monkey-patch in `conf.py` for + `sphinxfortran.fortran_domain.FortranDomain.merge_domaindata` to fix a + parallel-build bug in upstream sphinx-fortran. To be removed when + upstream merges a fix. + +The `flint` dependency (formerly used to patch Doxygen's incomplete +parsing of Fortran functions with `result()` clauses) was dropped after +verifying empirically that nothing in the build pipeline references it. + ## 2020 -The documentation pipeline was upgraded by [Rob Cermak](https://github.com/jr3cermak) and [Marshall Ward](https://github.com/marshallward). Four modified python modules are required -to process the MOM6 documentation. The versions are tagged and placed into the production version of `requirements.txt`. Development versions may be found in the respective `dev` branches. - -| Source | Modified | Version | Development | -| ------ | -------- | ------- | ----------- | -| [sphinx](https://github.com/sphinx-doc/sphinx) | [sphinx-3.2.1mom6.4](https://github.com/jr3cermak/sphinx) | B:3.2.1mom6.4 | B:dev | -| [sphinxcontrib-autodoc-doxygen](https://github.com/rmcgibbo/sphinxcontrib-autodoc_doxygen) | [sphinxcontrib-autodoc-doxygen](https://github.com/jr3cermak/sphinxcontrib-autodoc_doxygen) | T:0.7.13 | B:dev | -| [sphinx-fortran](https://github.com/VACUMM/sphinx-fortran) | [sphinx-fortran](https://github.com/jr3cermak/sphinx-fortran) | T:1.2.2 | B:dev | -| [flint](https://github.com/marshallward/flint) | [flint](https://github.com/jr3cermak/flint) | T:0.0.1 | B:dev | -| [MOM6](https://github.com/NOAA-GFDL/MOM6) | [esmg-docs](https://github.com/ESMG/MOM6/tree/esmg-docs) | [esmg-docs](https://github.com/ESMG/MOM6/tree/esmg-docs) | B:[esmg-test](https://github.com/jr3cermak/MOM6/tree/esmg-test) | - -T: tag B: branch +The documentation pipeline was upgraded by [Rob Cermak](https://github.com/jr3cermak) +and [Marshall Ward](https://github.com/marshallward). The pipeline at that time +required four modified Python modules (`sphinx`, `sphinxcontrib-autodoc_doxygen`, +`sphinx-fortran`, `flint`), all forked under the `jr3cermak` GitHub account. +That toolchain was retired during the 2026 modernization above; this entry +is retained as historical context. ## 2017 The sphinx documentation of MOM6 is made possible by modifications by [Angus Gibson](https://github.com/angus-g) to two packages, [sphinx-fortran](https://github.com/angus-g/sphinx-fortran) and [autodoc\_doxygen](https://github.com/angus-g/sphinxcontrib-autodoc_doxygen). diff --git a/docs/_ext/autodoc_doxygen/__init__.py b/docs/_ext/autodoc_doxygen/__init__.py new file mode 100644 index 0000000000..7c4a3afc80 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/__init__.py @@ -0,0 +1,101 @@ +import os.path +from lxml import etree as ET +from sphinx.errors import ExtensionError + + +def set_doxygen_xml(app): + """Load all doxygen XML files from the app config variable + `app.config.doxygen_xml` which should be a path to a directory + containing doxygen xml output. If the configured path is relative, + it is resolved against `app.confdir` rather than the current working + directory -- Sphinx may have any cwd by the time builder-inited fires, + and in particular RTD runs sphinx-build from the repo root. + """ + doxygen_xml = app.config.doxygen_xml + if not os.path.isabs(doxygen_xml): + doxygen_xml = os.path.join(app.confdir, doxygen_xml) + + err = ExtensionError( + '[autodoc_doxygen] No doxygen ' + 'xml output found in doxygen_xml="%s"' % doxygen_xml) + + if not os.path.isdir(doxygen_xml): + raise err + + files = [os.path.join(doxygen_xml, f) + for f in os.listdir(doxygen_xml) + if f.lower().endswith('.xml') and not f.startswith('._')] + if len(files) == 0: + raise err + + setup.DOXYGEN_ROOT = ET.ElementTree(ET.Element('root')).getroot() + for file in files: + root = ET.parse(file).getroot() + for node in root: + setup.DOXYGEN_ROOT.append(node) + + +def get_doxygen_root(): + """Get the root element of the doxygen XML document. + """ + if not hasattr(setup, 'DOXYGEN_ROOT'): + setup.DOXYGEN_ROOT = ET.Element("root") # dummy + return setup.DOXYGEN_ROOT + + +def get_doxygen_id_index(): + """Return a dict mapping every ``@id`` in the merged doxygen tree to + the element that owns it. Built lazily on first use and memoized + on the :func:`setup` function object. + + Profiling a serial build at full MOM6 input (XML_PROGRAMLISTING=YES, + 109 MB merged tree) showed ``xmlutils.visit_ref`` burning 250 s of + self time -- 27% of total wall clock -- in a single ``findall('.//* + [@id=X]')`` call that linearly scanned the entire merged tree once + per ```` in prose. This index turns that scan into an O(1) + dict lookup. Same shape of fix as the scanNode `//` -> `.//` patch + in commit 8a217135e. + """ + if not hasattr(setup, 'DOXYGEN_ID_INDEX'): + root = get_doxygen_root() + index = {} + for el in root.iter(): + eid = el.get('id') + if eid is not None: + index[eid] = el + setup.DOXYGEN_ID_INDEX = index + return setup.DOXYGEN_ID_INDEX + + +def setup(app): + import sphinx + from .autodoc import ( + DoxygenMethodDocumenter, + DoxygenTypeDocumenter, + DoxygenModuleDocumenter, + ) + from .autosummary import DoxygenAutosummary, DoxygenAutoEnum + from .autosummary.generate import process_generate_options + from .autodoxysource import AutoDoxySourceDirective + + app.connect("builder-inited", set_doxygen_xml) + app.connect("builder-inited", process_generate_options) + + app.setup_extension('sphinx.ext.autodoc') + app.setup_extension('sphinx.ext.autosummary') + + app.add_autodocumenter(DoxygenModuleDocumenter) + app.add_autodocumenter(DoxygenMethodDocumenter) + app.add_autodocumenter(DoxygenTypeDocumenter) + + app.add_config_value("doxygen_xml", "", 'env') + # Used in autodoc_doxygen/autosummary/generate.py + app.add_config_value('autosummary_toctree', '', 'html') + + app.add_directive('autodoxysummary', DoxygenAutosummary) + app.add_directive('autodoxyenum', DoxygenAutoEnum) + app.add_directive('autodoxysource', AutoDoxySourceDirective) + + app.add_css_file('autodoxysource.css') + + return {'version': sphinx.__display_version__, 'parallel_read_safe': True} diff --git a/docs/_ext/autodoc_doxygen/autodoc.py b/docs/_ext/autodoc_doxygen/autodoc.py new file mode 100644 index 0000000000..1b62eeca47 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autodoc.py @@ -0,0 +1,610 @@ +import re + +from docutils.parsers.rst import directives +from lxml import etree as ET +from sphinx.ext.autodoc import Documenter, members_option, ALL +from sphinx.errors import ExtensionError +from sphinx.util import logging + +from . import get_doxygen_root +from .autodoxysource import get_source_link +from .xmlutils import format_xml_paragraph, flatten + +logger = logging.getLogger(__name__) + + +class DoxygenDocumenter(Documenter): + # Variables to store the names of the object being documented. modname and fullname are redundant, + # and objpath is always the empty list. This is inelegant, but we need to work with the superclass. + + fullname = None # example: "OpenMM::NonbondedForce" or "OpenMM::NonbondedForce::methodName"" + modname = None # example: "OpenMM::NonbondedForce" or "OpenMM::NonbondedForce::methodName"" + objname = None # example: "NonbondedForce" or "methodName" + objpath = [] # always the empty list + object = None # the xml node for the object + # This allows section headers in autogenerated content + titles_allowed = True + + option_spec = { + 'members': members_option, + } + + # original + #def __init__(self, directive, name, indent=u'', id=None): + # super(DoxygenDocumenter, self).__init__(directive, name, indent) + # if id is not None: + # self.parse_id(id) + # new + def __init__(self, directive, name, indent=u'', id=None, brief=False, parent=None): + super().__init__(directive, name, indent) + + self.parent = parent + if id is not None: + self.parse_id(id) + self.brief = brief + + def parse_id(self, id): + return False + + def parse_name(self): + """Determine what module to import and what attribute to document. + Returns True and sets *self.modname*, *self.objname*, *self.fullname*, + if parsing and resolving was successful. + """ + # To view the context and order in which all of these methods get called, + # See, Documenter.generate(). That's the main "entry point" that first + # calls parse_name(), follwed by import_object(), format_signature(), + # add_directive_header(), and then add_content() (which calls get_doc()) + + # methods in the superclass sometimes use '.' to join namespace/class + # names with method names, and we don't want that. + self.name = self.name.replace('.', '::') + self.fullname = self.name + self.modname = self.fullname + self.objpath = [] + + if '::' in self.name: + parts = self.name.split('::') + self.objname = parts[-1] + else: + self.objname = self.name + + return True + + def document_members(self, all_members=False): + """Generate reST for member documentation. + If *all_members* is True, do all members, else those given by + *self.options.members*. + """ + want_all = all_members or self.options.inherited_members or \ + self.options.members is ALL + # new + members = all_members + # find out which members are documentable + # removed + #members_check_module, members = self.get_object_members(want_all) + + # remove members given by exclude-members + if self.options.exclude_members: + members = [(membername, member) for (membername, member) in members + if membername not in self.options.exclude_members] + + # document non-skipped members + memberdocumenters = [] + for (mname, member, isattr) in self.filter_members(members, want_all): + classes = [cls for cls in self.env.app.registry.documenters.values() + if cls.can_document_member(member, mname, isattr, self)] + if not classes: + # don't know how to document this member + continue + + # prefer the documenter with the highest priority + classes.sort(key=lambda cls: cls.priority) + + # change + #documenter = classes[-1](self.directive, mname, indent=self.indent, id=member.get('id')) + documenter = classes[-1](self.directive, mname, indent=self.indent, + id=member.get('id'), brief=self.brief, + parent=self.object) + memberdocumenters.append((documenter, isattr)) + + for documenter, isattr in memberdocumenters: + documenter.generate( + all_members=True, real_modname=self.real_modname, + #check_module=members_check_module and not isattr) + # modified + check_module=False and not isattr) + + # reset current objects + self.env.temp_data['autodoc:module'] = None + self.env.temp_data['autodoc:class'] = None + +# Copy of DoxygenClassDocumenter -> DoxygenModuleDocumenter +class DoxygenModuleDocumenter(DoxygenDocumenter): + # change + #objtype = 'doxyclass' + #directivetype = 'class' + #domain = 'cpp' + objtype = 'doxymodule' + directivetype = 'module' + domain = 'f' + priority = 100 + + option_spec = { + 'members': members_option, + 'methods': directives.flag, + 'types': directives.flag, + } + + @classmethod + def can_document_member(cls, member, membername, isattr, parent): + # this method is only called from Documenter.document_members + # when a higher level documenter (module or namespace) is trying + # to choose the appropriate documenter for each of its lower-level + # members. Currently not implemented since we don't have a higher-level + # doumenter like a DoxygenNamespaceDocumenter. + return False + + def import_object(self): + """Import the object and set it as *self.object*. In the call sequence, this + is executed right after parse_name(), so it can use *self.fullname*, *self.objname*, + and *self.modname*. + + Returns True if successful, False if an error occurred. + """ + # change + #xpath_query = './/compoundname[text()="%s"]/..' % self.fullname + xpath_query = './compounddef/compoundname[text()="%s"]/..' % self.fullname + match = get_doxygen_root().xpath(xpath_query) + if len(match) != 1: + # change + #raise ExtensionError('[autodoc_doxygen] could not find class (fullname="%s"). I tried' + raise ExtensionError('[autodoc_doxygen] could not find module (fullname="%s"). I tried' + 'the following xpath: "%s"' % (self.fullname, xpath_query)) + + self.object = match[0] + if self.env.app.verbosity > 0: print("[debug] xpath(%s) match(%s)" % (xpath_query,match[0].items())) + return True + + # todo: typo: report upstream + #def format_signaure(self): + def format_signature(self): + if self.env.app.verbosity > 0: print("[debug] DoxygenModuleDocumenter format_signature called") + #return '' + + def format_name(self): + return self.fullname + + # change + #def get_doc(self): + # detaileddescription = self.object.find('detaileddescription') + # doc = [format_xml_paragraph(detaileddescription)] + # encoding depricated? + # called via add_content + #def get_doc(self, encoding): + def get_doc(self): + if self.brief: + description = self.object.find('briefdescription') + else: + description = self.object.find('detaileddescription') + # use the brief description if there's no content in the + # detailed description + if not len(description) and not description.text.strip(): + description = self.object.find('briefdescription') + + #if self.env.app.verbosity > 0: print("[debug] get_doc(%s)(%s)" % (self.brief, description.items())) + doc = [format_xml_paragraph(description, self.env.config.sphinx_build_mode, + verbosity=self.env.app.verbosity)] + + #if self.env.app.verbosity > 0: + # if self.name == 'mom_ice_shelf': + + if not any(len(d.strip()) for d in doc[0]): + doc.append(['', '']) + + if self.brief: + # More references need to be unique across all pages + doc.append(['`More... `_' % (self.name), '']) + + return doc + + def get_object_members(self, want_all): + # change + pass + #all_members = self.object.xpath('.//sectiondef[@kind="public-func" ' + # 'or @kind="public-static-func"]/memberdef[@kind="function"]') + # + #if want_all: + # return False, ((m.find('name').text, m) for m in all_members) + #else: + # if not self.options.members: + # return False, [] + # else: + # return False, ((m.find('name').text, m) for m in all_members + # if m.find('name').text in self.options.members) + + def filter_members(self, members, want_all): + ret = [] + for (membername, member) in members: + ret.append((membername, member, False)) + return ret + + # change function arguments + #def document_members(self, all_members=False): + def document_members(self, member_type, all_members=False): + if member_type == 'func': + all_members = self.object.xpath('./sectiondef[@kind="func" ' + 'or @kind="public-static-func"]/memberdef[@kind="function"]') + + members = [(m.find('name').text, m) for m in all_members] + + elif member_type == 'type': + classes = self.object.findall('./innerclass') + members = [] + for c in classes: + + class_obj = get_doxygen_root().find('./compounddef[@id="%s"]' % c.get('refid')) + if class_obj.get('kind') == 'type': + members.append((class_obj.find('compoundname').text, class_obj)) + + if self.env.app.verbosity > 0: print("[debug] members(%s)" % (members)) + # Calls the plain DoxygenDocumenter to generate the rst + super().document_members(all_members=members) + # change + # super(DoxygenClassDocumenter, self).document_members(all_members=all_members) + # Uncomment to view the generated rst for the class. + # print('\n'.join(self.directive.result)) + + # added functions + + def add_title(self, title, char='='): + sourcename = self.get_sourcename() + + self.add_line(u'', sourcename) + self.add_line(char * len(title), sourcename) + self.add_line(title, sourcename) + self.add_line(char * len(title), sourcename) + self.add_line(u'', sourcename) + + # This generates the autogenerated content for all the module + # functions + def generate(self, more_content=None, real_modname=None, + check_module=False, all_members=False): + if not self.parse_name(): + logger.warning("don't know which module to import for autodocumenting %r" % self.name) + return + + if not self.import_object(): + return + + self.real_modname = real_modname or self.get_real_modname() + + # we can't import anything, since we're not Python + self.analyzer = None + + if check_module and not self.check_module(): + return + + sourcename = self.get_sourcename() + + # add title + title = '%s module reference' % self.format_name() + if self.env.app.verbosity > 0: + print("[debug] add_title:%s" % (title)) + self.add_title(title, char='=') + + # module directive + self.add_line(u'.. f:module:: %s' % self.format_name(), sourcename) + self.add_line(u'', sourcename) + + # brief description + self.brief = True + self.add_content(more_content) + + # we want a brief description of types/functions here + + # detailed description + #self.add_line(u'.. _`More...`:', sourcename) + self.add_line('','') + self.add_line(u'.. _DETA%s:' % (self.name), '') + self.add_title('Detailed Description', char='-') + self.brief = False + self.add_content(None) + + if 'types' in self.options: + self.add_title('Type Documentation', char='-') + self.document_members('type', all_members) + + # member doc + if 'methods' in self.options: + self.add_title('Function/Subroutine Documentation', char='-') + self.document_members('func', all_members) + + # [source] link at the bottom of the module page + src = get_source_link(self.object) + if src: + docname, line = src + file_id = docname.rsplit('/', 1)[-1] + self.add_line(u'', sourcename) + self.add_line( + u'`[source] <../source/%s.html#L%s>`__' % (file_id, line), + sourcename) + + if self.env.app.verbosity > 0: + if self.real_modname == 'mom_eos': + # Result: self.directive.result.data + pass + +class DoxygenMethodDocumenter(DoxygenDocumenter): + objtype = 'doxymethod' + directivetype = 'function' + # See if this can be modified to work for cpp and f? + # Put a breakpoint here + #domain = 'cpp' + domain = 'f' + priority = 100 + + @classmethod + def can_document_member(cls, member, membername, isattr, parent): + if ET.iselement(member) and member.tag == 'memberdef' and member.get('kind') == 'function': + return True + return False + + # add function + def add_directive_header(self, sig): + """Add the directive header and options to the generated content.""" + domain = self.domain + # use the field, without other information (e.g. public) + # functions are badly formed out of this function + if self.env.app.verbosity > 0: + print("[debug] add_directive_header sig(%s)" % (sig)) + if sig is not None and sig.find('adv_dyn') >= 0: + pass + name = self.format_name() + sourcename = self.get_sourcename() + + # determine which directive to use from the typefield + typefield = self.get_typefield() + if 'subroutine' in typefield: + directive = 'subroutine' + else: + directive = 'function' + + if self.env.app.verbosity > 0: + print("[debug] DoxygenMethodDocumenter directive(%s) name(%s)" % (directive,name)) + if name.find('eos_domain') >= 0 or name.find('mom_state_is') >= 0: + pass + + self.add_line(u'.. %s:%s:: %s%s' % (domain, directive, name, sig), + sourcename) + + def parse_id(self, id): + # added + # try to search our parent node instead of the entire tree + parent = self.parent + if parent is None: + parent = get_doxygen_root() + + xp = './/*[@id="%s"]' % id + # original + #match = get_doxygen_root().xpath(xp) + match = parent.xpath(xp) + if len(match) > 0: + match = match[0] + self.fullname = match.find('./definition').text.split()[-1] + self.modname = self.fullname + self.objname = match.find('./name').text + self.object = match + return False + + def import_object(self): + if ET.iselement(self.object): + # self.object already set from DoxygenDocumenter.parse_name(), + # caused by passing in the `id` of the node instead of just a + # classname or method name + return True + + return False + # original + xpath_query = ('.//compoundname[text()="%s"]/../sectiondef[@kind="public-func"]' + '/memberdef[@kind="function"]/name[text()="%s"]/..') % tuple(self.fullname.rsplit('::', 1)) + match = get_doxygen_root().xpath(xpath_query) + if len(match) == 0: + raise ExtensionError('[autodoc_doxygen] could not find method (modname="%s", objname="%s"). I tried ' + 'the following xpath: "%s"' % (tuple(self.fullname.rsplit('::', 1)) + (xpath_query,))) + self.object = match[0] + + def get_doc(self): + doc = [format_xml_paragraph(self.object.find('briefdescription'), self.env.config.sphinx_build_mode, + verbosity=self.env.app.verbosity)] + # debug + if self.object.find('name').text == 'eos_domain': + pass + #detaileddescription = self.object.find('detaileddescription') + #doc = [format_xml_paragraph(detaileddescription,self.env.config.sphinx_build_mode)] + + # add parameter documentation (in detaileddescription) for main function documentation + if not self.brief: + doc += [format_xml_paragraph(self.object.find('detaileddescription'), self.env.config.sphinx_build_mode, + verbosity=self.env.app.verbosity)] + + if self.object.find('name').text == 'eos_domain': + pass + # File location + # ffile = self.object.find('location').get('file') + # add references/referencedby + references = self.object.findall('references') + for ref in references: + name = ref.text + doc.append([':callto: :f:func:`%s <%s>`' % (name, name.split('::')[-1])]) + referencedby = self.object.findall('referencedby') + for ref in referencedby: + name = ref.text + doc.append([':calledfrom: :f:func:`%s <%s>`' % (name, name.split('::')[-1])]) + + # If a document returns a string with :return: that is our signal to use flint to + # repair the documentation a bit. Doxygen cannot parse functions of this syntax: + #!> This subroutine returns a two point integer array indicating the domain of i-indices + #!! to work on in EOS calls based on information from a hor_index type + #function EOS_domain(HI, halo) result(EOSdom) + # type(hor_index_type), intent(in) :: HI !< The horizontal index structure + # integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. + # integer, dimension(2) :: EOSdom !< The index domain that the EOS will work on, taking into account + # !! that the arrays inside the EOS routines will start at 1. + # + # ! Local variables + # integer :: halo_sz + # + # halo_sz = 0 ; if (present(halo)) halo_sz = halo + # + # EOSdom(1) = HI%isc - (HI%isd-1) - halo_sz + # EOSdom(2) = HI%iec - (HI%isd-1) + halo_sz + # + #end function EOS_domain + #if self.object.find('name').text == 'eos_domain': + + if not self.brief: + src = get_source_link(self.object) + if src: + docname, line = src + file_id = docname.rsplit('/', 1)[-1] + doc.append(['`[source] <../source/%s.html#L%s>`__' % (file_id, line)]) + + return doc + + # added function + def get_typefield(self): + return ' '.join(self.object.find('definition').text.split()[:-1]) + + def format_name(self): + #def text(el): + # if el.text is not None: + # return el.text + # return '' + + #def tail(el): + # if el.tail is not None: + # return el.tail + # return '' + + #rtype_el = self.object.find('type') + #rtype_el_ref = rtype_el.find('ref') + #if rtype_el_ref is not None: + # rtype = text(rtype_el) + text(rtype_el_ref) + tail(rtype_el_ref) + #else: + # rtype = rtype_el.text + + # replaced above with + + # we just want to get the bare part of the "type" field + # i.e. subroutine or function + typefield = self.get_typefield() + + if typefield is None: + rtype = None + elif 'function' in typefield: + # Don't include the return type in the directive name. + # sphinx-fortran's f_sig_re regex only matches + # "function name(args)" or bare "name(args)"; a return + # type prefix like "real name(args)" causes the regex + # to fail, leaving the function unregistered and + # unclickable. The f:function directive already labels + # the entry as "function". + rtype = None + else: + rtype = 'subroutine' if 'subroutine' in typefield else 'unknown' + + signame = (rtype and (rtype + ' ') or '') + self.objname + return self.format_template_name() + signame + + def format_template_name(self): + types = [e.text for e in self.object.findall('templateparamlist/param/type')] + if len(types) == 0: + return '' + return 'template <%s>\n' % ','.join(types) + + def format_signature(self): + args = self.object.find('argsstring').text + if self.env.app.verbosity > 0: + print("[debug] DoxygenMethodDocumenter format_signature called (%s)" % (args)) + if args is not None and args.find('adv_dyn')>=0: + pass + return args + + def document_members(self, all_members=False): + pass + +# add class + +class DoxygenTypeDocumenter(DoxygenDocumenter): + objtype = 'doxytype' + directivetype = 'type' + domain = 'f' + priority = 100 + + @classmethod + def can_document_member(cls, member, membername, isattr, parent): + if ET.iselement(member) and member.tag == 'compounddef' and member.get('kind') == 'type': + return True + return False + + def import_object(self): + if ET.iselement(self.object): + return True + return False + + def parse_id(self, id): + self.object = get_doxygen_root().find('./compounddef[@id="%s"]' % id) + self.fullname = self.object.find('compoundname').text + self.modname, self.objname = self.fullname.rsplit('::') + + return False + + def format_name(self): + return self.objname + + def add_directive_header(self, sig): + """Add the directive header and options to the generated content.""" + domain = self.domain + directive = 'type' + name = self.format_name() + sourcename = self.get_sourcename() + + self.add_line(u'.. %s:%s:: %s' % (domain, directive, name), + sourcename) + + def get_doc(self): + desc = [format_xml_paragraph(self.object.find('briefdescription'), + self.env.config.sphinx_build_mode, verbosity=self.env.app.verbosity)] + + for member in self.object.findall('./sectiondef/memberdef'): + name = member.find('name').text + type_el = member.find('type') + full_type = ''.join(type_el.itertext()).strip() if type_el is not None else '' + + if member.get('prot') == 'private': + if full_type: + full_type += ', private' + else: + full_type = 'private' + + field = ':typefield %s:' % name + if full_type: + field += ' ``%s``' % full_type + + brief = member.find('briefdescription/para') + if brief is not None: + field += ' ' + brief.text + + desc.append([field]) + + src = get_source_link(self.object) + if src: + docname, line = src + file_id = docname.rsplit('/', 1)[-1] + desc.append(['`[source] <../source/%s.html#L%s>`__' % (file_id, line)]) + + return desc + + def document_members(self, all_members=False): + pass diff --git a/docs/_ext/autodoc_doxygen/autodoxysource.py b/docs/_ext/autodoc_doxygen/autodoxysource.py new file mode 100644 index 0000000000..a12af14b11 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autodoxysource.py @@ -0,0 +1,231 @@ +"""autodoxysource directive: render doxygen as +syntax-highlighted source with clickable cross-references.""" + +from docutils import nodes +from docutils.parsers.rst import Directive +from sphinx import addnodes +from sphinx.util import logging + +from . import get_doxygen_root + +logger = logging.getLogger(__name__) + +# Map doxygen highlight classes to CSS classes for the source listing. +_HL_CSS = { + 'comment': 'f-hl-comment', + 'normal': 'f-hl-normal', + 'keyword': 'f-hl-keyword', + 'keywordtype': 'f-hl-keywordtype', + 'keywordflow': 'f-hl-keywordflow', + 'stringliteral': 'f-hl-stringliteral', + 'preprocessor': 'f-hl-preprocessor', +} + +# Lazily-built index: doxygen refid -> (refdomain, reftype, reftarget) +_REFID_INDEX = None + +# Index: absolute file path -> doxygen file-ID (for [source] links) +_FILE_PATH_INDEX = None + + +def _build_refid_index(): + """Walk the merged doxygen tree once, building refid -> xref info.""" + global _REFID_INDEX + _REFID_INDEX = {} + root = get_doxygen_root() + + for cd in root.findall('./compounddef'): + cid = cd.get('id') + kind = cd.get('kind') + cn = cd.find('compoundname') + if cn is None or cn.text is None: + continue + name = cn.text + + if kind == 'namespace': + _REFID_INDEX[cid] = ('f', 'mod', name) + elif kind in ('type', 'struct'): + # compoundname is "parent::typename" -> "parent/typename" + _REFID_INDEX[cid] = ('f', 'type', name.replace('::', '/')) + elif kind == 'interface': + _REFID_INDEX[cid] = ('f', 'func', name.replace('::', '/')) + # kind='file' / 'page' / 'dir' -> no xref + + # Index memberdefs inside this compound + for md in cd.iter('memberdef'): + mid = md.get('id') + mk = md.get('kind') + mn_el = md.find('name') + if mn_el is None or mn_el.text is None: + continue + qualified = name + '/' + mn_el.text + if mk == 'function': + _REFID_INDEX[mid] = ('f', 'func', qualified) + # variables / enums aren't useful xref targets here + + +def _resolve_ref(refid): + """O(1) lookup of a doxygen refid to (refdomain, reftype, reftarget).""" + global _REFID_INDEX + if _REFID_INDEX is None: + _build_refid_index() + return _REFID_INDEX.get(refid) + + +def _build_file_path_index(): + """Build filepath -> file_id index from compounddef[@kind='file'].""" + global _FILE_PATH_INDEX + _FILE_PATH_INDEX = {} + root = get_doxygen_root() + for cd in root.findall('./compounddef[@kind="file"]'): + fid = cd.get('id') + loc = cd.find('location') + if loc is not None and loc.get('file'): + _FILE_PATH_INDEX[loc.get('file')] = fid + + +def get_source_link(xml_node): + """Given a doxygen XML node (compounddef or memberdef), return + (docname, line) for a [source] link, or None if unavailable. + + *docname* is the Sphinx document name (e.g. 'api/generated/source/MOM_8F90'). + *line* is the source line number string. + """ + global _FILE_PATH_INDEX + if _FILE_PATH_INDEX is None: + _build_file_path_index() + + loc = xml_node.find('location') + if loc is None: + return None + + filepath = loc.get('file') + line = loc.get('line', '1') + if not filepath: + return None + + file_id = _FILE_PATH_INDEX.get(filepath) + if file_id is None: + return None + + docname = 'api/generated/source/' + file_id + return (docname, line) + + +class AutoDoxySourceDirective(Directive): + """.. autodoxysource:: + + Render the source listing for a doxygen file compound, with + per-line anchors, syntax highlighting, and clickable identifiers + that link to the Sphinx API documentation. + """ + required_arguments = 1 + optional_arguments = 0 + has_content = False + + def run(self): + file_id = self.arguments[0] + root = get_doxygen_root() + + compounddef = root.find('./compounddef[@id="%s"]' % file_id) + if compounddef is None: + logger.warning('autodoxysource: compounddef not found for %s', + file_id) + return [nodes.paragraph('', 'Source listing not available.')] + + programlisting = compounddef.find('.//programlisting') + if programlisting is None: + logger.warning('autodoxysource: no programlisting in %s', file_id) + return [nodes.paragraph('', 'Source listing not available.')] + + # Outer wrapper. support_smartquotes=False propagates to all + # descendants via sphinx.util.nodes.is_smartquotable, so every + # text node inside the listing is skipped by the smartquotes + # transform -- a meaningful speedup on 329 large source pages. + table = nodes.container(classes=['autodoxysource']) + table['support_smartquotes'] = False + + for codeline in programlisting.findall('codeline'): + lineno = codeline.get('lineno', '') + + # Per-line container carries the #L anchor via ``ids``; + # the previous standalone ``target`` node was dropped to + # cut a node per line. The inner ``source-code`` inline + # wrapper is kept because Sphinx's HTML writer asserts + # that ``reference`` nodes (produced when pending_xrefs + # resolve) have a ``TextElement`` parent. + line_node = nodes.container(classes=['source-line']) + if lineno: + line_node['ids'] = ['L' + lineno] + + line_node += nodes.inline(lineno, lineno, + classes=['source-lineno']) + + code_node = nodes.inline(classes=['source-code']) + for hl in codeline: + if hl.tag != 'highlight': + continue + css = _HL_CSS.get(hl.get('class', 'normal'), 'f-hl-normal') + _walk_highlight(hl, css, code_node) + line_node += code_node + + table += line_node + + return [table] + + +def _walk_highlight(hl, css_class, parent): + """Walk mixed content of a element, appending nodes to + *parent*. + + Text fragments are coalesced: consecutive characters with the same + CSS class (including ```` expansions and tail text) are + flushed as a single ``inline`` node rather than one per fragment. + Before coalescing, a typical line emitted 10-30 nodes; after, it + emits closer to 3-5. Node count drives pickling, transform walks, + and HTML writing cost linearly for the source-listing pages. + """ + buf = [] + + def flush(): + if buf: + text = ''.join(buf) + parent.append(nodes.inline(text, text, classes=[css_class])) + buf.clear() + + if hl.text: + buf.append(hl.text) + + for child in hl: + if child.tag == 'sp': + buf.append(' ') + elif child.tag == 'ref': + flush() + _emit_ref(child, css_class, parent) + elif child.text: + buf.append(child.text) + + if child.tail: + buf.append(child.tail) + + flush() + + +def _emit_ref(ref_el, css_class, parent): + """Emit a pending_xref (or plain text fallback) for a element.""" + ref_text = ref_el.text or '' + refid = ref_el.get('refid', '') + + resolved = _resolve_ref(refid) + if resolved: + refdomain, reftype, reftarget = resolved + inner = nodes.inline(ref_text, ref_text, classes=[css_class]) + xref = addnodes.pending_xref( + '', inner, + refdomain=refdomain, + reftype=reftype, + reftarget=reftarget, + ) + parent += xref + else: + parent += nodes.inline(ref_text, ref_text, classes=[css_class]) diff --git a/docs/_ext/autodoc_doxygen/autosummary/__init__.py b/docs/_ext/autodoc_doxygen/autosummary/__init__.py new file mode 100644 index 0000000000..fec98be964 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/__init__.py @@ -0,0 +1,260 @@ +import re +import operator +from functools import reduce +from itertools import count, groupby + +from docutils import nodes +from docutils.parsers.rst import directives +from docutils.statemachine import StringList, ViewList +from sphinx import addnodes +from sphinx.ext.autosummary import Autosummary, autosummary_table +from sphinx.util import logging + +from .. import get_doxygen_root +from ..autodoc import DoxygenMethodDocumenter, DoxygenModuleDocumenter +from ..xmlutils import format_xml_paragraph + +logger = logging.getLogger(__name__) + + +def import_by_name(name, env=None, prefixes=None, i=0): + """Get xml documentation for a class/method with a given name. + If there are multiple classes or methods with that name, you + can use the `i` kwarg to pick which one. + """ + if prefixes is None: + prefixes = [None] + + # angus + if env is not None: + parent = env.ref_context.get('cpp:parent_symbol') + parent_symbols = [] + while parent is not None and parent.identifier is not None: + parent_symbols.insert(0, str(parent.identifier)) + parent = parent.parent + prefixes.append('::'.join(parent_symbols)) + + # orig + if env is not None: + #if env.ref_context != None and env.ref_context != {}: + # print("[debug] parents: %s" % env.ref_context) + parents = env.ref_context.get('cpp:parent_key') + if parents is not None: + parent_symbols = [p[0].get_display_string() for p in parents] + prefixes.append('::'.join(parent_symbols)) + + # unmodified + tried = [] + for prefix in prefixes: + try: + if prefix: + prefixed_name = '::'.join([prefix, name]) + else: + prefixed_name = name + return _import_by_name(prefixed_name, i=i) + except ImportError: + tried.append(prefixed_name) + raise ImportError('no module named %s' % ' or '.join(tried)) + +def _import_by_name(name, i=0): + root = get_doxygen_root() + name = name.replace('.', '::') + + if '::' in name: + xpath_query = ( + './compounddef/compoundname[text()="%s"]/../' + 'sectiondef[@kind="func"]/memberdef[@kind="function"]/' + 'name[text()="%s"]/..') % tuple(name.rsplit('::', 1)) + m = root.xpath(xpath_query) + if len(m) > 0: + obj = m[i] + full_name = '.'.join(name.rsplit('::', 1)) + return full_name, obj, full_name, '' + + xpath_query = ('./compounddef/compoundname[text()="%s"]/..' % name) + m = root.xpath(xpath_query) + if len(m) > 0: + obj = m[i] + return (name, obj, name, '') + + raise ImportError() + +def get_documenter(obj, full_name): + if obj.tag == 'memberdef' and obj.get('kind') == 'function': + return DoxygenMethodDocumenter + elif obj.tag == 'compounddef': + return DoxygenModuleDocumenter + + raise NotImplementedError(obj.tag) + + +class DoxygenAutosummary(Autosummary): + # add + option_spec = { + 'toctree': directives.unchanged, + 'nosignatures': directives.flag, + 'template': directives.unchanged, + 'kind': directives.unchanged, + 'generate': directives.flag, + } + + def get_items(self, names): + """Try to import the given names, and return a list of + ``[(name, signature, summary_string, real_name), ...]``. + """ + env = self.state.document.settings.env + items = [] + + # Add "generate" directive + if 'generate' in self.options: + # don't generate a summary for pages + if self.options['kind'] == 'page': + return [] + + modules = get_doxygen_root().xpath('./compound[@kind="namespace"]') + names = [m.find('name').text for m in modules] + + # TODO: silently fail when there are no fortran files provided? + try: + names_and_counts = reduce(operator.add, + [tuple(zip(g, count())) for _, g in groupby(names)]) # type: List[(Str, Int)] + except: + return items + + for name, i in names_and_counts: + display_name = name + if name.startswith('~'): + name = name[1:] + display_name = name.split('::')[-1] + + try: + real_name, obj, parent, modname = import_by_name(name, env=env, i=i) + except ImportError: + logger.warning('failed to import %s' % name) + items.append((name, '', '', name)) + continue + + self.bridge.result = StringList() # initialize for each documenter + documenter = get_documenter(obj, parent)(self.bridge, real_name, + id=obj.get('id'), + brief=True, + parent=obj.find('..')) + if not documenter.parse_name(): + logger.warning('failed to parse name %s' % real_name) + items.append((display_name, '', '', real_name)) + continue + if not documenter.import_object(): + logger.warning('failed to import object %s' % real_name) + items.append((display_name, '', '', real_name)) + continue + if documenter.options.members and not documenter.check_module(): + continue + # -- Grab the signature + sig = documenter.format_signature() + + # -- Grab the summary + documenter.add_content(None) + doc = list(documenter.process_doc([self.bridge.result.data])) + + while doc and not doc[0].strip(): + doc.pop(0) + + # If there's a blank line, then we can assume the first sentence / + # paragraph has ended, so anything after shouldn't be part of the + # summary + for i, piece in enumerate(doc): + if not piece.strip(): + doc = doc[:i] + break + + # Try to find the "first sentence", which may span multiple lines + m = re.search(r"^([A-Z].*?\.)(?:\s|$)", " ".join(doc).strip()) + if m: + summary = m.group(1).strip() + elif doc: + summary = doc[0].strip() + else: + summary = '' + + items.append((display_name, sig, summary, real_name)) + + return items + + def get_tablespec(self): + table_spec = addnodes.tabular_col_spec() + table_spec['spec'] = 'll' + + table = autosummary_table('') + real_table = nodes.table('', classes=['longtable']) + table.append(real_table) + group = nodes.tgroup('', cols=2) + real_table.append(group) + group.append(nodes.colspec('', colwidth=10)) + group.append(nodes.colspec('', colwidth=90)) + body = nodes.tbody('') + group.append(body) + + def append_row(*column_texts): + row = nodes.row('') + for text in column_texts: + node = nodes.paragraph('') + vl = ViewList() + vl.append(text, '') + self.state.nested_parse(vl, 0, node) + try: + if isinstance(node[0], nodes.paragraph): + node = node[0] + except IndexError: + pass + row.append(nodes.entry('', node)) + body.append(row) + return table, table_spec, append_row + + def get_table(self, items): + """Generate a proper list of table nodes for autosummary:: directive. + + *items* is a list produced by :meth:`get_items`. + """ + table, table_spec, append_row = self.get_tablespec() + for name, sig, summary, real_name in items: + # required for cpp autolink + # original + #qualifier = 'cpp:any' + #full_name = real_name.replace('.', '::') + kind = self.options['kind'] + qualifier = 'f:' + kind + # modified + #col1 = ':%s:`%s <%s>`' % (qualifier, name, full_name) + col1 = ':%s:`%s`' % (qualifier, name) + col2 = summary + append_row(col1, col2) + + # RemovedInSphinx40Warning: Autosummary.result is deprecated + # debug: find alternative + #self.result.append(' .. rubric: sdsf', 0) + # removed + #self.bridge.result.append(' .. rubric: sdsf', 0) + # debug + return [table_spec, table] + + +class DoxygenAutoEnum(DoxygenAutosummary): + + def get_items(self, names): + env = self.state.document.settings.env + self.name = names[0] + + real_name, obj, parent, modname = import_by_name(self.name, env=env) + names = [n.text for n in obj.findall('./enumvalue/name')] + descriptions = [format_xml_paragraph(d) for d in obj.findall('./enumvalue/detaileddescription')] + return zip(names, descriptions) + + def get_table(self, items): + table, table_spec, append_row = self.get_tablespec() + for name, description in items: + col1 = ':strong:`' + name + '`' + while description and not description[0].strip(): + description.pop(0) + col2 = ' '.join(description) + append_row(col1, col2) + return [nodes.rubric('', 'Enum: %s' % self.name), table] diff --git a/docs/_ext/autodoc_doxygen/autosummary/generate.py b/docs/_ext/autodoc_doxygen/autosummary/generate.py new file mode 100644 index 0000000000..41d0453c03 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/generate.py @@ -0,0 +1,391 @@ +import codecs +import os +import re +import sys + +from jinja2 import FileSystemLoader +from jinja2.sandbox import SandboxedEnvironment +from sphinx.jinja2glue import BuiltinTemplateLoader +from sphinx.util.osutil import ensuredir + +from . import import_by_name, get_doxygen_root +from ..xmlutils import format_xml_paragraph + + +def is_type(node): + def_node = get_doxygen_root().find('./compounddef[@id="%s"]' % node.get('refid')) + return def_node.get('kind') == 'type' + +def generate_autosummary_docs(sources, output_dir=None, suffix='.rst', + #base_path=None, builder=None, template_dir=None): + # add toctree argument + base_path=None, builder=None, template_dir=None, toctree=None, + build_mode=None): + + showed_sources = list(sorted(sources)) + if len(showed_sources) > 20: + showed_sources = showed_sources[:10] + ['...'] + showed_sources[-10:] + print('[autosummary] generating autosummary for: %s' % + ', '.join(showed_sources)) + + if output_dir: + print('[autosummary] writing to %s' % output_dir) + + if base_path is not None: + sources = [os.path.join(base_path, filename) for filename in sources] + + # create our own templating environment + template_dirs = [os.path.join(os.path.dirname(__file__), 'templates')] + + if builder is not None: + # allow the user to override the templates + template_loader = BuiltinTemplateLoader() + template_loader.init(builder, dirs=template_dirs) + else: + if template_dir: + template_dirs.insert(0, template_dir) + template_loader = FileSystemLoader(template_dirs) + #template_env = SandboxedEnvironment(loader=template_loader) + # modified + template_env = SandboxedEnvironment(loader=template_loader, + trim_blocks=True, lstrip_blocks=True) + + # read + items = find_autosummary_in_files(sources) + + # keep track of new files + new_files = [] + + for name, path, template_name in sorted(set(items), key=str): + # replace + path = path or output_dir or os.path.abspath(toctree) + # debug + + # this is extra? + #if path is None: + # # The corresponding autosummary:: directive did not have + # # a :toctree: option + # print("[debug] directive did not have a :toctree: option") + # continue + + #path = output_dir or os.path.abspath(path) + if builder.app.verbosity > 0: + print("[debug] checking path: %s" % (path)) + ensuredir(path) + + try: + name, obj, parent, mod_name = import_by_name(name) + except ImportError as e: + print('WARNING [autosummary] failed to import %r: %s' % (name, e), file=sys.stderr) + continue + + fn = os.path.join(path, name + suffix).replace('::', '.') + + # skip it if it exists + if os.path.isfile(fn): + continue + + # removed? + #new_files.append(fn) + + if template_name is None: + if obj.tag == 'compounddef' and obj.get('kind') in ['namespace', 'module']: + template_name = 'doxymodule.rst' + elif obj.tag == 'compounddef' and obj.get('kind') == 'page': + template_name = 'doxypage.rst' + else: + raise NotImplementedError('No template for %s (%s %s)' % (obj.items(), obj.tag, obj.get('kind'))) + + if builder.app.verbosity > 0: + print("[debug] template:%s kind: %s obj.items():%s" % (template_name, obj.get('kind'), obj.items())) + with open(fn, 'w') as f: + template = template_env.get_template(template_name) + # The ns keys feed into the template + ns = {} + if obj.tag == 'compounddef' and obj.get('kind') == 'namespace': + ns['methods'] = [e.text for e in obj.findall('./sectiondef[@kind="func"]/memberdef[@kind="function"]/name')] + ns['types'] = [e.text for e in obj.findall('./innerclass') if is_type(e)] + ns['objtype'] = 'namespace' + elif obj.tag == 'compounddef' and obj.get('kind') == 'page': + if builder.app.verbosity > 0: + print("[debug] xml parsing for %s" % (obj.get('id'))) + ns['title'] = obj.find('title').text + ns['underline'] = len(ns['title']) * '=' + #ns['text'] = format_xml_paragraph(obj.find('detaileddescription'),build_mode) + ns = format_xml_paragraph(obj.find('detaileddescription'), build_mode, nsOrig=ns, verbosity=builder.app.verbosity) + #if obj.get('id') == 'Specifics': + else: + raise NotImplementedError(obj) + + parts = name.split('::') + mod_name, obj_name = '::'.join(parts[:-1]), parts[-1] + + ns['fullname'] = name + ns['module'] = mod_name + ns['objname'] = obj_name + ns['name'] = parts[-1] + if not('underline' in ns): + ns['underline'] = len(name) * '=' + + rendered = template.render(**ns) + f.write(rendered) + # debug: date/time caching hack + # f.write('\n..\n {}'.format(datetime.datetime.now())) + + # descend recursively to new files + if new_files: + generate_autosummary_docs(new_files, output_dir=output_dir, + suffix=suffix, base_path=base_path, builder=builder, + #template_dir=template_dir) + # add toctree argument + template_dir=template_dir, toctree=toctree) + + +def find_autosummary_in_files(filenames): + """Find out what items are documented in source/*.rst. + + See `find_autosummary_in_lines`. + """ + # todo: break when this doesn't exist + # look for modules and standalone documentation pages, but *not* the index page + # itself (which it links to from itself for some reason...) + documented = [] + for filename in filenames: + with codecs.open(filename, 'r', encoding='utf-8', errors='ignore') as f: + lines = f.read().splitlines() + documented.extend(find_autosummary_in_lines(lines, filename=filename)) + + return documented + + +def find_autosummary_in_lines(lines, module=None, filename=None): + """Find out what items appear in autosummary:: directives in the + given lines. + + Returns a list of (name, toctree, template) where *name* is a name + of an object and *toctree* the :toctree: path of the corresponding + autosummary directive (relative to the root of the file name), and + *template* the value of the :template: option. *toctree* and + *template* ``None`` if the directive does not have the + corresponding options set. + """ + + # add generate_arg_re + autosummary_re = re.compile(r'^(\s*)\.\.\s+autodoxysummary::\s*') + toctree_arg_re = re.compile(r'^\s+:toctree:\s*(.*?)\s*$') + template_arg_re = re.compile(r'^\s+:template:\s*(.*?)\s*$') + kind_arg_re = re.compile(r'^\s+:kind:\s*(.*?)\s*$') + generate_arg_re = re.compile(r'^\s+:generate:\s*$') + autosummary_item_re = re.compile(r'^\s+(~?[_a-zA-Z][a-zA-Z0-9_.:]*)\s*.*?') + + documented = [] + + toctree = None + template = None + in_autosummary = False + generate = False + base_indent = "" + + for line in lines: + if in_autosummary: + m = toctree_arg_re.match(line) + if m: + toctree = m.group(1) + if filename: + toctree = os.path.join(os.path.dirname(filename), + toctree) + continue + + m = template_arg_re.match(line) + if m: + template = m.group(1).strip() + continue + + # add + + m = generate_arg_re.match(line) + if m: + generate = True + continue + + m = kind_arg_re.match(line) + if m and generate: + kind = m.group(1).strip() + xpath = None + if kind == 'mod': + xpath = './compound[@kind="namespace"]' + elif kind == 'page': + xpath = './compound[@kind="page" and not(@refid="indexpage")]' + + if xpath is not None: + results = get_doxygen_root().xpath(xpath) + for result in results: + documented.append((result.find('name').text, toctree, template)) + + continue + + # end add + + if line.strip().startswith(':'): + continue # skip options + + m = autosummary_item_re.match(line) + if m: + name = m.group(1).strip() + if name.startswith('~'): + name = name[1:] + documented.append((name, toctree, template)) + continue + + if not line.strip() or line.startswith(base_indent + " "): + continue + + in_autosummary = False + + m = autosummary_re.match(line) + if m: + in_autosummary = True + base_indent = m.group(1) + toctree = None + template = None + # add + generate = False + continue + + return documented + + +def _generate_source_stubs(app): + """Generate one :orphan: stub per doxygen file compound under + api/generated/source/, each invoking ``.. autodoxysource::``.""" + root = get_doxygen_root() + source_dir = os.path.join(app.srcdir, 'api', 'generated', 'source') + ensuredir(source_dir) + + template_dirs = [os.path.join(os.path.dirname(__file__), 'templates')] + template_loader = FileSystemLoader(template_dirs) + template_env = SandboxedEnvironment(loader=template_loader, + trim_blocks=True, lstrip_blocks=True) + template = template_env.get_template('doxysource.rst') + + files = root.findall('./compounddef[@kind="file"]') + count = 0 + for cd in files: + file_id = cd.get('id') + if file_id is None: + continue + # Only generate if there is a programlisting + if cd.find('.//programlisting') is None: + continue + + fn = os.path.join(source_dir, file_id + '.rst') + if os.path.isfile(fn): + continue + + # Title from the location filename, or fall back to file_id + loc = cd.find('location') + if loc is not None and loc.get('file'): + title = os.path.basename(loc.get('file')) + else: + title = file_id + + rendered = template.render( + title=title, + underline='=' * len(title), + file_id=file_id, + ) + with open(fn, 'w') as f: + f.write(rendered) + count += 1 + + if count: + print('[autodoxysource] generated %d source stubs in %s' % + (count, source_dir)) + + +def _generate_function_index(app): + """Generate api/functions.rst listing every function/subroutine + across all namespace compounds, with cross-reference links to + the function's entry on its module page.""" + root = get_doxygen_root() + fn = os.path.join(app.srcdir, 'api', 'functions.rst') + if os.path.isfile(fn): + return + + entries = [] + for cd in root.findall('./compounddef[@kind="namespace"]'): + modname = cd.find('compoundname') + if modname is None or modname.text is None: + continue + mod = modname.text + for md in cd.findall('.//sectiondef[@kind="func"]/memberdef[@kind="function"]'): + name_el = md.find('name') + if name_el is None or name_el.text is None: + continue + name = name_el.text + brief_el = md.find('briefdescription/para') + brief = '' + if brief_el is not None and brief_el.text: + brief = brief_el.text.strip().replace('|', r'\|') + qualified = '%s/%s' % (mod, name) + entries.append((name, mod, qualified, brief)) + + entries.sort(key=lambda e: e[0].lower()) + + lines = [ + '.. _Functions:', + '', + '=========', + 'Functions', + '=========', + '', + '.. list-table::', + ' :widths: 30 30 40', + ' :header-rows: 1', + '', + ' * - Name', + ' - Module', + ' - Description', + ] + for name, mod, qualified, brief in entries: + lines.append(' * - :f:func:`%s <%s>`' % (name, qualified)) + lines.append(' - :f:mod:`%s`' % mod) + lines.append(' - %s' % brief) + + lines.append('') + + with open(fn, 'w') as f: + f.write('\n'.join(lines)) + print('[autodoxysource] generated function index with %d entries at %s' % + (len(entries), fn)) + + +def process_generate_options(app): + genfiles = app.config.autosummary_generate + # add + toctree = app.config.autosummary_toctree + # This is important to handle \htmlonly and \latexonly directives + sphinx_build_mode = app.config.sphinx_build_mode + + if genfiles and not hasattr(genfiles, '__len__'): + env = app.builder.env + genfiles = [os.fspath(env.doc2path(x, base=None)) for x in env.found_docs + if os.path.isfile(env.doc2path(x))] + + if not genfiles: + return + + ext = list(app.config.source_suffix)[0] + genfiles = [genfile + (not genfile.endswith(ext) and ext or '') + for genfile in genfiles] + + generate_autosummary_docs(genfiles, builder=app.builder, + # add toctree argument + # suffix=ext, base_path=app.srcdir) + suffix=ext, base_path=app.srcdir, toctree=toctree, build_mode=sphinx_build_mode) + + # Generate source browser stubs + _generate_source_stubs(app) + + # Generate function index + _generate_function_index(app) diff --git a/docs/_ext/autodoc_doxygen/autosummary/templates/doxymodule.rst b/docs/_ext/autodoc_doxygen/autosummary/templates/doxymodule.rst new file mode 100644 index 0000000000..2c89736453 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/templates/doxymodule.rst @@ -0,0 +1,34 @@ +.. autodoxymodule:: {{ fullname }} + :members: + {% if methods %} + :methods: + {% endif %} + {% if types %} + :types: + {% endif %} + + {% if types %} + ---------- + Data Types + ---------- + + .. autodoxysummary:: + :kind: type + + {% for item in types %} + ~{{ item }} + {% endfor %} + {% endif %} + + {% if methods %} + --------------------- + Functions/Subroutines + --------------------- + + .. autodoxysummary:: + :kind: func + + {% for item in methods %} + ~{{ fullname }}::{{ item }} + {% endfor %} + {% endif %} diff --git a/docs/_ext/autodoc_doxygen/autosummary/templates/doxypage.rst b/docs/_ext/autodoc_doxygen/autosummary/templates/doxypage.rst new file mode 100644 index 0000000000..96320dc499 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/templates/doxypage.rst @@ -0,0 +1,21 @@ +.. _{{ name }}: +{# comment +When the name is provided, we get "(INFO/1) Duplicate implicit target name:" +without this, we get undefined reference. This needs to be fixed later. +#} + +{{ underline }} +{{ title }} +{{ underline }} + +{% for line in text %} +{{ line }} +{% endfor %} +{% if footnotes %} + +.. rubric:: Footnotes + +{% for line in footnotes %} +.. [#] {{ line }} +{% endfor %} +{% endif %} diff --git a/docs/_ext/autodoc_doxygen/autosummary/templates/doxysource.rst b/docs/_ext/autodoc_doxygen/autosummary/templates/doxysource.rst new file mode 100644 index 0000000000..cef1c4cab7 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/templates/doxysource.rst @@ -0,0 +1,6 @@ +:orphan: + +{{ title }} +{{ underline }} + +.. autodoxysource:: {{ file_id }} diff --git a/docs/_ext/autodoc_doxygen/xmlutils.py b/docs/_ext/autodoc_doxygen/xmlutils.py new file mode 100644 index 0000000000..98459f5da9 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/xmlutils.py @@ -0,0 +1,997 @@ +import re + +from . import get_doxygen_root, get_doxygen_id_index + + +def flatten(xmlnode): + # this.textchild0.textchild0.tail... + + t = '' + + # text of this node + if xmlnode.text is not None: + t += xmlnode.text + + # process all children recursively + for n in xmlnode: + t += ' ' + t += flatten(n) + if n.tail is not None: + t += ' ' + t += n.tail + + return t + +def format_xml_paragraph(xmlnode,build_mode,nsOrig=None,verbosity=0): + """Format an Doxygen XML segment (principally a detaileddescription) + as a paragraph for inclusion in the rst document + + Parameters + ---------- + xmlnode + + Returns + ------- + lines + A list of lines. + """ + # Here we are operating on the entire document for the template + # This helps support \footnotes{} + if nsOrig is not None: + xmlParagraphFormatter = _DoxygenXmlParagraphFormatter() + xmlParagraphFormatter.setNS(nsOrig) + xmlParagraphFormatter.setVerbosity(verbosity) + xmlParagraphFormatter.generic_visit(xmlnode,build_mode=build_mode) + xmlParagraphFormatter.ns['text'] = [l.rstrip() for l in xmlParagraphFormatter.lines] + return xmlParagraphFormatter.ns + else: + # Return processing for typically ns['text'] only + # Expand to allow setting of options + xmlParagraphFormatter = _DoxygenXmlParagraphFormatter() + xmlParagraphFormatter.setVerbosity(verbosity) + xmlParagraphFormatter.generic_visit(xmlnode,build_mode=build_mode) + return [l.rstrip() for l in xmlParagraphFormatter.lines] + +class _DoxygenXmlParagraphFormatter(object): + # This class follows the model of the stdlib's ast.NodeVisitor for tree traversal + # where you dispatch on the element type to a different method for each node + # during the traverse. + + # It's supposed to handle paragraphs, references, preformatted text (code blocks), and lists. + + def __init__(self): + self.ns = {} + self.lines = [''] + self.continue_line = False + # We need to track specified math labels and place them prior to the ".. math::" blocks + self.math_labels = [] + self.build_mode = None + self.verbosity = 0 + self.indent = -1 + self.options = [] + + # new + def setNS(self, ns): + self.ns = ns + + def setVerbosity(self, verbosity): + self.verbosity = verbosity + if self.verbosity > 0: print("[debug] verbosity = %s" % (self.verbosity)) + + def visit_latexonly(self, node): + if not(self.build_mode in ('latexpdf','latex')): + return + + text = node.text + if text == None: + return + + # Convert \\ref{tag} to :ref:` ` and the sphinx latex processor + # converts it to a proper label reference. + ref_match = re.search('\\\\ref{(.*?)}', text) + if ref_match is not None: + tag_string = ref_match.groups()[0] + #val = [' :ref:`%s`' % tag_string] + val = [':latex:`\\ref{%s}`' % tag_string] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # If we have then skip DoxyImage provided material + if 'skipDoxyImage' in self.options: + if text.find('DoxyImage') >= 0: + return + + # At this point, just pass everything through to latex + self.concat_text(':latex:`%s`' % (text)) + + return + + # new + # Newer versions of doxygen utilize tag in XML + # Doxygen 1.8.13 leaves all this in see: para_eqref + def visit_htmlonly(self, node): + if self.build_mode != 'html': + return + + text = node.text + if text == None: + return + + # Check for \eqref2{tag,txt} and convert to :ref:`tag`_ + eqref_match = re.search('\\\\eqref2{(.*?)}', text) + if eqref_match is not None: + tag_string = eqref_match.groups()[0] + if tag_string.find(',') >= 0: + fc = tag_string.find(',') + val = [':math:numref:`%s` - %s' % (tag_string[0:fc],tag_string[fc+1:])] + else: + val = [':math:numref:`%s`' % tag_string] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # This supports \footnotes{} + if text.find('title=') >= 0: + text = text.replace('\n',' ') + title_match = re.search('title="(.*)"', text) + if title_match: + title_string = title_match.groups()[0] + # Recover \cite that have been converted to @cite to :cite:`%s` + if title_string.find('@cite') >= 0: + citeCommand = '@cite ([\w\-\_]+)' + m = re.search(citeCommand, title_string) + while m: + replStr = title_string[m.start():m.end()] + newStr = ':cite:`%s`' % (m.groups()[0]) + title_string = title_string.replace(replStr, newStr) + m = re.search(citeCommand, title_string) + if 'footnotes' in self.ns: + self.ns['footnotes'].append(title_string) + else: + self.ns['footnotes'] = [title_string] + + val = ["[#]_"] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # Check for \eqref{ replace with :ref:`tag`_ + # Post processing of equations will place a link into the HTML + eqref_match = re.search('\\\\eqref{(.*?)}', text) + if eqref_match is not None: + tag_string = eqref_match.groups()[0] + val = [':math:numref:`%s`' % tag_string] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # undefined + if self.verbosity > 0: + print("[debug] WARNING: Uncaptured htmlonly string (%s)" % text) + + # new + # reStructured text only permits one label per math:: block + def emit_math_labels(self): + if len(self.math_labels) == 0: + return + + if self.verbosity > 0: print("[debug] inserting math labels") + + math_block_idx = -1 + for idx in range(len(self.lines)-1,0,-1): + if self.lines[idx].startswith('.. math::'): + math_block_idx = idx + break + + # Add new label right after the math:: block + if math_block_idx >=0: + new_lines = self.lines[0:math_block_idx+1] + new_label = " :label: %s" % (self.math_labels[0]) + new_lines.append(new_label) + #new_lines.append('') + self.blank_line() + new_lines = new_lines + self.lines[math_block_idx+1:] + self.lines = new_lines + + self.math_labels = [] + + # Add appropriate implicit labels from anchors + def visit_anchor(self, node): + if self.verbosity > 0: + print("[debug] anchor id(%s)" % (node.get('id'))) + citeID = node.get('id') + if citeID.find('_1CITE') == 0: + citeID = "citeref_%s" % (citeID) + implicitLink = '.. _%s:' % (citeID) + self.lines.append(implicitLink) + #self.lines.append('') + self.blank_line() + + # Original + def visit(self, node): + method = 'visit_' + node.tag + if self.verbosity > 0: print("[debug] method=%s" % (method)) + if len(self.math_labels) > 0 and node.tag != 'formula': + self.emit_math_labels() + visitor = getattr(self, method, self.generic_visit) + return visitor(node) + + def generic_visit(self, node, build_mode=None): + if build_mode: + if self.verbosity > 2: print("[debug] Setting build mode: %s" % (build_mode)) + self.build_mode = build_mode + # Perform a scan for htmlonly or latexonly to prevent double processing of + # references + if not('scanned' in self.options): + self.options.append('scanned') + self.scanNode(node) + for child in node.getchildren(): + self.visit(child) + return self + + # Scan the node and set appropriate options + def scanNode(self, node): + # NOTE: these XPath expressions must use './/' rather than '//'. + # In XPath, '//foo' is an abbreviation for /descendant-or-self::node()/foo + # starting from the *document root*, not from `node`. Because our + # autodoc_doxygen extension concatenates every doxygen XML file into a + # single merged tree (see set_doxygen_xml), every `node` passed here is + # a small subtree (e.g. a single ) whose owner + # document is the *entire* MOM6 doxygen output. Using '//' here + # therefore scans the whole merged tree on every call, which made + # scanNode the dominant cost of `make html` -- 75% of single-threaded + # build time at full MOM6 input scale, quadratic in the tree size. + # Using './/' scans only descendants of the actual node, which is what + # was intended and makes each call O(local subtree size). + xp = node.xpath('.//latexonly') + if len(xp) > 0: + self.options.append('latexonly') + xp = node.xpath('.//htmlonly') + if len(xp) > 0: + self.options.append('htmlonly') + + if 'latexonly' in self.options: + xp = node.xpath('.//image[@type="latex"]') + if len(xp) > 0: + self.options.append('skipDoxyImage') + + def visit_ref(self, node): + refid = node.get('refid') + name_node = None + ream_name = None + kind = None + + # O(1) lookup via the lazily-built id -> element index. + # The previous findall('.//*[@id=X]') on the merged tree was the + # single largest cost in `make html` under XML_PROGRAMLISTING=YES + # -- see docs/REMAINING_TASKS.md / profile notes. + hit = get_doxygen_id_index().get(refid) + if self.verbosity > 0: print("[debug] refid(%s) kindref(%s) ref(%s)" % + (refid, node.get('kindref'), hit)) + if hit is not None: + ref = hit + kind = ref.get('kind') + if self.verbosity > 0: print("[debug] ref(%s)" % ref.items()) + if ref.tag == 'memberdef': + parent = ref.xpath('./ancestor::compounddef/compoundname')[0].text + name = ref.find('./name').text + real_name = parent + '::' + name + elif ref.tag in ('compounddef', 'enumvalue'): + if kind == 'page': + # :ref: works, but requires an explicit tag placed at the top of pages + # that generates an INFO message. FIX LATER. + val = [':ref:`%s`' % ref.get('id')] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + name_node = ref.find('./name') + real_name = name_node.text if name_node is not None else '' + elif ref.tag in ('anchor','sect1','sect2','sect3','sect4'): + # If _1CITEREF_ this is a doxygen processed citation + if refid.find('_1CITEREF_') >= 0: + citation = refid[18:] + val = [':cite:`%s`' % (citation)] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + # Capture sectional links + + # Treat the rest of these as general links + if refid.find('_1') >= 0: + reftext = node.text + reftext = reftext.strip() + refid2 = refid[refid.find('_1')+2:] + if reftext != '' and reftext != refid2: + if self.verbosity > 0: print("[debug] refid2(%s) reftext(%s)" % (refid2,reftext)) + val = [':ref:`%s<%s>`' % (reftext,refid)] + else: + if self.verbosity > 0: print("[debug] refid(%s)" % (refid)) + val = [':ref:`%s`' % refid] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + else: + print('[error] Unimplemented anchor tag: %s' % (ref.tag)) + raise NotImplementedError(ref.tag) + else: + print('[error] Unimplemented tag: %s' % (ref.tag)) + raise NotImplementedError(ref.tag) + else: + real_name = None + + + # Older doxygen support 1.8.13 for citation references + if node.get('kindref') == 'member' and refid.find('_1CITEREF_') >= 0: + citation = refid[18:] + val = [':cite:`%s`' % (citation)] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # if kind='file' treat as file references + if kind == 'file': + # for now treat these as text + # TODO: references to code + val = ['``%s``' % node.text] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + #debug + code_type = 'f' + if code_type == 'f': + val = [':%s:func:`%s' % (code_type, node.text)] + else: + val = [':%s:any:`' % code_type, node.text] + if real_name: + val.extend((' <%s>`' % (real_name))) + else: + val.append('`') + if node.tail is not None: + val.append(node.tail) + + if self.verbosity > 0: print("[debug] kind(%s) real_name(%s) node_name(%s)" % + (kind, real_name, name_node)) + #self.lines[-1] += ''.join(val) + self.concat_text(''.join(val)) + + # add visit_ulink + def visit_ulink(self, node): + self.para_text('`%s <%s>`_' % (node.text, node.get('url'))) + + # add visit_emphasis + def visit_emphasis(self, node): + self.para_text('*%s*' % node.text) + + # add role_text + def role_text(self, node, role): + # Is this even used? + if self.verbosity > 0: + print("[debug] role_text") + # XXX we should probably escape preceeding whitespace... + # but there's no backward equivalent of `tail` + text = ' :%s:`%s`' % (role, node.text) + + if node.tail is not None and not node.tail.startswith(' '): + # escape following whitespace + text += '\\' + + text += ' ' # interpretered text needs surrounding whitespace + self.para_text(text) + + # add visit_image + def visit_image(self, node): + + # Filter activity based on build type and type of image + image_type = node.get('type') + if image_type == 'html' and self.build_mode != 'html': + return + if image_type == 'latex' and not(self.build_mode in ('latexpdf','latex')): + return + + if self.verbosity > 0: + print("[debug] image type(%s) mode(%s)" % (image_type, self.build_mode)) + + # node.text is None for an empty element (no caption text); + # treat that the same as an empty caption and emit `.. image::` rather + # than `.. figure::`. The fork's original code crashed with + # AttributeError on these. Doxygen produces empty elements for + # cases like an image referenced from a `\image` command with no caption. + if node.text and node.text.strip(): + type = 'figure' + else: + type = 'image' + + self.lines.append('.. %s:: /images/%s' % (type, node.get('name'))) + + if type in 'figure': + # NOTE: Escaped math equations do not play nicely with "literal strings" in python! + + caption = node.text + + # Detect simple math commands and replace them with sphinx :math: directives + mathCommand = '\\\\f\$(.*?)\\\\f\$' + m = re.search(mathCommand, caption) + while m: + replStr = caption[m.start():m.end()] + newStr = ':math:`%s`' % (m.groups()[0]) + caption = caption.replace(replStr, newStr) + m = re.search(mathCommand, caption) + + # Only html needs to be double escaped + if image_type == 'html': + caption = node.text.replace('\\','\\\\') + + #if caption.find('Phi') >= 0: + + # Search for $[math]$ and convert to \([math]\) for html + # Use :math: for latex + mathCommand = '\$(.*?)\$' + m = re.search(mathCommand, caption) + while m: + replStr = caption[m.start():m.end()] + if image_type == 'html': + newStr = '\\\\(%s\\\\)' % (m.groups()[0]) + else: + newStr = ':math:`%s`' % (m.groups()[0]) + caption = caption.replace(replStr, newStr) + m = re.search(mathCommand, caption) + + # For html, scan for \\f and remove that too + if image_type == 'html': + caption = caption.replace('\\f','') + + if self.verbosity > 0: + # For math we have to double the number of escapes so we pass an + # escape from RST to HTML. + print("[debug] caption text(%s)" % (caption)) + self.lines.extend(['', " %s" % (caption), '']) + + # add visit_superscript + def visit_superscript(self, node): + self.role_text(node, 'superscript') + + # add visit_subscript + def visit_subscript(self, node): + self.role_text(node, 'subscript') + + # add visit_sup + # Support for doxygen 1.8.13 as it passes everything to + # Support for doxygen \footnote{} + def visit_sup(self, node): + + # Skip if we detect htmlonly or latexonly + if self.para_ignore(): + return + + title_string = node.get('title') + if title_string: + citeCommand = '@cite ([\w\-\_]+)' + m = re.search(citeCommand, title_string) + while m: + replStr = title_string[m.start():m.end()] + newStr = ':cite:`%s`' % (m.groups()[0]) + title_string = title_string.replace(replStr, newStr) + m = re.search(citeCommand, title_string) + + if 'footnotes' in self.ns: + self.ns['footnotes'].append(title_string) + else: + self.ns['footnotes'] = [title_string] + + val = ["[#]_"] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + + # Ignore duplicates provided by xmlonly if we detect latexonly or htmlonly + def para_ignore(self): + + if 'latexonly' in self.options or 'htmlonly' in self.options: + return True + return False + + # add replace any references of \eqref, \eqref2, \eqref4 + # Doxygen 1.8.13 + # html: use eqref2; remove eqref4 + # latex: use eqref4; remove eqref2 + # with appropriate replacements + # Remove duplicates here if latexonly or htmlonly is detected + def para_eqref(self, text): + + chg = True + while text.find('\\\\eqref2') >= 0 and chg: + chg = False + m = re.search('\\\\eqref2{(.*?)}', text) + if m: + ref = m.groups()[0] + fullRef = '\\\\eqref2{%s}' % (ref) + if ref.find(',') >= 0: + i = ref.find(',') + sphinxRef = ':math:numref:`%s` - %s' % (ref[0:i],ref[i+1:]) + if self.build_mode in ('latexpdf','latex'): + sphinxRef = '' + if self.para_ignore(): + sphinxRef = '' + text = text.replace(fullRef, sphinxRef) + chg = True + + chg = True + while text.find('\\\\eqref') >= 0 and chg: + chg = False + m = re.search('\\\\eqref{(.*?)}', text) + if m: + ref = m.groups()[0] + fullRef = '\\\\eqref{%s}' % (ref) + if self.build_mode in ('latexpdf','latex'): + sphinxRef = ':latex:`\\ref{%s}`' % ref + else: + sphinxRef = ':math:numref:`%s`' % (ref) + if self.para_ignore(): + sphinxRef = '' + text = text.replace(fullRef, sphinxRef) + chg = True + + chg = True + while text.find('\\\\eqref4') >= 0 and chg: + chg = False + m = re.search('\\\\eqref4{(.*?)}', text) + if m: + ref = m.groups()[0] + fullRef = '\\\\eqref4{%s}' % (ref) + sphinxRef = ':latex:`\\ref{%s}`' % (ref) + if self.build_mode in ('html'): + sphinxRef = '' + if self.para_ignore(): + sphinxRef = '' + text = text.replace(fullRef, sphinxRef) + chg = True + + return text + + # Assistant for ensuring there is blank lines between directives + # It makes sure we do not overly add blank lines + def blank_line(self): + if len(self.lines) == 0: + return + + if self.lines[-1] == '': + return + + self.lines.append('') + + # Assistant for putting sentences together + def concat_text(self, text): + if len(self.lines) == 0: + self.lines.append(text) + return + + lastLine = self.lines[-1] + + if len(lastLine) == 0: + self.lines[-1] = text + return + + lastChar = lastLine[-1] + newText = text + if len(newText) == 0: + return + + firstChar = newText[0] + + # Emphasis + if lastChar == "*" or firstChar == "*": + newText = " %s" % (newText) + firstChar = " " + + # whitespace after :cite:`tag` + if lastChar == '`': + if (firstChar >= 'a' and firstChar <= 'z') or (firstChar >= 'A' and firstChar <= 'Z') or firstChar in ['(','[','{']: + newText = " %s" % (newText) + firstChar = " " + + # whitespace before :commands: + if firstChar == ':': + if (lastChar >= 'a' and lastChar <= 'z') or (lastChar >= 'A' and lastChar <= 'Z') or lastChar in [',','.','=']: + newText = " %s" % (newText) + firstChar = " " + + # Footnotes and any items that end with _ + if newText == '[#]_': + newText = " %s" % (newText) + if lastChar == '_': + if len(lastLine) > 3: + if lastLine[-4:] == "[#]_" and firstChar != '.': + newText = " %s" % (newText) + firstChar = " " + else: + newText = " %s" % (newText) + + # Inline text check for space before (``) + if len(newText) >= 2: + if newText[0:2] == "``" and lastChar != ' ': + newText = " %s" % (newText) + firstChar = " " + + self.lines[-1] += newText + return + + # add para_text parser + # Doxygen 1.8.13 support for \eqref \eqref2 + def para_text(self, text): + + if text is not None: + if text.find('Some time later') >= 0: + a = 0 + + if text.find('eqref') >= 0: + text = self.para_eqref(text) + if self.continue_line: + if len(self.lines) >= 1: + # If we are in a continue_line situation but already + # have a linefeed, do an append instead + if self.lines[-1] == '': + self.lines.append(text) + return + self.concat_text(text) + else: + self.lines.append(text) + + def visit_para(self, node): + + self.para_text(node.text) + + # visit children and append tail + for child in node.getchildren(): + self.visit(child) + self.continue_line = True + + if child.tail is not None: + self.para_text(child.tail.lstrip()) + + # replaced + #if node.text is not None: + # if self.continue_line: + # self.lines[-1] += node.text + # else: + # self.lines.append(node.text) + #self.generic_visit(node) + + self.continue_line = False + #self.lines.append('') + self.blank_line() + + # add visit_formula + def visit_formula(self, node): + text = node.text + + # Remove the faked link for pdf version + if self.build_mode in ('latexpdf','latex'): + label_match = re.search(' \\\\label{(html:.*?)}.*?\\\\\\\\', text) + if label_match: + replace_string = label_match.group() + text = text.replace(replace_string,'') + + # detect inline or block math + if text.startswith('\\[') or not text.startswith('$'): + if text.startswith('\\['): + text = text[2:-2] + + # if we are emitting a math block and we have + # pending math labels, go back and emit those + # first. + if len(self.math_labels) > 0: + self.emit_math_labels() + + self.blank_line() + if '\n' in text: + self.lines.append('.. math::') + self.lines.append('') + for mathline in text.split('\n'): + self.lines.append(' ' + mathline) + else: + self.lines.append('.. math:: ' + text) + self.blank_line() + # Math blocks require an explicit blank line as well? + #self.lines.append('') + self.continue_line = False + else: + inline = ':math:`' + node.text.strip()[1:-1].strip() + '`' + if self.continue_line: + #self.lines[-1] += inline + self.concat_text(inline) + else: + self.lines.append(inline) + + self.continue_line = True + + # detect \label{html:tag} blocks + if text.find('\\label') >= 0: + # If we have a big block of equations, supply one label + label_matches = re.findall('\\\label{html:(.*?)?}',text) + if len(label_matches) > 0: + [self.math_labels.append(i) for i in label_matches] + else: + label_matches = re.findall('\\\label{(.*?)?}',text) + if len(label_matches) > 0: + [self.math_labels.append(i) for i in label_matches] + if self.verbosity > 0: + # For math we have to double the number of escapes so we pass an + # escape from RST to HTML. + print("[debug] math_labels(%s)" % (label_matches)) + + def visit_parametername(self, node): + if 'direction' in node.attrib: + direction = '[%s] ' % node.get('direction') + else: + direction = '' + + param_name = node.text or '' + + # Look up the parameter's Fortran type from the parent + # memberdef's elements. The inside + # only carries names and descriptions; + # the types live on the siblings of . + param_type = '' + memberdefs = node.xpath('./ancestor::memberdef') + if memberdefs: + for p in memberdefs[0].findall('param'): + defname = p.find('defname') + if defname is not None and defname.text == param_name: + type_el = p.find('type') + if type_el is not None: + param_type = ''.join(type_el.itertext()).strip() + break + + # Prepend the type as literal text in the description rather + # than using :param type name: (sphinx-fortran's regex can't + # handle commas in the type) or :type name: (sphinx-fortran's + # xref resolver crashes on % in dimension expressions). + if param_type: + self.lines.append(':param %s: ``%s`` %s' % (param_name, param_type, direction)) + else: + self.lines.append(':param %s: %s' % (param_name, direction)) + self.continue_line = True + + def visit_parameterlist(self, node): + lines = [l for l in type(self)().generic_visit(node).lines if l != ''] + # replaced + #self.lines.extend([':parameters:', ''] + ['* %s' % l for l in lines] + ['']) + self.lines.extend([''] + lines + ['']) + + # TODO: Doxygen generates a simplesect for functions with + # a specified return argument. For now, we leave as + # :returns undefined: + # marker so we can fix up the document using flint. + # Supports doxygen /sa or /see command + def visit_simplesect(self, node): + if self.verbosity > 0: + print("[debug] simplesect kind(%s)" % (node.get('kind'))) + + # Do nothing for \note for now + + # fortran function handling + if node.get('kind') == 'return': + self.lines.append(':returns undefined: ') + self.continue_line = True + self.generic_visit(node) + + # Add bold text psudo section for \see, \sa roughly acts like doxygen + if node.get('kind') in ('see', 'sa'): + see_also_label = "See also" + #self.lines.append('') + self.blank_line() + self.lines.append('**%s**' % (see_also_label)) + #self.lines.append('') + self.blank_line() + #self.lines.append('') + self.generic_visit(node) + # add + + def visit_sect(self, node, char): + """Generic visit section""" + title_node = node.find('title') + if title_node is not None: + title = title_node.text + # Filter html data (possibly if we see a <, / and >) + if self.verbosity > 0: + print("[debug] visit_sect id(%s) title(%s)" % (node.get('id'),title)) + if title.find('<') >=0 and title.find('>') >=0 and title.find('/') >=0: + html_match = False + # Filter => `` + if title.find("") >= 0: + title = title.replace('','``') + title = title.replace('','`` ') + html_match = True + if not(html_match) and self.verbosity > 0: + print("[debug] unmatched html (%s)" % (title)) + # Add a implicit lable for the sections + implicitLink = '.. _%s:' % (node.get('id')) + self.lines.append(implicitLink) + #self.lines.append('') + self.blank_line() + self.lines.append(title) + self.lines.append(len(title) * char) + #self.lines.append('') + self.blank_line() + + self.generic_visit(node) + + def visit_sect1(self, node): + self.visit_sect(node, '=') + + def visit_sect2(self, node): + self.visit_sect(node, '-') + + def visit_sect3(self, node): + self.visit_sect(node, '^') + + def visit_sect4(self, node): + self.visit_sect(node, '"') + + # add end + + # allows us to handle nested ordered lists + def visit_orderedlist(self, node): + self.indent = self.indent + 1 + self.generic_visit(node) + #self.lines.append('') + self.blank_line() + self.indent = self.indent - 1 + + # allows us to handle nested itemized lists + def visit_itemizedlist(self, node): + self.indent = self.indent + 1 + self.generic_visit(node) + #self.lines.append('') + self.blank_line() + self.indent = self.indent - 1 + + # Source of citation and numbering + def visit_listitem(self, node): + #char = '*' if node.getparent().tag == 'itemizedlist' else '#.' + if node.getparent().tag == 'itemizedlist': + #self.lines.append('') + char = '*' + else: + char = '#.' + if self.verbosity > 1: print("[debug] listitem indent = %s" % (self.indent)) + self.lines.append(' '*(self.indent*2) + char + ' ') + # replaced + #self.lines.append(' - ') + self.continue_line = True + # recursion + self.generic_visit(node) + + # add + def preformat_text(self, lines): + self.lines.extend(('::', '')) + self.lines.extend([' ' + l for l in lines]) + #self.lines.append('') + self.blank_line() + + def visit_preformatted(self, node): + segment = [node.text if node.text is not None else ''] + for n in node.getchildren(): + segment.append(n.text) + if n.tail is not None: + segment.append(n.tail) + + lines = ''.join(segment).split('\n') + # add line + self.preformat_text(lines) + # extra? no effect + #self.lines.extend(('.. code-block:: C++', '')) + #self.lines.extend([' ' + l for l in lines]) + + # add + def visit_programlisting(self, node): + lines = [] + for n in node.getchildren(): + lines.append(flatten(n)) + self.preformat_text(lines) + + #add + def visit_verbatim(self, node): + self.visit_preformatted(node) + + def visit_computeroutput(self, node): + c = node.find('preformatted') + if c is not None: + return self.visit_preformatted(c) + # add + # I don't think we can put links inside + # computeroutput text... + #self.lines[-1] += '``' + flatten(node) + '`` ' + self.concat_text('``' + flatten(node) + '``') + # omitted + #return self.visit_preformatted(node) + + def visit_xrefsect(self, node): + if node.find('xreftitle').text == 'Deprecated': + sublines = type(self)().generic_visit(node).lines + self.lines.extend(['.. admonition:: Deprecated'] + [' ' + s for s in sublines]) + return + # add - if not depricated + title = node.find('xreftitle').text + sublines = type(self)().generic_visit(node).lines + self.lines.extend(['.. admonition:: %s' % title] + [' ' + s for s in sublines]) + #else: + # raise ValueError(node) + + def visit_subscript(self, node): + #self.lines[-1] += '\ :sub:`%s` %s' % (node.text, node.tail) + self.concat_text(':sub:`%s` %s' % (node.text, node.tail)) + + def visit_table(self, node): + # save the number of columns + cols = int(node.get('cols')) + table = [] + # save the current output + lines = self.lines + + # get width of each column + widths = [0] * cols + + # build up the table contents + for row_node in node.findall('row'): + row = [] + for i, entry in enumerate(row_node.getchildren()): + self.lines = [''] + self.generic_visit(entry) + row.append(self.lines) + + # find width of this entry (including leading and trailing space) + widths[i] = max(widths[i], max([len(line) for line in self.lines]) + 2) + + table.append(row) + + def append_row(row): + # find number of lines in row + num_lines = max([len(e) for e in row]) + lines = [] + + for k in range(num_lines): + line = '|' + for i, e in enumerate(row): + if k < len(e): + # this is a valid line + line += ' ' + e[k] + # pad rest of line + line += ' ' * (widths[i] - len(e[k]) - 1) + else: + # invalid line, just fill with spaces + line += ' ' * widths[i] + + line += '|' + + lines.append(line) + + return lines + + self.lines = lines + # start with a blank + #self.lines.append('') + self.blank_line() + + # usual separator line + sep = '+' + for width in widths: + sep += '-' * width + sep += '+' + + self.lines.append(sep) + + # header row + self.lines.extend(append_row(table[0])) + # header separator uses '=' instead of '-' + self.lines.append(sep.replace('-', '=')) + + # loop over body rows + for row in table[1:]: + self.lines.extend(append_row(row)) + self.lines.append(sep) + + # end with a blank + #self.lines.append('') + self.blank_line() diff --git a/docs/_static/autodoxysource.css b/docs/_static/autodoxysource.css new file mode 100644 index 0000000000..81f42425a9 --- /dev/null +++ b/docs/_static/autodoxysource.css @@ -0,0 +1,94 @@ +/* Source browser styling for autodoxysource directive. + Font stack and sizes match the sphinx_rtd_theme's code-block rules + so source listings look consistent with fenced code blocks. */ + +.autodoxysource { + font-family: SFMono-Regular, Menlo, Monaco, Consolas, "Liberation Mono", + "Courier New", Courier, monospace; + font-size: 12px; + line-height: 1.2; + background: #f8f8f8; + border: 1px solid #e1e4e5; + border-radius: 4px; + padding: 12px 0; + overflow-x: auto; + min-width: fit-content; + max-width: calc(6.5em + 120ch + 24px); +} + +.autodoxysource .source-line { + display: block; + white-space: nowrap; + margin: 0; + padding: 0 12px 0 0; + line-height: 1.2; +} + +.autodoxysource .source-code { + white-space: pre; +} + +.autodoxysource .source-line:target { + background-color: #ffffcc; +} + +.autodoxysource .source-lineno { + display: inline-block; + width: 4.5em; + text-align: right; + padding-right: 0.8em; + margin-right: 0.8em; + color: #858585; + border-right: 1px solid #e6e9ea; + text-decoration: none; + -webkit-user-select: none; + user-select: none; +} + +.autodoxysource .source-lineno:hover { + color: #333; +} + +/* Doxygen highlight classes */ +.f-hl-comment { + color: #408080; + font-style: italic; +} + +.f-hl-keyword { + color: #008000; + font-weight: bold; +} + +.f-hl-keywordtype { + color: #b00040; +} + +.f-hl-keywordflow { + color: #008000; + font-weight: bold; +} + +.f-hl-stringliteral { + color: #ba2121; +} + +.f-hl-preprocessor { + color: #bc7a00; +} + +.f-hl-normal { + color: #333; +} + +/* Make xref links within source subtle */ +.autodoxysource a.reference { + color: inherit; + text-decoration: none; + border-bottom: 1px dotted #999; +} + +.autodoxysource a.reference:hover { + border-bottom: 1px solid #333; + color: #2980b9; +} diff --git a/docs/api/files.rst b/docs/api/files.rst new file mode 100644 index 0000000000..b90fd69b86 --- /dev/null +++ b/docs/api/files.rst @@ -0,0 +1,11 @@ +.. _Files: + +============ +Source Files +============ + +.. toctree:: + :maxdepth: 1 + :glob: + + generated/source/* diff --git a/docs/apiref.rst b/docs/apiref.rst index 7f94e1c4b9..2e884ab1a6 100644 --- a/docs/apiref.rst +++ b/docs/apiref.rst @@ -11,3 +11,5 @@ The complete API documentation is generated with doxygen and can be found at htt :maxdepth: 1 api/modules + api/functions + api/files diff --git a/docs/conf.py b/docs/conf.py index 4407d88356..50bb5a9e52 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -20,11 +20,144 @@ # If extensions (or modules to document with autodoc) are in another directory, # add these directories to sys.path here. If the directory is relative to the # documentation root, use os.path.abspath to make it absolute, like shown here. -#sys.path.insert(0, os.path.abspath('.')) +sys.path.insert(0, os.path.abspath('_ext')) # -- Custom configuration values and roles ----------------------------------- from docutils import nodes +# -- Monkey-patch: fix sphinx-fortran's broken parallel-build merge ---------- +# +# Upstream VACUMM/sphinx-fortran (as of commit reachable from master, 2025-10) +# ships a FortranDomain.merge_domaindata() that has two bugs which together +# cause every f-domain object to be lost when sphinx-build is run with -j > 1: +# +# 1. The function references a name `outNames` that does not exist +# (typo for `ourNames`); accessing it raises NameError, which Sphinx's +# parallel worker error path swallows silently. +# +# 2. Even with the typo fixed, the unpack `for name, docname in +# otherdata['modules'].items()` is wrong, because `modules` values are +# 4-tuples `(docname, synopsis, platform, deprecated)` and `objects` +# values are 2-tuples `(docname, type)`, not bare docnames. +# +# Symptom: with `make html` (which passes -j 4), env.domaindata['f'] ends up +# with 0 modules and 0 objects, every :f:func:/:f:type:/:f:mod: cross- +# reference fails to resolve, and pages like f-modindex.html disappear. +# +# We patch this in-process so the existing -j 4 build still works. The fix +# is small and obvious; once it lands upstream we should pin sphinx-fortran +# to a post-fix commit and remove this patch. +# +# TODO(piece-2): submit upstream PR to VACUMM/sphinx-fortran with this fix, +# then drop this monkey-patch and pin requirements.txt to a +# post-fix commit. +def _patch_sphinx_fortran_merge_domaindata(): + try: + from sphinxfortran.fortran_domain import FortranDomain + except ImportError: + return + def merge_domaindata(self, docnames, otherdata): + ourNames = self.data['modules'] + for name, data in otherdata['modules'].items(): + # data == (docname, synopsis, platform, deprecated) + if data[0] in docnames and name not in ourNames: + ourNames[name] = data + ourNames = self.data['objects'] + for name, data in otherdata['objects'].items(): + # data == (docname, type) + if data[0] in docnames and name not in ourNames: + ourNames[name] = data + FortranDomain.merge_domaindata = merge_domaindata +_patch_sphinx_fortran_merge_domaindata() + +# -- Monkey-patch: stop sphinx.util.math.wrap_displaymath from double-wrapping +# LaTeX environments that the source already provides -------------------- +# +# MOM6's documentation contains a lot of math written directly with explicit +# LaTeX environments (`\begin{equation}`, `\begin{eqnarray}`, `\begin{align}`) +# inside `.. math::` directives. By default, Sphinx's wrap_displaymath() takes +# the body of a single-part `.. math::` directive and wraps it in +# `\begin{split}...\end{split}` and then again in `\begin{equation}` (or the +# starred unnumbered form). When the body already contains its own +# `\begin{equation}` etc., that produces nested LaTeX environments and +# pdflatex chokes. +# +# Sphinx's official workaround is the `:nowrap:` option on every affected +# `.. math::` directive, which would mean editing every math directive +# upstream in the MOM6 source tree. The jr3cermak/sphinx fork that the docs +# build previously depended on instead patched wrap_displaymath() so that any +# part containing one of these begin-environments is emitted verbatim and the +# outer wrapping is suppressed. We replicate that behavior here as a +# function-level monkey-patch on stock upstream Sphinx, so we can build +# against unmodified Sphinx 8.x. +# +# The detection is intentionally a plain substring search, matching the +# fork's behavior — `begin{equation`, `begin{eqnarray`, and `begin{align` all +# also match their starred and `aligned`/`equation*` variants. This is the +# same heuristic the fork shipped and what the existing MOM6 sources expect. +# +# Sphinx upstream issue tracking the same problem has been open since 2017 +# (sphinx-doc/sphinx#3785). A faithful upstream PR would be the right +# long-term fix, but that conversation is much older than this MOM6 upgrade +# work, so we are not blocking on it. +# +# TODO(piece-3): consider submitting a cleaner version upstream and dropping +# this patch when/if it lands. +def _patch_sphinx_wrap_displaymath(): + import sphinx.util.math as _sm + + def wrap_displaymath(text, label, numbering): + def is_equation(part): + return part.strip() + + if label is None: + labeldef = '' + else: + labeldef = r'\label{%s}' % label + numbering = True + + parts = list(filter(is_equation, text.split('\n\n'))) + + # Detect parts that already supply their own LaTeX environment. + nowrap = any( + ('begin{equation' in p) or + ('begin{eqnarray' in p) or + ('begin{align' in p) + for p in parts + ) + + equations = [] + if len(parts) == 0: + return '' + elif len(parts) == 1: + if numbering: + begin = r'\begin{equation}' + labeldef + end = r'\end{equation}' + else: + begin = r'\begin{equation*}' + labeldef + end = r'\end{equation*}' + if nowrap: + equations.append('%s\n' % parts[0]) + else: + equations.append('\\begin{split}%s\\end{split}\n' % parts[0]) + else: + if numbering: + begin = r'\begin{align}%s\!\begin{aligned}' % labeldef + end = r'\end{aligned}\end{align}' + else: + begin = r'\begin{align*}%s\!\begin{aligned}' % labeldef + end = r'\end{aligned}\end{align*}' + equations.extend('%s\\\\\n' % part.strip() for part in parts) + + if nowrap: + begin = '' + end = '' + + return '%s\n%s%s' % (begin, ''.join(equations), end) + + _sm.wrap_displaymath = wrap_displaymath +_patch_sphinx_wrap_displaymath() + def setup(app): app.add_config_value('sphinx_build_mode', '', 'env') app.add_role('latex', latexPassthru) @@ -137,13 +270,18 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): extensions = [ 'sphinxcontrib.bibtex', 'sphinx.ext.ifconfig', - 'sphinxcontrib.autodoc_doxygen', + 'autodoc_doxygen', 'sphinxfortran.fortran_domain', ] bibtex_bibfiles = ['ocean.bib', 'references.bib', 'zotero.bib'] autosummary_generate = ['api/modules.rst', 'api/pages.rst'] -doxygen_xml = 'xml' +# Absolute path so the autodoc_doxygen extension can find the doxygen XML +# output regardless of what cwd Sphinx has at builder-inited time. This +# previously broke on RTD, where `sphinx-build -M html docs ...` runs from +# the repo root rather than from `docs/`, and the extension's os.path.isdir +# check resolved "xml" against the wrong directory. +doxygen_xml = os.path.join(os.path.dirname(os.path.abspath(__file__)), 'xml') # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] @@ -182,7 +320,17 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # List of patterns, relative to source directory, that match files and # directories to ignore when looking for source files. -exclude_patterns = ['_build', 'details', 'src', 'Thumbs.db', '.DS_Store'] +exclude_patterns = [ + '_build', '_build.*', + 'details', 'src', 'Thumbs.db', '.DS_Store', + # Local virtualenvs that may sit alongside the docs source. Sphinx walks + # the entire source tree by default and otherwise picks up LICENSE.rst, + # README.rst, autosummary template files, etc. from inside site-packages + # and reports them as "isn't included in any toctree". + 'venv', 'venv.*', 'venv-*', + # Vendored extension's Jinja2 templates are not real .rst documents. + '_ext/*/templates', '_ext/*/*/templates', +] # The reST default role (used for this markup: `text`) to use for all # documents. @@ -241,7 +389,7 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # Add any paths that contain custom static files (such as style sheets) here, # relative to this directory. They are copied after the builtin static files, # so a file named "default.css" will overwrite the builtin "default.css". -#html_static_path = ['_static'] +html_static_path = ['_static'] # Add any extra paths that contain custom files (such as robots.txt or # .htaccess) here, relative to this directory. These files are copied diff --git a/docs/requirements.txt b/docs/requirements.txt index b38dbc34b7..ef24c6989b 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -1,18 +1,16 @@ -git+https://github.com/jr3cermak/sphinx.git@v3.2.1mom6.4 -git+https://github.com/jr3cermak/sphinxcontrib-autodoc_doxygen.git@0.7.13#egg=sphinxcontrib-autodoc_doxygen -git+https://github.com/jr3cermak/sphinx-fortran.git@1.2.2#egg=sphinx-fortran -git+https://github.com/jr3cermak/flint.git@0.0.1#egg=flint +sphinx>=8,<9 sphinx-rtd-theme sphinxcontrib-bibtex -# requirements.txt not working from sphinx-fortran +# lxml is required by the vendored docs/_ext/autodoc_doxygen extension +# (used to parse Doxygen XML output). +lxml numpy + +# Upstream VACUMM/sphinx-fortran has not cut a PyPI release past 1.1.1 but +# its master branch has had continued fixes through 2025. Pinned to a +# specific commit for reproducibility. See Notes-sphinx-upgrade.md (piece 2). +# NB: this commit contains a broken FortranDomain.merge_domaindata that we +# monkey-patch in conf.py to keep parallel builds (-j > 1) working. sphinx- +# fortran also still imports `six` at module load time on this commit. +git+https://github.com/VACUMM/sphinx-fortran.git@b14f438c1cc74d1dbcd5acd9a330c3b509caab56#egg=sphinx-fortran six -future -# Old Sphinx requires an old Jinja2 -jinja2<3.1 -sphinxcontrib_applehelp<1.0.8 -sphinxcontrib_devhelp<1.0.6 -sphinxcontrib_htmlhelp<2.0.5 -sphinxcontrib_qthelp<1.0.7 -sphinxcontrib_serializinghtml<1.0.7 -alabaster<0.7.14 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index e319b71ddc..e8bde7791d 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -55,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 @@ -142,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 @@ -240,7 +242,7 @@ subroutine ALE_init( param_file, G, 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.", & @@ -294,6 +296,13 @@ subroutine ALE_init( param_file, G, 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 "//& @@ -307,7 +316,7 @@ subroutine ALE_init( param_file, G, 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) @@ -415,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 @@ -1186,9 +1195,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 @@ -1261,9 +1270,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 @@ -1609,11 +1618,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 @@ -1672,6 +1681,45 @@ 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(G, GV, US, max_depth, param_file, mdl, regridCS) @@ -1796,7 +1844,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 d3a889ed99..0ac424b2d0 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -429,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 diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 index 68a193cebe..921ccecccc 100644 --- a/src/ALE/MOM_hybgen_remap.F90 +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -275,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 1dfae7a167..dee62ef47c 100644 --- a/src/ALE/MOM_hybgen_unmix.F90 +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -216,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 diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 28ea5b13cb..b34314e207 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -102,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 @@ -219,7 +226,7 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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 + 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 @@ -238,8 +245,8 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & ! 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 :: 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] @@ -434,8 +441,16 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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 @@ -453,9 +468,9 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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 @@ -505,7 +520,7 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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)) @@ -575,13 +590,13 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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 + 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 + enddo ; enddo if (main_parameters) then call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) @@ -642,7 +657,7 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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 + 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)) @@ -663,7 +678,7 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & enddo endif !integer:else endif !mask2dT - enddo; enddo + enddo ; enddo varName = trim( extractWord(trim(string(12:)), 4) ) if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz_3d allocate(dz(ke)) @@ -673,13 +688,13 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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 + 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 + enddo ; enddo if (main_parameters) then call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) @@ -706,7 +721,7 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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 + 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)) @@ -722,7 +737,7 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & enddo endif !integer:else endif !mask2dT - enddo; enddo + enddo ; enddo endif !dz deallocate(index_map) deallocate(rho_target_2d) @@ -852,7 +867,7 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & 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 + 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) @@ -861,11 +876,11 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & rho_target_3d(i,j,k) = rho_target(k) enddo endif !mask2dT - enddo; enddo + enddo ; enddo endif - do i=G%isc-1,G%iec+1; do j=G%jsc-1,G%jec+1 + do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1 if (G%mask2dT(i,j)>0.) then - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*US%Z_to_m + 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) @@ -890,7 +905,7 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & endif !depth_s endif !nominalDepth endif !mask2dT - enddo; enddo + enddo ; enddo endif !n_sigma deallocate(dz_shallow) endif !REGRIDDING_HYCOM1 @@ -983,8 +998,14 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & "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 @@ -1063,9 +1084,9 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & ", initialize_regridding: "// & "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(longString)//")") 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.") endif @@ -1129,8 +1150,8 @@ subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, 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.") endif @@ -1210,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 @@ -1245,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 @@ -1669,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) @@ -1694,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 @@ -1768,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) @@ -1915,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 @@ -2045,11 +2069,12 @@ subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, 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 @@ -2418,7 +2444,7 @@ subroutine setCoordinateResolution_3d( dz_3d, CS, scale ) !! 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 [m -> Z] + 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: '//& @@ -2459,7 +2485,7 @@ end subroutine set_target_densities_from_GV 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 [kg m-3 -> R] + 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)) & @@ -2758,8 +2784,8 @@ 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) @@ -2768,9 +2794,11 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri 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] @@ -2801,6 +2829,8 @@ 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(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 = & @@ -2812,6 +2842,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri endif if (present(min_thickness)) CS%min_thickness = min_thickness + if (present(use_adjust_interface_motion)) CS%use_adjust_interface_motion = use_adjust_interface_motion if (present(compress_fraction)) CS%compressibility_fraction = compress_fraction if (present(ref_pressure)) CS%ref_pressure = ref_pressure if (present(integrate_downward_for_e)) CS%integrate_downward_for_e = integrate_downward_for_e diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index e22b148c23..d32b957717 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -38,6 +38,7 @@ module MOM_remapping use Recon1d_EPPM_CWK, only : EPPM_CWK use Recon1d_PPM_H4_2019, only : PPM_H4_2019 use Recon1d_PPM_H4_2018, only : PPM_H4_2018 +use Recon1d_PLM_WLS, only : PLM_WLS implicit none ; private @@ -439,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 @@ -1795,6 +1796,9 @@ subroutine setReconstructionType(string,CS) case ("C_PPM_H4_2018") allocate( PPM_H4_2018 :: CS%reconstruction ) CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PLM_WLS") + allocate( PLM_WLS :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS case default call MOM_error(FATAL, "setReconstructionType: "//& "Unrecognized choice for REMAPPING_SCHEME ("//trim(string)//").") @@ -2114,6 +2118,7 @@ logical function remapping_unit_tests(verbose, num_comp_samp) type(PPM_hybgen) :: PPM_hybgen_instance type(PPM_CWK) :: PPM_CWK_instance type(EPPM_CWK) :: EPPM_CWK_instance + type(PLM_WLS) :: PLM_WLS_instance call test%set( verbose=verbose ) ! Sets the verbosity flag in test ! call test%set( stop_instantly=.true. ) ! While debugging @@ -2743,6 +2748,7 @@ logical function remapping_unit_tests(verbose, num_comp_samp) call test%test( PPM_CW_instance%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CW unit test') call test%test( PPM_CWK_instance%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CWK unit test') call test%test( EPPM_CWK_instance%unit_tests(verbose, test%stdout, test%stderr), 'EPPM_CWK unit test') + call test%test( PLM_WLS_instance%unit_tests(verbose, test%stdout, test%stderr), 'PLM_WLS unit test') ! Randomized, brute force tests ntests = 3000 @@ -2772,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) @@ -2798,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) @@ -2809,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/Recon1d_PCM.F90 b/src/ALE/Recon1d_PCM.F90 index 3225e25985..efb943c354 100644 --- a/src/ALE/Recon1d_PCM.F90 +++ b/src/ALE/Recon1d_PCM.F90 @@ -19,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 @@ -38,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 @@ -107,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 @@ -183,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 0e966d2e48..be42a399f0 100644 --- a/src/ALE/Recon1d_PLM_CW.F90 +++ b/src/ALE/Recon1d_PLM_CW.F90 @@ -25,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 @@ -47,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 @@ -196,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 @@ -336,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 b5a6266f0e..1e20f87318 100644 --- a/src/ALE/Recon1d_PLM_CWK.F90 +++ b/src/ALE/Recon1d_PLM_CWK.F90 @@ -31,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..f32ff59b73 --- /dev/null +++ b/src/ALE/Recon1d_PLM_WLS.F90 @@ -0,0 +1,473 @@ +!> Piecewise Linear Method using Weighted Conservative Least Squares 1D reconstruction +module Recon1d_PLM_WLS + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PLM_WLS, testing + +!> PLM reconstruction using Weighted Least Squares constrained to conserve for central cell +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - x() -> recon1d_type.x() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PLM_WLS + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + real, allocatable, private :: slp(:) !< Difference across cell, ur - ul [A]. + !! This is redundant with ul and ur and not used + !! in any evaluations, but is needed for testing. + +contains + !> Implementation of the PLM_WLS initialization + procedure :: init => init + !> Implementation of the PLM_WLS reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PLM_WLS average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PLM_WLS reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PLM_WLS reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PLM_WLS + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PLM_WLS reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PLM_WLS reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PLM_WLS + +contains + +!> Initialize a 1D PLM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PLM_WLS), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + allocate( this%slp(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PLM_WLS reconstruction based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PLM_WLS), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_l0, h_r0 ! Thickness of left and right cells with h_neglect added [H] + real :: hx2l, hx2r ! Contributions to denominator, [H3] + real :: hxyl, hxyr ! Contributions to numerator, [H2 A] + integer :: n, km1, k, kp1 + + n = this%n + + ! Loop over all cells + do k = 1, n + km1 = max(1, k-1) + kp1 = min(n, k+1) + u_l = u(km1) + u_c = u(k) + u_r = u(kp1) + + h_l = h(km1) * real( k - km1 ) ! This zeroes h_l at k==1 + h_c = h(k) + h_r = h(kp1) * real( kp1 - k ) ! This zeroes h_r at k==n + + ! This is the slope that minimizes the error + ! sum_l={-1,1} h(k+l) * [ u(k+l) - u(k) + slp * ( z(k+l) - z(k) ) ] + ! i.e. volume weighted least squares + h_l0 = h_l + this%h_neglect + h_r0 = h_r + this%h_neglect + hxyl = ( h_l * ( h_c + h_l ) ) * ( u_c - u_l ) + hxyr = ( h_r * ( h_c + h_r ) ) * ( u_r - u_c ) + hx2l = h_l0 * ( h_c + h_l0 )**2 + hx2r = h_r0 * ( h_c + h_r0 )**2 + slp = 2. * h_c * ( hxyr + hxyl ) / ( hx2l + hx2r ) + + ! Mean value + this%u_mean(k) = u_c + + ! Left edge + this%ul(k) = u_c - 0.5 * slp + + ! Right edge + this%ur(k) = u_c + 0.5 * slp + + ! Store slope + this%slp(k) = slp + enddo + +end subroutine reconstruct + +!> Value of PLM_WLS reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PLM_WLS), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: du ! Difference across cell [A] + + du = this%ur(k) - this%ul(k) + + ! This expression might be used beyond the element to evaluate + ! LS errors. In other PLM implementations x is bounded to the + ! element and the expressions are constructed to not exceed + ! bounds. There are no such constraints for PLM_WLS. + f = this%u_mean(k) + du * ( x - 0.5) + !f = this%u_mean(k) + this%slp(k) * ( x - 0.5) + +end function f + +!> Derivative of PLM_WLS reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PLM_WLS), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + dfdx = this%ur(k) - this%ul(k) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PLM reconstruction [A] +real function average(this, k, xa, xb) + class(PLM_WLS), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xmab ! Mid-point between xa and xb (0 to 1) + real :: u_a, u_b ! Values at xa and xb [A] + + ! Mid-point between xa and xb + xmab = 0.5 * ( xa + xb ) + + ! This expression for u_a can overshoot u_r but is good for xmab<<1 + u_a = this%ul(k) + ( this%ur(k) - this%ul(k) ) * xmab + ! This expression for u_b can overshoot u_l but is good for 1-xmab<<1 + u_b = this%ur(k) + ( this%ul(k) - this%ur(k) ) * ( 1. - xmab ) + + ! Since u_a and u_b are both bounded, this will perserve uniformity but will the + ! sum be bounded? Emperically it seems to work... + average = 0.5 * ( u_a + u_b ) + +end function average + +!> Deallocate the PLM reconstruction +subroutine destroy(this) + class(PLM_WLS), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PLM_WLS reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PLM_WLS), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + real :: slp ! Cell slope [A] + type(PLM_WLS) :: perturbed !< A perturbed reconstruction + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_l0, h_r0, h_c0 ! Thickness of left, right, center cells with h_neglect added [H] + real :: x_l, x_r ! Positions of left and right cells [H] + real :: hx2l, hx2r ! Contributions to denominator, [H3] + real :: hxyl, hxyr ! Contributions to numerator, [H2 A] + real :: hy2l, hy2r ! Contributions to error, [H3] + real :: y_l, y_r ! Left, right, value differencess [A] + real :: b_h, bp_h ! slp / h_c [A H-1] + integer :: km1, kp1 + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + + ! Create a perturbable reconstruction + perturbed = this ! Complete copy of this + ! Check the copy is identical + do k = 1, this%n + if ( abs( perturbed%u_mean(k) - this%u_mean(k) ) > 0. ) check_reconstruction = .true. + if ( abs( perturbed%ul(k) - this%ul(k) ) > 0. ) check_reconstruction = .true. + if ( abs( perturbed%ur(k) - this%ur(k) ) > 0. ) check_reconstruction = .true. + if ( abs( perturbed%slp(k) - this%slp(k) ) > 0. ) check_reconstruction = .true. + enddo + ! The !DIR$ NOINLINE directive would be needed here to avoid ifort -O2 changing answers + ! Now perturb the slope. The local error should not decrease. + do k = 1, this%n + slp = this%slp(k) * ( 1.0 + 1. * epsilon(slp) ) + perturbed%slp(k) = slp + perturbed%ul(k) = u(k) - 0.5 * slp + perturbed%ur(k) = u(k) + 0.5 * slp + if ( LS_error(perturbed, k, h, u) < LS_error(this, k, h, u) ) check_reconstruction = .true. + + slp = this%slp(k) * ( 1.0 - 1. * epsilon(slp) ) + perturbed%slp(k) = slp + perturbed%ul(k) = u(k) - 0.5 * slp + perturbed%ur(k) = u(k) + 0.5 * slp + if ( LS_error(perturbed, k, h, u) < LS_error(this, k, h, u) ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Returns local least squares error for a particular cell +!! +!! Note that this is the error relative to the minimum of the loss function so that at the +!! true solution this function returns zero. See module documentation. +real function LS_error(this, k, h, u) + type(PLM_WLS), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_l0, h_r0, hc0 ! Thickness of left, right, center cells with h_neglect added [H] + real :: hx2l, hx2r ! Contributions to denominator, [H3] + real :: hxyl, hxyr ! Contributions to numerator, [H2 A] + real :: slp ! The PLM slopes (difference across cell) [A] + integer :: km1, kp1 + + km1 = max(1, k-1) + kp1 = min(this%n, k+1) + u_l = u(km1) + u_c = u(k) + u_r = u(kp1) + + h_l = h(km1) * real( k - km1 ) ! This zeroes h_l at k==1 + h_r = h(kp1) * real( kp1 - k ) ! This zeroes h_r at k==n + h_c = h(k) + hc0 = h_c + this%h_neglect + + h_l0 = h_l + this%h_neglect + h_r0 = h_r + this%h_neglect + hxyl = ( h_l * ( h_c + h_l ) ) * ( u_c - u_l ) + hxyr = ( h_r * ( h_c + h_r ) ) * ( u_r - u_c ) + hx2l = h_l0 * ( h_c + h_l0 )**2 + hx2r = h_r0 * ( h_c + h_r0 )**2 + slp = 2. * h_c * ( hxyr + hxyl ) / ( hx2l + hx2r ) + LS_error = h_c * ( ( hx2l + hx2r ) * ( this%slp(k) - slp ) )**2 + LS_error = LS_error / ( hc0 * ( hx2l + hx2r ) ) +end function LS_error + +!> Runs PLM_WLS reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PLM_WLS), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3, h_neglect=1.e-20) + call test%test( this%n /= 3, "Setting number of levels") + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/1.,1.,1./), (/-1.,0.,2./) ) + call test%real_arr(3, this%slp, (/1.,1.5,2./), "(1,1,1)(-1,0,2) slope") + + do k = 1, 3 + um(k) = LS_error(this, k, (/1.,1.,1./), (/-1.,0.,2./) ) + enddo + call test%real_arr(3, um, (/0.,0.,0./), "(1,1,1)(-1,0,2) LS' rel error") + + call this%reconstruct( (/0.,1.,1./), (/-1.,0.,2./) ) + call test%real_arr(3, this%slp, (/0.,2.,2./), "(0,1,1)(-1,0,2) slope") + + do k = 1, 3 + um(k) = LS_error(this, k, (/0.,1.,1./), (/-1.,0.,2./) ) + enddo + call test%real_arr(3, um, (/0.,0.,0./), "(0,1,1)(-1,0,2) LS' rel error") + + call this%reconstruct( (/1.,1.,1./), (/-2.,0.,1./) ) + call test%real_arr(3, this%slp, (/2.,1.5,1./), "(1,1,1)(-2,0,1) slope") + + call this%reconstruct( (/1.,1.,0./), (/-2.,0.,1./) ) + call test%real_arr(3, this%slp, (/2.,2.,0./), "(1,1,0)(-2,0,1) slope") + + call this%destroy() + call this%init(3) ! Reset to defaults + + ! Straight line data on uniform grid + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), "Straight line data") + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,4./), "Evaluation on left edge") + call test%real_arr(3, um, (/1.,3.,5./), "Evaluation in center") + call test%real_arr(3, ur, (/2.,4.,6./), "Evaluation on right edge") + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/2.,2.,2./), "dfdx on left edge") + call test%real_arr(3, um, (/2.,2.,2./), "dfdx in center") + call test%real_arr(3, ur, (/2.,2.,2./), "dfdx on right edge") + + do k = 1, 3 + um(k) = LS_error(this, k, (/2.,2.,2./), (/1.,3.,5./) ) + enddo + call test%real_arr(3, um, (/0.,0.,0./), "Rel error is 0") + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.5 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.25,3.25,5.25/), "Return interval average") + + call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0') + call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5') + call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1') + call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0') + call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5') + call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1') + call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0') + call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5') + call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + deallocate( um, ul, ur ) + + unit_tests = test%summarize("PLM_WLS:unit_tests") + +end function unit_tests + +!> \namespace recon1d_plm_wls +!! +!! This implementation of PLM fits the slope using least squares, but retains conservation +!! for the central cell by passing through the central value. +!! Cell-wise reconstructions are NOT limited by neighbours. +!! Thus, this reconstruction does not yield monotonic profiles needed for the general remapping problem. +!! +!! The algorithm solves the least squares problem of fitting a straight line through +!! the neighboring data. The line is constained to pass through the center cell, +!! \f$ (x_{k}, y_{k}) \f$, so that the construction is conservative. The more general +!! function \f$ f(x) = a_{k} + b_{k} x \f$ would not conserve for arbitrary data. +!! +!! The unknown parameter \f$ b_{k} \f$ in the line +!! \f[ +!! f(x) = y_{k} + b_{k} ( x - x_{k} ) / h_{k} +!! \f] +!! is fit to neighbors \f$ x_{k-1}, y_{k-1} \f$ and \f$ x_{k+1}, y_{k+1} \f$. +!! +!! Denoting \f$ y'_{k+j} = y_{k+j} - y_{k} \f$ and \f$ x'_{k+j} = x_{k+j} - x_{k} \f$ +!! the local error is +!! \f{align}{ +!! e_{k+j} &= b_k \frac{ x_{k+j} - x_{k} }{ h_{k} } + y_{k} - y_{k+j} \\\\ +!! &= b_k \frac{ x'_{k+j} }{ h_{k} } - y'_{k+j} +!! \;\; . \f} +!! +!! We use volume weighting in the loss +!! \f[ +!! G(b) = h_{k-1} e_{k-1}^2 + h_{k+1} e_{k+1}^2 +!! \;\; . \f] +!! +!! When solving for \f$ b_k \f$, we solve \f$ dG/db = 0 \f$ where +!! \f{align}{ +!! dG/db &= 2 h_{k-1} e_{k-1} \frac{ de_{k-1} }{db} + 2 h_{k+1} e_{k+1} \frac{ de_{k+1} }{db} \\\\ +!! &= 2 h_{k-1} ( b_k \frac{ x'_{k-1} }{ h_{k} } - \frac{ y'_{k-1} ) x'_{k-1} }{ h_{k} } + +!! 2 h_{k+1} ( b_k \frac{ x'_{k+1} }{ h_{k} } - \frac{ y'_{k+1} ) x'_{k+1} }{ h_{k} } \\\\ +!! &= 4 b_k \frac{ < h x'^2 > }{ h_{k}^2 } - 4 \frac{ < h x' y' > }{ h_{k} } +!! \f} +!! and where \f$ < a > = \frac{1}{2} ( a_{k-1} + a_{k+1} ) \f$. +!! Thus +!! \f[ +!! b_k = \frac{ h_{k} < h x' y' > }{ < h x'^2 > } \;\; . +!! \f] +!! +!! When evaluating the loss, \f$ G \f$, some rearrangement is necessary to reduce truncation +!! errors. Since +!! \f{align}{ +!! e_{k+j}^2 &= \left( b \frac{ x'_{k+j} }{ h_{k} } - y'_{k+j} \right)^2 \\\\ +!! &= b^2 \frac{ {x'}_{k+j}^2 }{ h_{k}^2 } - 2 b \frac{ x'_{k+j} y'_{k+j} }{ h_{k} } + {y'}_{k+j}^2 +!! \f} +!! then +!! \f{align}{ +!! G(b) &= 2 < h e^2 > \\\\ +!! &= 2 b^2 \frac{ < h {x'}^2 > }{ h_{k}^2 } - 4 b \frac{ < h x' y' > }{ h_{k} } + 2 < h {y'}^2 > +!! \;\; . +!! \f} +!! +!! If we denote the value of b that yields the minimum value as \f$ b^* \f$ then +!! \f[ +!! G(b^*) = 2 < h {y'}^2 > - \frac{ 2 < h x' y' >^2 }{ < h {x'}^2 > } +!! \;\; . +!! \f] +!! +!! Let +!! \f{align}{ +!! G''(b) &= G(b) - G(b^*) \\\\ +!! &= 2 b^2 \frac{ < h {x'}^2 > }{ h_{k}^2 } - 4 b \frac{ < h x' y' > }{ h_{k} } +!! + 2 \frac{ < h x' y' >^2 }{ < h {x'}^2 > } \\\\ +!! &= 2 \frac{ \left( b < h {x'}^2 > - h_{k} < h x' y' > \right)^2 }{ h_{k} < h {x'}^2 > } +!! \;\; . +!! \f} +!! Minimizing \f$ G''(b) \f$ is equivalent to minimizing \f$ G(b) \f$ for the same data. +!! \f$ G''(b^*)=0 \f$ so evaluation with the last form, in the vicinity of \f$ b^* \f$, avoids +!! large cancelling terms. + +end module Recon1d_PLM_WLS diff --git a/src/ALE/Recon1d_PLM_hybgen.F90 b/src/ALE/Recon1d_PLM_hybgen.F90 index aa33ce7443..0d5fa26e26 100644 --- a/src/ALE/Recon1d_PLM_hybgen.F90 +++ b/src/ALE/Recon1d_PLM_hybgen.F90 @@ -31,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 @@ -360,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 27be489b7f..7a0734ec88 100644 --- a/src/ALE/Recon1d_PPM_CW.F90 +++ b/src/ALE/Recon1d_PPM_CW.F90 @@ -28,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 @@ -51,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 @@ -154,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 @@ -335,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' @@ -368,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 @@ -394,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 07256b4372..42d6cd04f7 100644 --- a/src/ALE/Recon1d_PPM_CWK.F90 +++ b/src/ALE/Recon1d_PPM_CWK.F90 @@ -29,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 @@ -52,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 @@ -139,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 @@ -217,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 @@ -375,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_2019.F90 b/src/ALE/Recon1d_PPM_H4_2019.F90 index 26985be644..2dc3315eaf 100644 --- a/src/ALE/Recon1d_PPM_H4_2019.F90 +++ b/src/ALE/Recon1d_PPM_H4_2019.F90 @@ -365,10 +365,10 @@ subroutine end_value_h4(dz, u, Csys) Wt(2,4) = -4.0 * I_h1234 * (I_h23 * (I_h123 + I_h234)) ! Wt*h1^3 > -4* (h1/h23)*(1+h1/h234) Wt(3,4) = 4.0 * I_denom ! = 4.0*I_h1234 * I_h234 * I_h34 ! Wt*h1^3 < 4 * (h1/h234)*(h1/h34) - Csys(1) = ((u(1) + Wt(1,1) * (u(2)-u(1))) + Wt(2,1) * (u(3)-u(2))) + Wt(3,1) * (u(4)-u(3)) - Csys(2) = (Wt(1,2) * (u(2)-u(1)) + Wt(2,2) * (u(3)-u(2))) + Wt(3,2) * (u(4)-u(3)) - Csys(3) = (Wt(1,3) * (u(2)-u(1)) + Wt(2,3) * (u(3)-u(2))) + Wt(3,3) * (u(4)-u(3)) - Csys(4) = (Wt(1,4) * (u(2)-u(1)) + Wt(2,4) * (u(3)-u(2))) + Wt(3,4) * (u(4)-u(3)) + Csys(1) = ((u(1) + (Wt(1,1) * (u(2)-u(1)))) + (Wt(2,1) * (u(3)-u(2)))) + (Wt(3,1) * (u(4)-u(3))) + Csys(2) = ((Wt(1,2) * (u(2)-u(1))) + (Wt(2,2) * (u(3)-u(2)))) + (Wt(3,2) * (u(4)-u(3))) + Csys(3) = ((Wt(1,3) * (u(2)-u(1))) + (Wt(2,3) * (u(3)-u(2)))) + (Wt(3,3) * (u(4)-u(3))) + Csys(4) = ((Wt(1,4) * (u(2)-u(1))) + (Wt(2,4) * (u(3)-u(2)))) + (Wt(3,4) * (u(4)-u(3))) ! endif ! End of non-uniform layer thickness branch. diff --git a/src/ALE/Recon1d_PPM_hybgen.F90 b/src/ALE/Recon1d_PPM_hybgen.F90 index 72fc374be4..343da5d8e8 100644 --- a/src/ALE/Recon1d_PPM_hybgen.F90 +++ b/src/ALE/Recon1d_PPM_hybgen.F90 @@ -28,7 +28,7 @@ module Recon1d_PPM_hybgen !! The source for the methods ultimately used by this class are: !! - init() -> recon1d_ppm_cw.init() !! - reconstruct() *locally defined -!! - average() -> recon1d_ppm_cw.average() +!! - average() *locally defined but calls recon1d_ppm_cw.average() !! - f() -> recon1d_ppm_cw.f() !! - dfdx() -> recon1d_ppm_cw.dfdx() !! - check_reconstruction() *locally defined @@ -42,6 +42,8 @@ module Recon1d_PPM_hybgen contains !> Implementation of the PPM_hybgen reconstruction procedure :: reconstruct => reconstruct + !> Implementation of the PPM_hybgen average over an interval [A] + procedure :: average => average !> Implementation of check reconstruction for the PPM_hybgen reconstruction procedure :: check_reconstruction => check_reconstruction !> Implementation of unit tests for the PPM_hybgen reconstruction @@ -51,212 +53,85 @@ module Recon1d_PPM_hybgen contains -!> Calculate a 1D PPM_hybgen reconstructions based on h(:) and u(:) +!> Calculate a 1D PPM_hybgen reconstruction based on h(:) and u(:) +!! +!! First pass: hybgen_ppm_coefs() computes initial edge estimates with CW monotonicity. +!! Second pass: applies OM4-era bound_edge_values() and check_discontinuous_edge_values(), +!! then the standard CW PPM limiter (post-2018 expressions, answer_date=99991231). +!! This reproduces bit-for-bit the behavior of the old-style PPM_HYBGEN scheme. subroutine reconstruct(this, h, u) class(PPM_hybgen), intent(inout) :: this !< This reconstruction real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] real, intent(in) :: u(*) !< Cell mean values [A] ! Local variables - real :: h0, h1, h2, h3 ! Cell thickness h(k-2), h(k-1), h(k), h(k+1) in K loop [H] - real :: h01_h112, h23_h122 ! Approximately 2/3 [nondim] - real :: h112, h122 ! Approximately 3 h [H] - real :: ddh ! Approximately 0 [nondim] - real :: I_h12, I_h01, I_h0123 ! Reciprocals of d12 and sum(h) [H-1] - real :: dul, dur ! Left and right cell PLM slopes [A] - real :: u0, u1, u2 ! Far left, left, and right cell values [A] - real :: edge ! Edge value between cell k-1 and k [A] - real :: u_min, u_max ! Minimum and maximum value across edge [A] - real :: a6 ! Colella and Woodward curvature [A] - real :: du, duc ! Difference between edges across cell [A] - real :: slp(this%n) ! PLM slope [A] - real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as - ! differences across the cell [A] - real :: slope_x_h ! retained PLM slope times half grid step [A] - real :: edge_l, edge_r ! Edge values (left and right) [A] - real :: expr1, expr2 ! Temporary expressions [A2] - real :: u0_avg ! avg value at given edge [A] - integer :: k, n, km1, kp1 + integer :: k, n + real :: ppoly_e(this%n, 2) ! PPM edge values [A] + real :: u_l, u_c, u_r ! Left, center, right cell averages [A] + real :: edge_l, edge_r ! Left and right edge values [A] + real :: expr1, expr2 ! Temporary expressions [A2] n = this%n - ! First populate the PLM reconstructions - slp(1) = 0. - do k = 2, n-1 - h0 = max( this%h_neglect, h(k-1) ) - h1 = max( this%h_neglect, h(k) ) - h2 = max( this%h_neglect, h(k+1) ) - dul = u(k) - u(k-1) - dur = u(k+1) - u(k) - h112 = ( 2.0 * h0 + h1 ) - h122 = ( h1 + 2.0 * h2 ) - I_h01 = 1. / ( h0 + h1 ) - I_h12 = 1. / ( h1 + h2 ) - h01_h112 = ( 2.0 * h0 + h1 ) / ( h0 + h1 ) ! When uniform -> 3/2 - h23_h122 = ( 2.0 * h2 + h1 ) / ( h2 + h1 ) ! When uniform -> 3/2 - if ( dul * dur > 0.) then - du = ( h1 / ( h1 + ( h0 + h2 ) ) ) * ( h112 * dur * I_h12 + h122 * dul * I_h01 ) - slp(k) = sign( min( abs(2.0 * dul), abs(du), abs(2.0 * dur) ), du) - else - slp(k) = 0. - endif - enddo - slp(n) = 0. - - this%ul(1) = u(1) ! PCM - this%ur(1) = u(1) ! PCM - this%ul(2) = u(1) ! PCM - do K = 3, n-1 ! K=3 is interface between cells 2 and 3 - h0 = max( this%h_neglect, h(k-2) ) - h1 = max( this%h_neglect, h(k-1) ) - h2 = max( this%h_neglect, h(k) ) - h3 = max( this%h_neglect, h(k+1) ) - h01_h112 = ( h0 + h1 ) / ( 2. * h1 + h2 ) ! When uniform -> 2/3 - h23_h122 = ( h2 + h3 ) / ( h1 + 2. * h2 ) ! When uniform -> 2/3 - ddh = h01_h112 - h23_h122 ! When uniform -> 0 - I_h12 = 1.0 / ( h1 + h2 ) ! When uniform -> 1/(2h) - I_h0123 = 1.0 / ( ( h0 + h1 ) + ( h2 + h3 ) ) ! When uniform -> 1/(4h) - dul = slp(k-1) - dur = slp(k) - u1 = u(k-1) - u2 = u(k) - edge = I_h12 * ( h2 * u1 + h1 * u2 ) & ! 1/2 u1 + 1/2 u2 - + I_h0123 * ( 2.0 * h1 * h2 * I_h12 * ( u2 - u1 ) * ddh & ! 0 - + ( h2 * dul * h23_h122 - h1 * dur * h01_h112 ) ) ! 1/6 dul - 1/6 dur - this%ur(k-1) = edge - this%ul(k) = edge - enddo - this%ur(n-1) = u(n) ! PCM - this%ur(n) = u(n) ! PCM - this%ul(n) = u(n) ! PCM - - do K = 2, n ! K=2 is interface between cells 1 and 2 - u0 = u(k-1) - u1 = u(k) - u2 = u(k+1) - a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) ) - a6 = 6.0 * u1 - 3.0 * ( this%ul(k) + this%ur(k) ) - du = this%ur(k) - this%ul(k) - if ( ( u2 - u1 ) * ( u1 - u0 ) <- 0.0 ) then ! Large scale extrema - this%ul(k) = u1 - this%ur(k) = u1 - elseif ( du * a6 > du * du ) then ! Extrema on right - edge = 3.0 * u1 - 2.0 * this%ur(k) ! Subject to round off - ! u_min = min( u0, u1 ) - ! u_max = max( u0, u1 ) - ! edge = max( min( edge, u_max), u_min ) - this%ul(k) = edge - elseif ( du * a6 < - du * du ) then ! Extrema on left - edge = 3.0 * u1 - 2.0 * this%ul(k) ! Subject to round off - ! u_min = min( u1, u2 ) - ! u_max = max( u1, u2 ) - ! edge = max( min( edge, u_max), u_min ) - this%ur(k) = edge - endif - enddo - - ! ### Note that the PPM_HYBGEM option calculated the CW PPM coefficients and then - ! invoked the OM4-era limiters afterwards, effectively doing the limiters twice. - ! This second pass does change answers! + ! First pass: compute initial edge estimates using the hybgen algorithm with CW monotonicity + call hybgen_ppm_coefs(u, h, ppoly_e, n, this%h_neglect) - ! Loop on cells to bound edge value - do k = 1, n + ! Second pass: apply OM4-era PPM limiters (post-2018 answers via answer_date=99991231) + call bound_edge_values(n, h, u, ppoly_e, this%h_neglect, answer_date=99991231) + call check_discontinuous_edge_values(n, u, ppoly_e) - ! For the sake of bounding boundary edge values, the left neighbor of the left boundary cell - ! is assumed to be the same as the left boundary cell and the right neighbor of the right - ! boundary cell is assumed to be the same as the right boundary cell. This effectively makes - ! boundary cells look like extrema. - km1 = max(1,k-1) ; kp1 = min(k+1,N) - - slope_x_h = 0.0 - sigma_l = ( u(k) - u(km1) ) - if ( (h(km1) + h(kp1)) + 2.0*h(k) > 0. ) then - sigma_c = ( u(kp1) - u(km1) ) * ( h(k) / ((h(km1) + h(kp1)) + 2.0*h(k)) ) - else - sigma_c = 0. - endif - sigma_r = ( u(kp1) - u(k) ) - - ! The limiter is used in the local coordinate system to each cell, so for convenience store - ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) - if ( (sigma_l * sigma_r) > 0.0 ) & - slope_x_h = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) - - ! Limit the edge values - if ( (u(km1)-this%ul(k)) * (this%ul(k)-u(k)) < 0.0 ) then - this%ul(k) = u(k) - sign( min( abs(slope_x_h), abs(this%ul(k)-u(k)) ), slope_x_h ) - endif - - if ( (u(kp1)-this%ur(k)) * (this%ur(k)-u(k)) < 0.0 ) then - this%ur(k) = u(k) + sign( min( abs(slope_x_h), abs(this%ur(k)-u(k)) ), slope_x_h ) - endif - - ! Finally bound by neighboring cell means in case of roundoff - this%ul(k) = max( min( this%ul(k), max(u(km1), u(k)) ), min(u(km1), u(k)) ) - this%ur(k) = max( min( this%ur(k), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) - - enddo ! loop on interior edges - - do k = 1, n-1 - if ( (this%ul(k+1) - this%ur(k)) * (u(k+1) - u(k)) < 0.0 ) then - u0_avg = 0.5 * ( this%ur(k) + this%ul(k+1) ) - u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) - this%ur(k) = u0_avg - this%ul(k+1) = u0_avg - endif - enddo ! end loop on interior edges - - ! Loop on interior cells to apply the standard - ! PPM limiter (Colella & Woodward, JCP 84) + ! Apply the standard CW PPM limiter (Colella & Woodward, JCP 84) on interior cells do k = 2, n-1 - - ! Get cell averages - u0 = u(k-1) - u1 = u(k) - u2 = u(k+1) - - edge_l = this%ul(k) - edge_r = this%ur(k) - - if ( (u2 - u1)*(u1 - u0) <= 0.0) then - ! Flatten extremum - edge_l = u1 - edge_r = u1 + u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) + edge_l = ppoly_e(k,1) ; edge_r = ppoly_e(k,2) + if ( (u_r - u_c)*(u_c - u_l) <= 0.0 ) then + edge_l = u_c ; edge_r = u_c else - expr1 = 3.0 * (edge_r - edge_l) * ( (u1 - edge_l) + (u1 - edge_r)) + expr1 = 3.0 * (edge_r - edge_l) * ( (u_c - edge_l) + (u_c - edge_r) ) expr2 = (edge_r - edge_l) * (edge_r - edge_l) if ( expr1 > expr2 ) then - ! Place extremum at right edge of cell by adjusting left edge value - edge_l = u1 + 2.0 * ( u1 - edge_r ) - edge_l = max( min( edge_l, max(u0, u1) ), min(u0, u1) ) ! In case of round off + edge_l = u_c + 2.0 * ( u_c - edge_r ) + edge_l = max( min( edge_l, max(u_l, u_c) ), min(u_l, u_c) ) elseif ( expr1 < -expr2 ) then - ! Place extremum at left edge of cell by adjusting right edge value - edge_r = u1 + 2.0 * ( u1 - edge_l ) - edge_r = max( min( edge_r, max(u2, u1) ), min(u2, u1) ) ! In case of round off + edge_r = u_c + 2.0 * ( u_c - edge_l ) + edge_r = max( min( edge_r, max(u_r, u_c) ), min(u_r, u_c) ) endif endif - ! This checks that the difference in edge values is representable - ! and avoids overshoot problems due to round off. - !### The 1.e-60 needs to have units of [A], so this dimensionally inconsistent. - if ( abs( edge_r - edge_l ) Average between xa and xb for cell k of a PPM_hybgen reconstruction [A] +!! +!! Calls the parent PPM_CW average and then clamps the result to [min(ul,ur), max(ul,ur)]. +!! This replicates the force_bounds_in_subcell behavior of the equivalent old-style PPM_HYBGEN +!! scheme. +real function average(this, k, xa, xb) + class(PPM_hybgen), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: u_lo, u_hi ! Bounds on the sub-cell average given by the edge values [A] + + average = this%PPM_CW%average(k, xa, xb) + u_lo = min(this%ul(k), this%ur(k)) + u_hi = max(this%ul(k), this%ur(k)) + average = max(u_lo, min(u_hi, average)) + +end function average + !> Checks the PPM_hybgen reconstruction for consistency logical function check_reconstruction(this, h, u) class(PPM_hybgen), intent(in) :: this !< This reconstruction @@ -402,4 +277,177 @@ end function unit_tests !> \namespace recon1d_ppm_hybgen !! +! ============================================================================ +! Private subroutines copied from phased-out modules to avoid dependencies. +! These reproduce bit-for-bit the results of the original functions they replace. +! ============================================================================ + +!> Set up edge values for PPM reconstruction using the hybgen (HYCOM) algorithm. +!! +!! Copied from MOM_hybgen_remap.hybgen_ppm_coefs(). +!! Original code by Tim Campbell (MSU, 2002) and Alan Wallcraft (NRL, 2007). +subroutine hybgen_ppm_coefs(s, h_src, edges, nk, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + real, intent(in) :: s(nk) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2) !< The PPM interpolation edge values [A] + real, intent(in) :: thin !< A negligible layer thickness [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping + + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping + real :: da ! Difference between the unlimited scalar edge value estimates [A] + real :: a6 ! Scalar field differences that are proportional to the curvature [A] + real :: slk, srk ! Differences between adjacent cell averages of scalars [A] + real :: sck ! Scalar differences across a cell [A] + real :: as(nk) ! Scalar field difference across each cell [A] + real :: al(nk), ar(nk) ! Scalar field at the left and right edges of a cell [A] + real :: h112(nk+1), h122(nk+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(nk+1) ! Inverses of combinations of thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(nk) ! A ratio of a layer thickness to the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(nk) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(nk+1) ! A ratio of sums of adjacent thicknesses [nondim] + real :: h23_h122(nk+1) ! A ratio of sums of adjacent thicknesses [nondim] + integer :: k + + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + do k=2,nk + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo + do k=2,nk-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,nk-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + as(1) = 0. + do k=2,nk-1 + if (PCM_layer(k)) then + as(k) = 0.0 + else + slk = s(k)-s(k-1) + srk = s(k+1)-s(k) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + as(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + as(k) = 0. + endif + endif + enddo + as(nk) = 0. + al(1) = s(1) + ar(1) = s(1) + al(2) = s(1) + do K=3,nk-1 + al(k) = (dp(k)*s(k-1) + dp(k-1)*s(k)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(s(k)-s(k-1)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*as(k-1)*h23_h122(K) - dp(k-1)*as(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo + ar(nk-1) = s(nk) + al(nk) = s(nk) + ar(nk) = s(nk) + do k=2,nk-1 + if ((PCM_layer(k)) .or. ((s(k+1)-s(k))*(s(k)-s(k-1)) <= 0.)) then + al(k) = s(k) + ar(k) = s(k) + else + da = ar(k)-al(k) + a6 = 6.0*s(k) - 3.0*(al(k)+ar(k)) + if (da*a6 > da*da) then + al(k) = 3.0*s(k) - 2.0*ar(k) + elseif (da*a6 < -da*da) then + ar(k) = 3.0*s(k) - 2.0*al(k) + endif + endif + enddo + do k=1,nk + edges(k,1) = al(k) + edges(k,2) = ar(k) + enddo + +end subroutine hybgen_ppm_coefs + +!> Bound edge values by the averages of the neighboring cells. +!! +!! Copied from regrid_edge_values.bound_edge_values(). +subroutine bound_edge_values(N, h, u, edge_val, h_neglect, answer_date) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< Cell widths [H] + real, dimension(N), intent(in) :: u !< Cell averages [A] + real, dimension(N,2), intent(inout) :: edge_val !< Edge values [A] + real, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + real :: sigma_l, sigma_c, sigma_r + real :: slope_x_h + logical :: use_2018_answers + integer :: k, km1, kp1 + + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) + + do k = 1,N + km1 = max(1,k-1) ; kp1 = min(k+1,N) + slope_x_h = 0.0 + if (use_2018_answers) then + sigma_l = 2.0 * ( u(k) - u(km1) ) / ( h(k) + h_neglect ) + sigma_c = 2.0 * ( u(kp1) - u(km1) ) / ( h(km1) + 2.0*h(k) + h(kp1) + h_neglect ) + sigma_r = 2.0 * ( u(kp1) - u(k) ) / ( h(k) + h_neglect ) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = 0.5 * h(k) * sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + elseif ( ((h(km1) + h(kp1)) + 2.0*h(k)) > 0.0 ) then + sigma_l = ( u(k) - u(km1) ) + sigma_c = ( u(kp1) - u(km1) ) * ( h(k) / ((h(km1) + h(kp1)) + 2.0*h(k)) ) + sigma_r = ( u(kp1) - u(k) ) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + endif + if ( (u(km1)-edge_val(k,1)) * (edge_val(k,1)-u(k)) < 0.0 ) then + edge_val(k,1) = u(k) - sign( min( abs(slope_x_h), abs(edge_val(k,1)-u(k)) ), slope_x_h ) + endif + if ( (u(kp1)-edge_val(k,2)) * (edge_val(k,2)-u(k)) < 0.0 ) then + edge_val(k,2) = u(k) + sign( min( abs(slope_x_h), abs(edge_val(k,2)-u(k)) ), slope_x_h ) + endif + edge_val(k,1) = max( min( edge_val(k,1), max(u(km1), u(k)) ), min(u(km1), u(k)) ) + edge_val(k,2) = max( min( edge_val(k,2), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) + enddo + +end subroutine bound_edge_values + +!> Replace discontinuous edge values with their average when not monotonic. +!! +!! Copied from regrid_edge_values.check_discontinuous_edge_values(). +subroutine check_discontinuous_edge_values(N, u, edge_val) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: u !< Cell averages [A] + real, dimension(N,2), intent(inout) :: edge_val !< Edge values [A] + + integer :: k + real :: u0_avg + + do k = 1,N-1 + if ( (edge_val(k+1,1) - edge_val(k,2)) * (u(k+1) - u(k)) < 0.0 ) then + u0_avg = 0.5 * ( edge_val(k,2) + edge_val(k+1,1) ) + u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg + endif + enddo + +end subroutine check_discontinuous_edge_values + end module Recon1d_PPM_hybgen diff --git a/src/ALE/Recon1d_type.F90 b/src/ALE/Recon1d_type.F90 index a98eb80434..505adc6c2e 100644 --- a/src/ALE/Recon1d_type.F90 +++ b/src/ALE/Recon1d_type.F90 @@ -17,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) @@ -52,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 @@ -82,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 @@ -99,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 @@ -109,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 @@ -117,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 @@ -124,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 @@ -147,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 @@ -166,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_hycom.F90 b/src/ALE/coord_hycom.F90 index 2036e61c1e..d383351517 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -98,7 +98,7 @@ subroutine init_3d_coord_hycom(CS, G, nk, coordinateResolution, target_density, 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 + 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) @@ -106,7 +106,7 @@ subroutine init_3d_coord_hycom(CS, G, nk, coordinateResolution, target_density, enddo CS%target_density_3d(nk+1,i,j) = target_density(i,j,nk+1) endif !mask2dT - enddo; enddo + enddo ; enddo if (is_root_pe()) call MOM_error(NOTE, "init_3d_coord_hycom: use_3d = .true.") diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index f9a0bacd25..15dc4a2005 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -1005,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 84b94684ea..e2b756c334 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -337,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 2ac2230ec4..328a06204a 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -166,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 ca0dfe0145..6f00babf63 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -16,7 +16,7 @@ module MOM use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_mediator_init, enable_averaging, enable_averages -use MOM_diag_mediator, only : diag_mediator_infrastructure_init +use MOM_diag_mediator, only : diag_mediator_infrastructure_init, diag_mediator_set_OBC_info use MOM_diag_mediator, only : diag_set_state_ptrs, diag_update_remap_grids use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : register_diag_field, register_cell_measure @@ -47,7 +47,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 @@ -117,13 +117,18 @@ module MOM use MOM_obsolete_diagnostics, only : register_obsolete_diagnostics 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_dynamics_data, read_OBC_tracer_data +use MOM_open_boundary, only : initialize_OBC_segment_reservoirs use MOM_open_boundary, only : setup_OBC_tracer_reservoirs use MOM_open_boundary, only : setup_OBC_thickness_reservoirs use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields use MOM_open_boundary, only : open_boundary_setup_vert, initialize_segment_data -use MOM_open_boundary, only : update_OBC_segment_data, rotate_OBC_config +use MOM_open_boundary, only : update_OBC_dynamics_data, update_OBC_tracer_data +use MOM_open_boundary, only : 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_open_boundary, only : copy_OBC_radiation_coefs +use MOM_open_boundary, only : copy_OBC_tracer_reservoirs, copy_OBC_thickness_reservoirs 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 @@ -334,7 +339,7 @@ module MOM real :: dt_obc_seg_period !< The time interval between OBC segment updates for OBGC !! tracers [T ~> s], or a negative value if the segment !! data are time-invarant, or zero to update the OBGC - !! segment data with every call to update_OBC_segment_data. + !! segment data with every call to update_OBC_tracer_data. type(time_type) :: dt_obc_seg_interval !< A time_time representation of dt_obc_seg_period. type(time_type) :: dt_obc_seg_time !< The next time OBC segment update is applied to OBGC tracers. @@ -392,6 +397,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. @@ -499,6 +505,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 @@ -517,6 +524,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 @@ -620,6 +628,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 @@ -804,7 +814,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo if (CS%VarMix%use_variable_mixing) then - call enable_averages(cycle_time, Time_start + real_to_time(US%T_to_s*cycle_time), CS%diag) + 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) @@ -832,7 +843,8 @@ 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) + 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) @@ -862,9 +874,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS do n=1,n_max 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)) + 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) @@ -895,10 +907,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS 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. - CS%Time = CS%Time + real_to_time(0.5*US%T_to_s*(dtdia-dt)) + 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. - 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. @@ -914,7 +926,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + 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 @@ -1012,7 +1024,7 @@ 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. if (dtdia > dt) & - CS%Time = CS%Time - real_to_time(0.5*US%T_to_s*(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, & @@ -1031,7 +1043,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Reset CS%Time to its previous value. if (dtdia > dt) & - CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt, unscale=US%T_to_s) endif if (do_dyn) then @@ -1151,7 +1163,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (MOM_state_is_synchronized(CS)) & call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, & G, GV, US, CS%sum_output_CSp, CS%tracer_flow_CSp, & - dt_forcing=real_to_time(US%T_to_s*time_interval) ) + dt_forcing=real_to_time(time_interval, unscale=US%T_to_s) ) call cpu_clock_end(id_clock_other) @@ -1204,6 +1216,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 @@ -1233,14 +1246,15 @@ 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 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) + CS%stoch_CS, u, v) call cpu_clock_end(id_clock_thick_diff) call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) if (showCallTree) call callTree_waypoint("finished thickness_diffuse_first (step_MOM)") @@ -1274,8 +1288,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & ! 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) @@ -1373,10 +1387,10 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & if (Waves%Stokes_DDT .and. (.not.Waves%Passive_Stokes_DDT)) then do J=jsq,jeq ; do i=is,ie v(i,J,:) = v(i,J,:) + Waves%ddt_us_y(i,J,:)*dt - enddo; enddo + 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 + enddo ; enddo call pass_vector(u, v, G%Domain) endif ! Added an additional output to track Stokes drift time tendency. @@ -1385,12 +1399,12 @@ 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 @@ -1404,8 +1418,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & 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) - + CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, & + CS%stoch_CS, u, v) call cpu_clock_end(id_clock_thick_diff) call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, unscale=GV%H_to_MKS) @@ -1471,10 +1485,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & ! 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 + ! 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 @@ -1548,6 +1563,26 @@ 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 + + ! Tracer-step OBC path: active when DT_OBC_SEG_UPDATE_OBGC is ignored (i.e. DT_OBC_SEG_UPDATE_OBGC = DT_TRACER) + ! or when the bug fix is enabled (OBC_TRACER_DZ_BUG=F). OBC_TRACER_DZ_BUG controls whether dz is recomputed + ! from the current layer thicknesses before reading. + if (associated(CS%OBC)) then + if (CS%OBC%ignore_dt_obc_bgc .or. (.not. CS%OBC%tracer_dz_bug)) then + if (CS%OBC%tracer_dz_bug) then + call read_OBC_tracer_data(G, GV, US, CS%OBC, Time_local) + else + call read_OBC_tracer_data(G, GV, US, CS%OBC, Time_local, h=h, tv=CS%tv) + endif + call update_OBC_tracer_data(CS%OBC) + endif + 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 @@ -1672,13 +1707,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) @@ -1839,9 +1872,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 @@ -1921,12 +1952,14 @@ subroutine ALE_regridding_and_remapping(CS, G, GV, US, u, v, h, tv, dtdia, Time_ call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h_old_u, h_old_v, h_new_u, h_new_v, CS%ALE_CSp) endif - if (associated(CS%OBC)) then + if (associated(CS%OBC) .or. associated(CS%visc%Kv_shear_Bu)) then call pass_var(h, G%Domain, complete=.false.) call pass_var(h_new, G%Domain, complete=.true.) - call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) endif + if (associated(CS%OBC)) & + call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) + call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) if (associated(CS%visc%Kv_shear)) & call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, clock=id_clock_pass, halo=1) @@ -2004,12 +2037,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) @@ -2103,12 +2134,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 @@ -2394,6 +2425,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical :: use_KPP ! If true, diabatic is using KPP vertical mixing logical :: MLE_use_PBL_MLD ! If true, use stored boundary layer depths for submesoscale restratification. logical :: OBC_reservoir_init_bug + logical :: OBC_bgc_time_ref_bug ! If true, use the start of the current run (not the overall + ! start time) as the reference for OBC BGC tracer update schedule. integer :: nkml, nkbl, verbosity, write_geom, number_of_OBC_segments integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. @@ -2413,8 +2446,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 @@ -2423,7 +2457,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_MOM_input(param_file, dirs, default_input_filename=input_restart_file, ensemble_num=ensemble_num) verbosity = 2 ; call read_param(param_file, "VERBOSITY", verbosity) - call MOM_set_verbosity(verbosity) + call MOM_set_verbosity(verbosity, .true.) call callTree_enter("initialize_MOM(), MOM.F90") call find_obsolete_params(param_file) @@ -2438,6 +2472,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & "Integer controlling level of messaging\n" // & "\t0 = Only FATAL messages\n" // & "\t2 = Only FATAL, WARNING, NOTE [default]\n" // & + "\t6 = Above plus call tree messages\n" //& "\t9 = All)", default=2, debuggingParam=.true.) call get_param(param_file, "MOM", "DO_UNIT_TESTS", do_unit_tests, & "If True, exercises unit tests at model start up.", & @@ -2537,7 +2572,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 @@ -2591,7 +2626,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & "If true, the defaults for certain recently added bug-fix flags are set to "//& "recreate the bugs so that the code can be moved forward without changing "//& "answers for existing configurations. The defaults for groups of bug-fix "//& - "flags are periodcially changed to correct the bugs, at which point this "//& + "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.", & @@ -2684,20 +2719,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & default_val = US%T_to_s*CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 CS%dtbt_reset_period = -1.0 call get_param(param_file, "MOM", "DTBT_RESET_PERIOD", CS%dtbt_reset_period, & - "The period between recalculations of DTBT (if DTBT <= 0). "//& - "If DTBT_RESET_PERIOD is negative, DTBT is set based "//& - "only on information available at initialization. If 0, "//& - "DTBT will be set every dynamics time step. The default "//& - "is set by DT_THERM. This is only used if SPLIT is true.", & - units="s", default=default_val, scale=US%s_to_T, do_not_read=(dtbt > 0.0)) + "The period between recalculations of DTBT (if DTBT <= 0). If "//& + "DTBT_RESET_PERIOD is negative, DTBT is set based only on information "//& + "available at initialization. If 0, DTBT will be set every dynamics time "//& + "step. Values between 0 and DT are treated as 0. The default is set by "//& + "DT_THERM. This is only used if SPLIT is true.", & + units="s", default=default_val, scale=US%s_to_T, do_not_read=(dtbt > 0.0)) endif - call get_param(param_file, "MOM", "DT_OBC_SEG_UPDATE_OBGC", CS%dt_obc_seg_period, & - "The time between OBC segment data updates for OBGC tracers. "//& - "This must be an integer multiple of DT and DT_THERM. "//& - "The default is set to DT.", & - units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(OBC_in)) - ! This is here in case these values are used inappropriately. use_frazil = .false. ; bound_salinity = .false. ; use_p_surf_in_EOS = .false. CS%tv%P_Ref = 2.0e7*US%Pa_to_RL2_T2 @@ -2846,7 +2875,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. "//& @@ -2940,6 +2974,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Allocate initialize time-invariant MOM variables. call MOM_initialize_fixed(dG_in, US, OBC_in, param_file) + call get_param(param_file, "MOM", "DT_OBC_SEG_UPDATE_OBGC", CS%dt_obc_seg_period, & + "The time between OBC segment data updates for OBGC tracers. This must be an "//& + "integer multiple of DT and DT_THERM. The default is set to DT.", units="s", & + default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(OBC_in)) + call get_param(param_file, "MOM", "OBC_BGC_TIME_REF_BUG", OBC_bgc_time_ref_bug, & + "If true, recover a bug that the BGC OBC segment update schedule is "//& + "referenced to the start of the current run rather than the overall start "//& + "time, which can lead to restart reproducibility failures.", & + default=enable_bugs, do_not_log=.not.associated(OBC_in)) + ! Copy the grid metrics and bathymetry to the ocean_grid_type call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) @@ -3180,7 +3224,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! 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) + 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 @@ -3244,7 +3288,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 @@ -3379,7 +3423,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call calc_derived_thermo(CS%tv, CS%h, G, GV, US) ! Call this during initialization to fill boundary arrays from fixed values - call update_OBC_segment_data(G, GV, US, CS%OBC, CS%tv, CS%h, Time) + call read_OBC_dynamics_data(G, GV, US, CS%OBC, CS%tv, CS%h, Time) + call update_OBC_dynamics_data(G, GV, US, CS%OBC, CS%h, Time) + ! BGC data is not read/updated at initialization since OBC%update_OBC_seg_data is false. + call read_OBC_tracer_data(G, GV, US, CS%OBC, Time, include_bgc=.false.) + call update_OBC_tracer_data(CS%OBC, include_bgc=.false.) + call initialize_OBC_segment_reservoirs(GV, CS%OBC) endif if (use_ice_shelf .and. CS%debug) then @@ -3519,6 +3568,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & diag => CS%diag ! Initialize the diag mediator. call diag_mediator_init(G, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + if (associated(CS%OBC)) then + call diag_mediator_set_OBC_info(G, CS%OBC%segnum_u, CS%OBC%segnum_v, diag) + endif if (present(diag_ptr)) diag_ptr => CS%diag ! Initialize the diagnostics masks for native arrays. @@ -3602,16 +3654,22 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, & cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) endif + ! A reset period no longer than dt is equivalent to recalculating every step. + if (CS%dtbt_reset_period > 0.0 .and. CS%dtbt_reset_period <= CS%dt) & + CS%dtbt_reset_period = 0.0 if (CS%dtbt_reset_period > 0.0) then - CS%dtbt_reset_interval = real_to_time(US%T_to_s*CS%dtbt_reset_period) - ! 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) - if ((CS%dtbt_reset_time > Time) .and. calc_dtbt) then - ! Back up dtbt_reset_time one interval to force dtbt to be calculated, - ! because the restart was not aligned with the interval to recalculate - ! dtbt, and dtbt was not read from a restart file. - CS%dtbt_reset_time = CS%dtbt_reset_time - CS%dtbt_reset_interval + CS%dtbt_reset_interval = real_to_time(CS%dtbt_reset_period, unscale=US%T_to_s) + if (calc_dtbt) then + ! No restart DTBT (not found or new run) or DTBT_RESTART_BUG=True: set to the most recent + ! multiple of the interval before or equal to current time, so the set_dtbt is called on + ! the first step. + CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & + ((Time - Time_init) / CS%dtbt_reset_interval) + else + ! Restart DTBT available: defer to the next multiple after current time so the first step + ! uses the restart value unless a reset is naturally due. + CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & + ((Time - Time_init) / CS%dtbt_reset_interval + 1) endif endif elseif (CS%use_RK2) then @@ -3629,10 +3687,36 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & 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_time = Time + CS%dt_obc_seg_interval + ! When IGNORE_DT_OBC_SEG_UPDATE_OBGC is true, BGC OBC updates happen every tracer advection step. + if (associated(CS%OBC)) then + if (CS%OBC%ignore_dt_obc_bgc) CS%dt_obc_seg_period = 0.0 + endif + + ! Set the next time to update OBC segment BGC tracer data + if (associated(CS%OBC) .and. (CS%dt_obc_seg_period > 0.0)) then + if (CS%dt_obc_seg_period > CS%dt_tr_adv) then + if (new_sim) then + call MOM_error(WARNING, "DT_OBC_SEG_UPDATE_OBGC > DT_TRACER_ADVECT: this run will "//& + "proceed normally, but any restart from it will fail with a FATAL error because "//& + "BGC OBC external data is not saved in restart files. "//& + "Set DT_OBC_SEG_UPDATE_OBGC = DT_TRACER_ADVECT or 0 until this is fixed.") + else + call MOM_error(FATAL, "DT_OBC_SEG_UPDATE_OBGC > DT_TRACER_ADVECT is not supported "//& + "for restart runs: BGC OBC external data is not saved in restart files, so the "//& + "first tracer advection step after restart may use incorrect boundary data. "//& + "Set DT_OBC_SEG_UPDATE_OBGC = DT_TRACER_ADVECT or 0 until this is fixed.") + endif + endif + CS%dt_obc_seg_interval = real_to_time(CS%dt_obc_seg_period, unscale=US%T_to_s) + if (OBC_bgc_time_ref_bug) then + CS%dt_obc_seg_time = Time + CS%dt_obc_seg_interval + else + ! Set to the next update point after current time, so that %t read from initialization is + ! not overwritten. Note that even though this line by itself is correct, there are still + ! issue with restart runs, as external data %t is not saved in restart files. + CS%dt_obc_seg_time = Time_init + CS%dt_obc_seg_interval * & + ((Time - Time_init) / CS%dt_obc_seg_interval + 1) + endif endif call callTree_waypoint("dynamics initialized (initialize_MOM)") @@ -3684,13 +3768,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) @@ -3743,6 +3823,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 @@ -3764,6 +3847,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & 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) + call copy_OBC_radiation_coefs(CS%OBC) + if (.not. (CS%OBC%reservoir_init_bug .and. new_sim .and. CS%diabatic_first)) & + ! The if-guard is needed to preserve old answers with OBC_RESERVOIR_INIT_BUG=True, in which case + ! segment T/S reservoir %tres and global restart arrays OBC%tres_x/y have diverged at this point. + call copy_OBC_tracer_reservoirs(CS%OBC) + call copy_OBC_thickness_reservoirs(CS%OBC, G, GV) endif call register_obsolete_diagnostics(param_file, CS%diag) @@ -3811,7 +3900,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call stochastics_init(CS%dt_therm, CS%G, CS%GV, US, 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 @@ -3893,11 +3982,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) @@ -3925,6 +4014,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 @@ -4083,8 +4174,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) @@ -4220,7 +4311,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 @@ -4387,8 +4478,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. & @@ -4552,6 +4643,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, & @@ -4559,6 +4651,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 @@ -4566,6 +4659,8 @@ 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) @@ -4653,6 +4748,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 af85ae3889..5004108a83 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -16,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 @@ -248,9 +250,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav 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] - real :: h_v, h_u ! h_v is the thickness at v point, h_u is the thickness at u point [H ~> m or kg m-2] - integer :: seventh_order, fifth_order, third_order, second_order ! Order of accuracy for the WENO calculations - real :: psi ! Ratio of PV gradient for the Koren limiter [nondim] + 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] @@ -336,7 +336,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav (-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 ; enddo endif if (.not. Waves%Passive_Stokes_VF) then do J=Js_q,Je_q ; do I=Is_q,Ie_q @@ -344,18 +344,18 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav ((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 ; enddo else do J=Js_q,Je_q ; do I=Is_q,Ie_q dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J)) dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j)) - enddo; enddo + enddo ; enddo endif else do J=Js_q,Je_q ; do I=Is_q,Ie_q dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J)) dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j)) - enddo; enddo + enddo ; enddo endif do J=Js_q,Je_q ; do i=Is_q,Ie_q+1 hArea_v(i,J) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i,j+1) * h(i,j+1,k))) @@ -379,26 +379,32 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav 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 - if (OBC%zero_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - dvdx(I,J) = 0. ; dudy(I,J) = 0. - enddo ; endif - if (OBC%freeslip_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - dudy(I,J) = 0. - enddo ; endif - if (OBC%computed_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - dudy(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%dxCu(I,j) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - dudy(I,J) = 2.0*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dxCu(I,j+1) - endif - enddo ; endif - if (OBC%specified_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j)*G%dyBu(I,J) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j+1)*G%dyBu(I,J) - endif - enddo ; endif + 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) @@ -419,26 +425,32 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav enddo endif elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) 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 + 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) @@ -500,23 +512,23 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav if (CS%no_slip) then do J=Js_q,Je_q ; do I=Is_q,Ie_q rel_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) - enddo; enddo + enddo ; enddo if (Stokes_VF) then if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 stk_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvSdx(I,J) - duSdy(I,J)) * G%IareaBu(I,J) - enddo; enddo + enddo ; enddo endif endif else do J=Js_q,Je_q ; do I=Is_q,Ie_q rel_vort(I,J) = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) - enddo; enddo + enddo ; enddo if (Stokes_VF) then if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 stk_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvSdx(I,J) - duSdy(I,J)) * G%IareaBu(I,J) - enddo; enddo + enddo ; enddo endif endif endif @@ -530,13 +542,13 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav Ih_q(I,J) = Area_q(I,J) / (hArea_q + vol_neglect) h_q(I,J) = hArea_q / max(Area_q(I,J), area_neglect) q(I,J) = abs_vort(I,J) * Ih_q(I,J) - enddo; enddo + enddo ; enddo if (Stokes_VF) then if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then do J=js-1,Jeq ; do I=is-1,Ieq qS(I,J) = stk_vort(I,J) * Ih_q(I,J) - enddo; enddo + enddo ; enddo endif endif @@ -678,7 +690,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav endif ! Calculate KE and the gradient of KE - call gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) + call gradKE(u(:,:,k), v(:,:,k), h(:,:,k), KE, KEx, KEy, G, GV, US, CS) ! Calculate the tendencies of zonal velocity due to the Coriolis ! force and momentum advection. On a Cartesian grid, this is @@ -1119,7 +1131,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav CAvS(i,J,k) = 0.25 * & ((qS(I,J) * (uh(I,j+1,k) + uh(I,j,k))) + & (qS(I-1,J) * (uh(I-1,j,k) + uh(I-1,j+1,k)))) * G%IdyCv(i,J) - enddo; enddo + enddo ; enddo endif endif @@ -1233,22 +1245,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav 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]. @@ -1267,29 +1277,29 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) ! identified in Arakawa & Lamb 1982 as important for KE conservation. It ! also includes the possibility of partially-blocked tracer cell faces. do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - KE(i,j) = ( ( (G%areaCu( I ,j)*(u( I ,j,k)*u( I ,j,k))) + & - (G%areaCu(I-1,j)*(u(I-1,j,k)*u(I-1,j,k))) ) + & - ( (G%areaCv(i, J )*(v(i, J ,k)*v(i, J ,k))) + & - (G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k))) ) )*0.25*G%IareaT(i,j) + KE(i,j) = ( ( (G%areaCu( I ,j)*(u( I ,j)*u( I ,j))) + & + (G%areaCu(I-1,j)*(u(I-1,j)*u(I-1,j))) ) + & + ( (G%areaCv(i, J )*(v(i, J )*v(i, J ))) + & + (G%areaCv(i,J-1)*(v(i,J-1)*v(i,J-1))) ) )*0.25*G%IareaT(i,j) enddo ; enddo elseif (CS%KE_Scheme == KE_SIMPLE_GUDONOV) then ! The following discretization of KE is based on the one-dimensional Gudonov ! scheme which does not take into account any geometric factors do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - up = 0.5*( u(I-1,j,k) + ABS( u(I-1,j,k) ) ) ; up2 = up*up - um = 0.5*( u( I ,j,k) - ABS( u( I ,j,k) ) ) ; um2 = um*um - vp = 0.5*( v(i,J-1,k) + ABS( v(i,J-1,k) ) ) ; vp2 = vp*vp - vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2 = vm*vm + up = 0.5*( u(I-1,j) + ABS( u(I-1,j) ) ) ; up2 = up*up + um = 0.5*( u( I ,j) - ABS( u( I ,j) ) ) ; um2 = um*um + vp = 0.5*( v(i,J-1) + ABS( v(i,J-1) ) ) ; vp2 = vp*vp + vm = 0.5*( v(i, J ) - ABS( v(i, J ) ) ) ; vm2 = vm*vm KE(i,j) = ( max(up2,um2) + max(vp2,vm2) ) *0.5 enddo ; enddo elseif (CS%KE_Scheme == KE_GUDONOV) then ! The following discretization of KE is based on the one-dimensional Gudonov ! scheme but has been adapted to take horizontal grid factors into account do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - up = 0.5*( u(I-1,j,k) + ABS( u(I-1,j,k) ) ) ; up2a = up*up*G%areaCu(I-1,j) - um = 0.5*( u( I ,j,k) - ABS( u( I ,j,k) ) ) ; um2a = um*um*G%areaCu( I ,j) - vp = 0.5*( v(i,J-1,k) + ABS( v(i,J-1,k) ) ) ; vp2a = vp*vp*G%areaCv(i,J-1) - vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2a = vm*vm*G%areaCv(i, J ) + up = 0.5*( u(I-1,j) + ABS( u(I-1,j) ) ) ; up2a = up*up*G%areaCu(I-1,j) + um = 0.5*( u( I ,j) - ABS( u( I ,j) ) ) ; um2a = um*um*G%areaCu( I ,j) + vp = 0.5*( v(i,J-1) + ABS( v(i,J-1) ) ) ; vp2a = vp*vp*G%areaCv(i,J-1) + vm = 0.5*( v(i, J ) - ABS( v(i, J ) ) ) ; vm2a = vm*vm*G%areaCv(i, J ) KE(i,j) = ( max(um2a,up2a) + max(vm2a,vp2a) )*0.5*G%IareaT(i,j) enddo ; enddo elseif (CS%KE_Scheme == KE_UP3) then @@ -1302,14 +1312,14 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) G%mask2dCu(I,j) * G%mask2dCu(I+1,j)) if (third_order_u == 1) then - up = (7.0 * (u(I-1,j,k) + u(I,j,k)) - (u(I-2,j,k) + u(I+1,j,k))) * C1_12 - call UP3_Koren_limiter_reconstruction(u(I-2:I+1,j,k), up, um) + 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,k) + u(I,j,k))*0.5 + up = (u(I-1,j) + u(I,j))*0.5 if (up>0.) then - um = u(I-1,j,k) + um = u(I-1,j) elseif (up<0.) then - um = u(I,j,k) + um = u(I,j) else um = up endif @@ -1318,14 +1328,14 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) 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,k) + v(i,J,k)) - (v(i,J-2,k) + v(i,J+1,k))) * C1_12 - call UP3_Koren_limiter_reconstruction(v(i,J-2:J+1,k), vp, vm) + 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,k) + v(i,J,k))*0.5 + vp = (v(i,J-1) + v(i,J))*0.5 if (vp>0.) then - vm = v(i,J-1,k) + vm = v(i,J-1) elseif (vp<0.) then - vm = v(i,J,k) + vm = v(i,J) else vm = vp endif @@ -1340,14 +1350,14 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) G%mask2dCu(I,j) * G%mask2dCu(I+1,j)) if (third_order_u == 1) then - up = (7.0 * (u(I-1,j,k) + u(I,j,k)) - (u(I-2,j,k) + u(I+1,j,k))) * C1_12 - call UP3_reconstruction(u(I-2:I+1,j,k), up, um) + 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,k) + u(I,j,k))*0.5 + up = (u(I-1,j) + u(I,j))*0.5 if (up>0.) then - um = u(I-1,j,k) + um = u(I-1,j) elseif (up<0.) then - um = u(I,j,k) + um = u(I,j) else um = up endif @@ -1356,14 +1366,14 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) 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,k) + v(i,J,k)) - (v(i,J-2,k) + v(i,J+1,k))) * C1_12 - call UP3_reconstruction(v(i,J-2:J+1,k), vp, vm) + 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,k) + v(i,J,k))*0.5 + vp = (v(i,J-1) + v(i,J))*0.5 if (vp>0.) then - vm = v(i,J-1,k) + vm = v(i,J-1) elseif (vp<0.) then - vm = v(i,J,k) + vm = v(i,J) else vm = vp endif @@ -1376,28 +1386,14 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) ! Term - d(KE)/dx. do j=js,je ; do I=Isq,Ieq - KEx(I,j) = (KE(i+1,j) - KE(i,j)) * G%IdxCu(I,j) + KEx(I,j) = (KE(i+1,j) - KE(i,j)) * G%IdxCu_OBCmask(I,j) enddo ; enddo ! Term - d(KE)/dy. do J=Jsq,Jeq ; do i=is,ie - KEy(i,J) = (KE(i,j+1) - KE(i,j)) * G%IdyCv(i,J) + KEy(i,J) = (KE(i,j+1) - KE(i,j)) * G%IdyCv_OBCmask(i,J) enddo ; enddo - if (associated(OBC)) then - do n=1,OBC%number_of_segments - if (OBC%segment(n)%is_N_or_S) then - do i=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied - KEy(i,OBC%segment(n)%HI%JsdB) = 0. - enddo - elseif (OBC%segment(n)%is_E_or_W) then - do j=OBC%segment(n)%HI%jsd,OBC%segment(n)%HI%jed - KEx(OBC%segment(n)%HI%IsdB,j) = 0. - enddo - endif - enddo - endif - end subroutine gradKE !> Reconstruct the scalar (e.g., pv, vorticity) onto point i-1/2 using a third-order upwind scheme @@ -1455,7 +1451,7 @@ function fac_fn(tau, b) result(fac) 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 + fac = 1.0e40 ; if (abs(b) > 1.0e-20*tau) fac = (1 + tau / b)**2 end function fac_fn diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index b0e1934229..fdfddbe2b0 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -24,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 @@ -186,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)) :: & @@ -199,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]. @@ -210,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]. @@ -282,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) @@ -355,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) @@ -367,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), & @@ -438,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 @@ -655,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 @@ -1015,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]. @@ -1026,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]. @@ -1107,7 +1101,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp, integer, dimension(2) :: EOSdom_u ! The i-computational domain for the equation of state at u-velocity points integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: i, j, k, 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 @@ -1163,7 +1157,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp, !$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 @@ -1242,6 +1236,8 @@ 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) @@ -1273,7 +1269,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp, enddo ; enddo else do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - Z_0p(i,j) = G%Z_ref + Z_0p(i,j) = G%meanSL(i,j) enddo ; enddo endif @@ -1287,7 +1283,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp, ! is used, whereby densities within each layer are constant no matter ! where the layers are located. if ( use_ALE .and. CS%Recon_Scheme > 0 ) then - if ( CS%Recon_Scheme == 1 ) then + 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), & @@ -1357,7 +1353,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 @@ -2038,7 +2036,6 @@ 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". @@ -2079,16 +2076,16 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL "If true, apply tidal momentum forcing.", default=.false.) if (CS%tides) then call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & - "This sets the default value for the various _ANSWER_DATE parameters.", & - default=99991231) + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tides_answer_date, "The vintage of "//& - "self-attraction and loading (SAL) and tidal forcing calculations. Setting "//& - "dates before 20230701 recovers old answers (Boussinesq and non-Boussinesq "//& - "modes) when SAL is part of the tidal forcing calculation. The answer "//& - "difference is only at bit level and due to a reordered summation. Setting "//& - "dates before 20250201 recovers answers (Boussinesq mode) that interface "//& - "heights are modified before pressure force integrals are calculated.", & - default=default_answer_date, do_not_log=(.not.CS%tides)) + "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) @@ -2184,7 +2181,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 "//& diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 19aa7b2aaa..e79f540546 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -199,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) @@ -478,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 @@ -709,7 +709,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) 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) + press(i) = -Rho0xG*(e(i,j,1) - G%meanSL(i,j)) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & tv%eqn_of_state, EOSdom) @@ -718,7 +718,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) enddo do k=2,nz do i=Isq,Ieq+1 - press(i) = -Rho0xG*(e(i,j,K) - G%Z_ref) + press(i) = -Rho0xG*(e(i,j,K) - G%meanSL(i,j)) T_int(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo @@ -892,7 +892,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 3cc0dd560b..760ac99988 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -30,7 +30,7 @@ module MOM_barotropic use MOM_self_attr_load, only : scalar_SAL_sensitivity use MOM_self_attr_load, only : SAL_CS use MOM_streaming_filter, only : Filt_register, Filt_init, Filt_accum, Filter_CS -use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) +use MOM_time_manager, only : time_type, real_to_time, get_date, operator(+), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type use MOM_verticalGrid, only : verticalGrid_type @@ -602,13 +602,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]. @@ -629,13 +624,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]. @@ -664,9 +654,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]. @@ -696,7 +685,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 @@ -757,13 +745,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.") @@ -1330,8 +1316,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, uhbt(:,:) = 0.0 ; vhbt(:,:) = 0.0 u_accel_bt(:,:) = 0.0 ; v_accel_bt(:,:) = 0.0 - if (apply_OBCs) then - ubt_first(:,:) = ubt(:,:) ; vbt_first(:,:) = vbt(:,:) + if (apply_OBCs .or. (CS%id_ubtdt > 0)) then + do j=js,je ; do I=is-1,ie ; ubt_st(I,j) = ubt(I,j) ; enddo ; enddo + endif + if (apply_OBCs .or. (CS%id_vbtdt > 0)) then + do J=js-1,je ; do i=is,ie ; vbt_st(i,J) = vbt(i,J) ; enddo ; enddo endif ! Here the vertical average accelerations due to the Coriolis, advective, @@ -1802,17 +1791,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif 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 - endif - if (query_averaging_enabled(CS%diag)) then if (CS%id_eta_st > 0) call post_data(CS%id_eta_st, eta(isd:ied,jsd:jed), CS%diag) if (CS%id_ubt_st > 0) call post_data(CS%id_ubt_st, ubt(IsdB:IedB,jsd:jed), CS%diag) @@ -2028,13 +2006,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 @@ -2472,9 +2450,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] @@ -2482,14 +2460,14 @@ 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] - cfl_ltd_vol !< The volume available after removing sinks used to limit uhbt_int and vhbt_int [H L2 ~> m3] + 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] @@ -2508,6 +2486,7 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL ! 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 @@ -2567,7 +2546,7 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL (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 @@ -2884,7 +2863,21 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL do j=jsv,jev ; do i=isv,iev eta(i,j) = (eta_IC(i,j) + eta_cor_multiplier*eta_src(i,j)) + CS%IareaT_OBCmask(i,j) * & ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + ! eta_acc contains the magnitude of the largest term in the above expression which + ! will be used to estimate a bound for round off when comparing to the bottom depth + eta_acc = abs( CS%IareaT_OBCmask(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) ) + eta_acc = max( eta_acc, abs( eta_cor_multiplier*eta_src(i,j) ), abs( eta_IC(i,j) ) ) + if ( G%mask2dT(i,j) * ( eta(i,j) + GV%Z_to_H*G%bathyT(i,j) ) > & + -G%mask2dT(i,j) * eta_acc * epsilon(eta_acc) * 2. ) & + eta(i,j) = max( eta(i,j), -GV%Z_to_H*G%bathyT(i,j) ) eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then + write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + if (CS%bt_limit_integral_transport) & + call MOM_error(FATAL, "btstep: eta has dropped below bathyT: "//trim(mesg)) + endif enddo ; enddo else !$OMP do @@ -2982,7 +2975,7 @@ 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) @@ -3044,7 +3037,7 @@ 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 @@ -3183,9 +3176,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 @@ -3535,7 +3528,6 @@ 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) @@ -3690,7 +3682,7 @@ end subroutine btstep_layer_accel !> This subroutine automatically determines an optimal value for dtbt based on some state of the ocean. Either pbce or !! gtot_est is required to calculate gravitational acceleration. Column thickness can be estimated using BT_cont, eta, !! and SSH_add (default=0), with priority given in that order. The subroutine sets CS%dtbt_max and CS%dtbt. -subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add) +subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -3707,6 +3699,7 @@ subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add) !! anomaly [H ~> m or kg m-2]. real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to provide a margin of !! error when calculating the external wave speed [Z ~> m]. + type(time_type), optional, intent(in) :: Time !< Model time at the beginning of the baroclinic time step. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -3738,7 +3731,8 @@ subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add) ! barotropic time step [T-2 ~> s-2]. logical :: use_BT_cont type(memory_size_type) :: MS - + character(len=200) :: mesg + integer :: yr, mon, day, hr, minute, sec integer :: i, j, k, is, ie, js, je, nz if (.not.CS%module_is_initialized) call MOM_error(FATAL, & @@ -3809,6 +3803,14 @@ subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add) CS%dtbt = CS%dtbt_fraction * dtbt_max CS%dtbt_max = dtbt_max + if (is_root_PE() .and. present(Time)) then + call get_date(Time, yr, mon, day, hr, minute, sec) + write(mesg, '("DTBT reset by set_dtbt at ",i4.4,"-",i2.2,"-",i2.2," ",i2.2,":",i2.2,":",i2.2, & + & ", dtbt = ",ES12.6," s, dtbt_max = ",ES12.6," s")') & + yr, mon, day, hr, minute, sec, (US%T_to_s*CS%dtbt), (US%T_to_s*dtbt_max) + call MOM_mesg(mesg, 3) + endif + if (CS%debug) then call chksum0(CS%dtbt, "End set_dtbt dtbt", unscale=US%T_to_s) call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", unscale=US%T_to_s) @@ -4592,7 +4594,6 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) 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.") @@ -5360,14 +5361,14 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) Datu(I,j) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) -! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2) + ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2) enddo ; enddo !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) Datv(i,J) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2) -! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2) + ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2) enddo ; enddo else !$OMP do @@ -5390,27 +5391,31 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) !$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) + H1 = max((G%meanSL(i+1,j) + add_max) + G%bathyT(i+1,j), 0.0) + H2 = max((G%meanSL(i,j) + add_max) + G%bathyT(i,j), 0.0) + Datu(I,j) = CS%dy_Cu(I,j) * Z_to_H * max(H1, H2) enddo ; enddo !$OMP do 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) + H1 = max((G%meanSL(i,j+1) + add_max) + G%bathyT(i,j+1), 0.0) + H2 = max((G%meanSL(i,j) + add_max) + G%bathyT(i,j), 0.0) + Datv(i,J) = CS%dx_Cv(i,J) * Z_to_H * max(H1, H2) enddo ; enddo else 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 + 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 + 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) @@ -5533,8 +5538,7 @@ 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 @@ -5558,6 +5562,7 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & 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. + logical :: dtbt_restart_bug ! Stores the value of runtime parameter DTBT_RESTART_BUG. character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -5741,7 +5746,10 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & "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, "DTBT_RESTART_BUG", dtbt_restart_bug, & + "If true, recover a bug where the barotropic timestep DTBT read from a "//& + "restart file is immediately overridden by a recalculation on the "//& + "first dynamics step.", default=enable_bugs) 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 @@ -6023,10 +6031,10 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & ! This sets pressure force diagnostics on land, at coastlines and at OBC points to zero. if (mask_coastal_pressure_force) then do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB - CS%IdxCu(I,j) = G%OBCmaskCu(I,j) * G%IdxCu(I,j) + 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%OBCmaskCv(i,J) * G%IdyCv(i,J) + CS%IdyCv(i,J) = G%IdyCv_OBCmask(i,J) enddo ; enddo endif @@ -6136,25 +6144,26 @@ 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(Mean_SL+G%bathyT(i+1,j),0.0) * Z_to_H + 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(Mean_SL+G%bathyT(i,j),0.0) * Z_to_H + 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(Mean_SL+G%bathyT(i,j+1),0.0) * Z_to_H + 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(Mean_SL+G%bathyT(i,j),0.0) * Z_to_H + 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 @@ -6162,10 +6171,11 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & 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)) * & ((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(Mean_SL+G%bathyT(i,j),0.0)) + & - (CS%q_wt(4,I,J) * max(Mean_SL+G%bathyT(i+1,j+1),0.0))) + & - ((CS%q_wt(2,I,J) * max(Mean_SL+G%bathyT(i+1,j),0.0)) + & - (CS%q_wt(3,I,J) * max(Mean_SL+G%bathyT(i,j+1),0.0)))), h_a_neglect) + 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 @@ -6242,7 +6252,7 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & 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) + call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra, Time=Time) if (dtbt_input > 0.0) then CS%dtbt = US%s_to_T * dtbt_input @@ -6250,7 +6260,11 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & CS%dtbt = dtbt_restart endif - calc_dtbt = .true. ; if ((dtbt_restart > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. + if (dtbt_restart_bug) then + calc_dtbt = .true. ; if ((dtbt_restart > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. + else + calc_dtbt = (dtbt_restart <= 0.0) + endif 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) @@ -6311,7 +6325,7 @@ 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, & @@ -6436,18 +6450,19 @@ 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%OBCmaskCu(I,j) > 0.) then - CS%IDatu(I,j) = G%OBCmaskCu(I,j) * 2.0 / (Z_to_H * ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL)) + 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%OBCmaskCv(i,J) > 0.) then - CS%IDatv(i,J) = G%OBCmaskCv(i,J) * 2.0 / (Z_to_H * ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL)) + 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 diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 9caf549de7..c8798a3bb6 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -11,7 +11,9 @@ module MOM_boundary_update use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data, chksum_OBC_segments +use MOM_open_boundary, only : ocean_obc_type, chksum_OBC_segments +use MOM_open_boundary, only : read_OBC_dynamics_data, read_OBC_tracer_data +use MOM_open_boundary, only : update_OBC_dynamics_data, update_OBC_tracer_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 @@ -43,6 +45,8 @@ module MOM_boundary_update 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 @@ -74,6 +78,8 @@ subroutine call_OBC_register(G, GV, US, param_file, CS, OBC, tr_Reg) ! Local variables logical :: debug + 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=200) :: config character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. ! This include declares and sets the variable "version". @@ -86,6 +92,11 @@ 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, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + 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=enable_bugs) call get_param(param_file, mdl, "USE_FILE_OBC", CS%use_files, & "If true, use external files for the open boundary.", & default=.false.) @@ -168,8 +179,23 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) 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, h, Time) - if (OBC%any_needs_IO_for_data .or. OBC%add_tide_constituents) & - call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + + if (.not. OBC%user_BCs_set_globally) then + ! Update dynamics + if (OBC%any_needs_IO_for_data) & + call read_OBC_dynamics_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_dynamics_data(G, GV, US, OBC, h, Time) + ! Update tracers: this is the old incorrect path. See step_MOM_tracer_dyn for the locked path. + ! If DT_OBC_SEG_UPDATE_OBGC is used (not recommended), BGC has its own update schedule, which + ! may happen in between tracer steps. + if ((.not. OBC%ignore_dt_obc_bgc) .and. OBC%any_needs_IO_for_data .and. OBC%tracer_dz_bug) then + call read_OBC_tracer_data(G, GV, US, OBC, Time, include_bgc=OBC%update_OBC_seg_data) + call update_OBC_tracer_data(OBC, include_bgc=OBC%update_OBC_seg_data) + endif + 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 d04a6b3934..b52b577293 100644 --- a/src/core/MOM_check_scaling.F90 +++ b/src/core/MOM_check_scaling.F90 @@ -128,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 ecb8f7edb3..bfe1366bf6 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -237,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 diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index bbfe1cc75d..992f9b0ad0 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -51,6 +51,9 @@ module MOM_continuity_PPM !! discrepancies between the barotropic solution and !! the sum of the layer thicknesses [L T-1 ~> m s-1]. real :: CFL_limit_adjust !< The maximum CFL of the adjusted velocities [nondim] + real :: h_marg_min !< Negligible floor on h_marg, the marginal thickness + !! used to calculate the partial derivative of transports + !! with velocities [H ~> m or kg m-2] logical :: aggress_adjust !< If true, allow the adjusted velocities to have a !! relative CFL change up to 0.5. False by default. logical :: vol_CFL !< If true, use the ratio of the open face lengths @@ -159,8 +162,8 @@ 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.") if (x_first) then ! First advect zonally, with loop bounds that accomodate the subsequent meridional advection. @@ -627,7 +630,8 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa 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) + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), & + CS%h_marg_min, OBC) if (local_specified_BC) then do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= 0) then l_seg = abs(OBC%segnum_u(I,j)) @@ -877,7 +881,8 @@ subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, p 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) + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), & + CS%h_marg_min, OBC) if (OBC_in_row) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= 0) then l_seg = abs(OBC%segnum_u(I,j)) if (OBC%segment(l_seg)%specified) uh(I) = OBC%segment(l_seg)%normal_trans(I,j,k) @@ -896,7 +901,7 @@ 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) + ish, ieh, do_I, vol_CFL, por_face_areaU, h_marg_min, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZIB_(G)), intent(in) :: visc_rem !< Both the fraction of the @@ -920,13 +925,13 @@ subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & logical, intent(in) :: vol_CFL !< If true, rescale the real, dimension(SZIB_(G)), intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] !! ratio of face areas to the cell areas when estimating the CFL number. + real, intent(in) :: h_marg_min !< Negligible floor on h_marg [H ~> m or kg m-2] type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] real :: curv_3 ! A measure of the thickness curvature over a grid length [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. @@ -954,6 +959,7 @@ subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & uh(I) = 0.0 h_marg = 0.5 * (h_W(i+1) + h_E(i)) endif + h_marg = max(h_marg, h_marg_min) duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h_marg * visc_rem(I) endif ; enddo @@ -962,10 +968,10 @@ subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & if (OBC%segment(abs(OBC%segnum_u(I,j)))%open) then if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i) - duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h(i) * visc_rem(I) + duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * max(h(i), h_marg_min) * visc_rem(I) else ! OBC_DIRECTION_W uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i+1) - duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * h(i+1) * visc_rem(I) + duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * max(h(i+1), h_marg_min) * visc_rem(I) endif endif endif ; endif ; enddo @@ -1217,7 +1223,8 @@ subroutine zonal_flux_adjust(u, h_in, h_W, h_E, uhbt, uh_tot_0, duhdu_tot_0, & 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) + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), & + CS%h_marg_min, OBC) enddo ; endif if (itt < max_itts) then @@ -1365,11 +1372,14 @@ subroutine set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0, 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)) + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaU(:,j,k), CS%h_marg_min) call zonal_flux_layer(u_L, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_L, duhdu_L, & - visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaU(:,j,k), CS%h_marg_min) call zonal_flux_layer(u_R, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_R, duhdu_R, & - visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaU(:,j,k), CS%h_marg_min) do I=ish-1,ieh ; if (do_I(I)) then FAmt_0(I) = FAmt_0(I) + duhdu_0(I) FAmt_L(I) = FAmt_L(I) + duhdu_L(I) @@ -1520,7 +1530,8 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p 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) + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), & + CS%h_marg_min, OBC) if (local_specified_BC) then do i=ish,ieh ; if (OBC%segnum_v(i,J) /= 0) then l_seg = abs(OBC%segnum_v(i,J)) @@ -1767,7 +1778,8 @@ subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, O 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) + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), & + CS%h_marg_min, OBC) if (OBC_in_row) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= 0) then l_seg = abs(OBC%segnum_v(i,J)) if (OBC%segment(l_seg)%specified) vh(i) = OBC%segment(l_seg)%normal_trans(i,J,k) @@ -1787,7 +1799,7 @@ end subroutine meridional_BT_mass_flux !> 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) + ish, ieh, do_I, vol_CFL, por_face_areaV, h_marg_min, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: visc_rem !< Both the fraction of the @@ -1815,6 +1827,7 @@ subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & !! 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] + real, intent(in) :: h_marg_min !< Negligible floor on h_marg [H ~> m or kg m-2] type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] @@ -1850,6 +1863,7 @@ subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & vh(i) = 0.0 h_marg = 0.5 * (h_S(i,j+1) + h_N(i,j)) endif + h_marg = max(h_marg, h_marg_min) dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h_marg * visc_rem(i) endif ; enddo @@ -1859,10 +1873,10 @@ subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & if (OBC%segment(abs(OBC%segnum_v(i,J)))%open) then if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * h(i,j) - dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h(i,j) * visc_rem(i) + dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * max(h(i,j), h_marg_min) * visc_rem(i) else vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * h(i,j+1) - dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h(i,j+1) * visc_rem(i) + dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * max(h(i,j+1), h_marg_min) * visc_rem(i) endif endif endif @@ -2114,7 +2128,8 @@ subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vhbt, vh_tot_0, dvhdv_tot_0 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) + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), & + CS%h_marg_min, OBC) enddo ; endif if (itt < max_itts) then @@ -2262,11 +2277,14 @@ subroutine set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0, 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)) + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaV(:,:,k), CS%h_marg_min) call merid_flux_layer(v_L, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_L, dvhdv_L, & - visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaV(:,:,k), CS%h_marg_min) call merid_flux_layer(v_R, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_R, dvhdv_R, & - visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaV(:,:,k), CS%h_marg_min) do i=ish,ieh ; if (do_I(i)) then FAmt_0(i) = FAmt_0(i) + dvhdv_0(i) FAmt_L(i) = FAmt_L(i) + dvhdv_L(i) @@ -2722,7 +2740,7 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS, OBC) !! 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 + logical :: local_open_BC, use_h_marg_min type(OBC_segment_type), pointer :: segment => NULL() integer :: n @@ -2795,12 +2813,23 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS, OBC) "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 a large negative value to recreate previous answers.", default=.false.) CS%diag => diag id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) id_clock_update = cpu_clock_id('(Ocean continuity update)', grain=CLOCK_ROUTINE) id_clock_correct = cpu_clock_id('(Ocean continuity correction)', grain=CLOCK_ROUTINE) + if (use_h_marg_min) then + CS%h_marg_min = GV%H_subroundoff + else + ! The light-year here means there is effectively no floor on negative marginal thicknesses. + CS%h_marg_min = -1.0e16*GV%m_to_H ! Negative 1.057 light years + endif + if (local_open_BC) then do n=1, OBC%number_of_segments segment => OBC%segment(n) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 19cad281e8..bb398d9f00 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -680,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 @@ -792,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 @@ -1124,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 @@ -1236,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 @@ -1476,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 8588a0c41e..d566e19d05 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -36,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, real_to_time, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS, ALE_remap_velocities @@ -62,7 +62,6 @@ 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 @@ -651,9 +650,6 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (G%nonblocking_updates) & call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) - if (associated(CS%OBC)) & - call copy_thickness_reservoirs(CS%OBC, G, GV) - ! u_accel_bt = layer accelerations due to barotropic solver if (associated(CS%BT_cont) .or. CS%BT_use_layer_fluxes) then call cpu_clock_begin(id_clock_continuity) @@ -668,17 +664,19 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f 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) if (calc_dtbt) then if (CS%dtbt_use_bt_cont .and. associated(CS%BT_cont)) then - call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, BT_cont=CS%BT_cont) + call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, BT_cont=CS%BT_cont, & + Time=Time_local - real_to_time(dt, unscale=US%T_to_s)) else ! In the following call, eta is only used when NONLINEAR_BT_CONTINUITY is True. Otherwise, dtbt is effectively ! calculated with eta=0. Note that NONLINEAR_BT_CONTINUITY is False if BT_CONT is used, which is the default. - call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, eta=eta) + call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, eta=eta, & + Time=Time_local - real_to_time(dt, unscale=US%T_to_s)) endif endif if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") @@ -1265,6 +1263,9 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_C 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 + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source = 0.0) + allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source = 0.0) + thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) @@ -1310,6 +1311,18 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_C call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) + 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.,& + do_not_log=.true.) + + if (CS%split_bottom_stress) then + vd(1) = var_desc("taux_bot", "kg m-1 s-2", "Zonal bottom stress", 'u', '1') + vd(2) = var_desc("tauy_bot", "kg m-1 s-2", "Meridional bottom stress", 'v', '1') + call register_restart_pair(CS%taux_bot, CS%tauy_bot, vd(1), vd(2), .false., restart_CS, & + conversion=US%RLZ_T2_to_Pa) + endif + end subroutine register_restarts_dyn_split_RK2 !> This subroutine does remapping for the auxiliary restart variables that are used @@ -1338,10 +1351,11 @@ subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_ call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u_av, CS%v_av) call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%CAu_pred, CS%CAv_pred) - call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) + call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.false.) endif call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%diffu, CS%diffv) + call pass_vector(CS%diffu, CS%diffv, G%Domain, complete=.true.) end subroutine remap_dyn_split_RK2_aux_vars @@ -1457,7 +1471,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p 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. "//& @@ -1526,9 +1540,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p "continuity() and btstep() calls in the corrector step. Default of this flag "//& "is set by VISC_REM_BUG", default=visc_rem_bug) - allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) - allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) - ALLOC_(CS%uhbt(IsdB:IedB,jsd:jed)) ; CS%uhbt(:,:) = 0.0 ALLOC_(CS%vhbt(isd:ied,JsdB:JedB)) ; CS%vhbt(:,:) = 0.0 ALLOC_(CS%visc_rem_u(IsdB:IedB,jsd:jed,nz)) ; CS%visc_rem_u(:,:,:) = 0.0 @@ -1936,6 +1947,7 @@ subroutine end_dyn_split_RK2(CS) if (associated(CS%taux_bot)) deallocate(CS%taux_bot) if (associated(CS%tauy_bot)) deallocate(CS%tauy_bot) + DEALLOC_(CS%uhbt) ; DEALLOC_(CS%vhbt) DEALLOC_(CS%u_accel_bt) ; DEALLOC_(CS%v_accel_bt) DEALLOC_(CS%visc_rem_u) ; DEALLOC_(CS%visc_rem_v) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index dcdfd9b834..4c03afd263 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -37,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, real_to_time, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS, ALE_remap_velocities @@ -61,7 +61,6 @@ 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 @@ -371,10 +370,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(:,:) :: & @@ -394,7 +393,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 @@ -671,9 +670,6 @@ 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, & @@ -690,11 +686,13 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_begin(id_clock_btstep) if (calc_dtbt) then if (CS%dtbt_use_bt_cont .and. associated(CS%BT_cont)) then - call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, BT_cont=CS%BT_cont) + call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, BT_cont=CS%BT_cont, & + Time=Time_local - real_to_time(dt, unscale=US%T_to_s)) else ! In the following call, eta is only used when NONLINEAR_BT_CONTINUITY is True. Otherwise, dtbt is effectively ! calculated with eta=0. Note that NONLINEAR_BT_CONTINUITY is False if BT_CONT is used, which is the default. - call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, eta=eta) + call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, eta=eta, & + Time=Time_local - real_to_time(dt, unscale=US%T_to_s)) endif endif if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") @@ -1188,11 +1186,11 @@ 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 integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + character(len=40) :: mdl = "MOM_dynamics_split_RK2b" ! This module's name. 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 @@ -1216,6 +1214,9 @@ subroutine register_restarts_dyn_split_RK2b(HI, GV, US, param_file, CS, restart_ ALLOC_(CS%du_av_inst(IsdB:IedB,jsd:jed)) ; CS%du_av_inst(:,:) = 0.0 ALLOC_(CS%dv_av_inst(isd:ied,JsdB:JedB)) ; CS%dv_av_inst(:,:) = 0.0 + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source = 0.0) + allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source = 0.0) + ALLOC_(CS%eta(isd:ied,jsd:jed)) ; CS%eta(:,:) = 0.0 thickness_units = get_thickness_units(GV) @@ -1239,6 +1240,18 @@ subroutine register_restarts_dyn_split_RK2b(HI, GV, US, param_file, CS, restart_ call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) + 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.,& + do_not_log=.true.) + + if (CS%split_bottom_stress) then + vd(1) = var_desc("taux_bot", "kg m-1 s-2", "Zonal bottom stress", 'u', '1') + vd(2) = var_desc("tauy_bot", "kg m-1 s-2", "Meridional bottom stress", 'v', '1') + call register_restart_pair(CS%taux_bot, CS%tauy_bot, vd(1), vd(2), .false., restart_CS, & + conversion=US%RLZ_T2_to_Pa) + endif + end subroutine register_restarts_dyn_split_RK2b !> This subroutine does remapping for the auxiliary restart variables that are used @@ -1322,13 +1335,11 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, !! 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. @@ -1364,7 +1375,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, 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. "//& @@ -1420,9 +1431,6 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, "is set by VISC_REM_BUG", default=visc_rem_bug) - allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) - allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) - ALLOC_(CS%uhbt(IsdB:IedB,jsd:jed)) ; CS%uhbt(:,:) = 0.0 ALLOC_(CS%vhbt(isd:ied,JsdB:JedB)) ; CS%vhbt(:,:) = 0.0 ALLOC_(CS%visc_rem_u(IsdB:IedB,jsd:jed,nz)) ; CS%visc_rem_u(:,:,:) = 0.0 diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index c560ba07a8..34897d0894 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -248,9 +248,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & 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 @@ -282,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) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 0f2274c445..005a2a77e1 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -68,7 +68,7 @@ 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 @@ -260,7 +260,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, 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 @@ -609,7 +609,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, tv, Time, G, GV, US, param_file, 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. "//& diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 34ac8be444..4e50a6892d 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -135,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 @@ -375,6 +379,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 @@ -545,14 +550,10 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! Initializes/sets logicals if 'rates' are requested ! These factors are required for legacy reasons ! and therefore computed only when optional outputs are requested - do_NHR = .false. - do_NSR = .false. - do_NMIOR = .false. - do_PSWBR = .false. - if (present(net_heat_rate)) do_NHR = .true. - if (present(net_salt_rate)) do_NSR = .true. - if (present(netmassinout_rate)) do_NMIOR = .true. - if (present(pen_sw_bnd_rate)) do_PSWBR = .true. + do_NHR = present(net_heat_rate) + do_NSR = present(net_salt_rate) + do_NMIOR = present(netmassinout_rate) + do_PSWBR = present(pen_sw_bnd_rate) !}BGR ! GMM: by default heat content from mass entering and leaving the ocean (enthalpy) @@ -1203,7 +1204,7 @@ subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_units) ! 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 @@ -1268,7 +1269,7 @@ subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_unit ! 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 @@ -1409,7 +1410,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, & @@ -1556,8 +1557,9 @@ 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_MARBL_tracers, use_glc_runoff) +subroutine register_forcing_type_diags(Time, diag, US, use_temperature, & + handles, use_berg_fluxes, use_waves, use_cfcs, use_MARBL_tracers, & + 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 @@ -1568,6 +1570,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, logical, optional, intent(in) :: use_cfcs !< If true, allow cfc related diagnostics logical, optional, intent(in) :: use_MARBL_tracers !< If true, allow MARBL 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 logical :: use_cfcs_or_MARBL_tracers @@ -1652,8 +1655,8 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_seaice_bc_flux = register_diag_field('ocean_model', 'SEAICE_BLACK_CARBON_FLUX_CPL', & diag%axesT1, Time, 'SEAICE_BLACK_CARBON_FLUX from cpl', 'kg m-2 s', & conversion=US%RZ_T_to_kg_m2s) - end if - end if + endif + endif handles%id_psurf = register_diag_field('ocean_model', 'p_surf', diag%axesT1, Time, & 'Pressure at ice-ocean or atmosphere-ocean interface', & 'Pa', conversion=US%RL2_T2_to_Pa, cmor_field_name='pso', & @@ -1730,7 +1733,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='water_flux_into_sea_water_from_rivers', & cmor_long_name='Water Flux into Sea Water From Rivers') - if (present(use_glc_runoff)) then + if (present(use_glc_runoff)) then ; if (use_glc_runoff) then handles%id_frunoff_glc = register_diag_field('ocean_model', 'frunoff_glc', diag%axesT1, Time, & 'Frozen glacier runoff (calving) and iceberg melt into ocean', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & @@ -1740,7 +1743,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Liquid runoff (glaciers) into ocean', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_flux_into_sea_water_from_glaciers') ! todo: update cmor names - endif + endif ; endif handles%id_net_massout = register_diag_field('ocean_model', 'net_massout', diag%axesT1, Time, & 'Net mass leaving the ocean due to evaporation, seaice formation', & @@ -1824,7 +1827,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='water_flux_into_sea_water_from_rivers_area_integrated', & cmor_long_name='Water Flux into Sea Water From Rivers Area Integrated') - if (present(use_glc_runoff)) then + if (present(use_glc_runoff)) then ; if (use_glc_runoff) then handles%id_total_frunoff_glc = register_scalar_field('ocean_model', 'total_frunoff_glc', Time, diag, & long_name='Area integrated frozen glacier runoff (calving) & iceberg melt into ocean', & units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) @@ -1832,7 +1835,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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 + endif ; endif handles%id_total_net_massout = register_scalar_field('ocean_model', 'total_net_massout', Time, diag, & long_name='Area integrated mass leaving ocean due to evap and seaice form', & @@ -1894,7 +1897,15 @@ 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_glc_runoff)) then + 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 ; if (use_glc_runoff) then handles%id_heat_content_frunoff_glc = register_diag_field('ocean_model', 'heat_content_frunoff_glc', & diag%axesT1, Time, 'Heat content (relative to 0C) of solid glacier runoff into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) @@ -1902,7 +1913,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_heat_content_lrunoff_glc = register_diag_field('ocean_model', 'heat_content_lrunoff_glc', & diag%axesT1, Time, 'Heat content (relative to 0C) of liquid glacier runoff into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) - endif + endif ; endif handles%id_hfrunoffds = register_diag_field('ocean_model', 'hfrunoffds', & diag%axesT1, Time, 'Heat content (relative to 0C) of liquid+solid runoff into ocean', & @@ -2008,10 +2019,10 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='heat_flux_into_sea_water_due_to_iceberg_thermodynamics', & cmor_long_name='Latent Heat to Melt Frozen Runoff/Iceberg') - if (present(use_glc_runoff)) then + if (present(use_glc_runoff)) then ; if (use_glc_runoff) then handles%id_lat_frunoff_glc = register_diag_field('ocean_model', 'latent_frunoff_glc', diag%axesT1, Time, & 'Latent heat flux into ocean due to melting of frozen glacier runoff', 'W m-2', conversion=US%QRZ_T_to_W_m2) - endif + endif ; endif handles%id_sens = register_diag_field('ocean_model', 'sensible', diag%axesT1, Time, & 'Sensible heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & @@ -2052,7 +2063,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name= & 'Temperature Flux due to Runoff Expressed as Heat Flux into Sea Water Area Integrated') - if (present(use_glc_runoff)) then + if (present(use_glc_runoff)) then ; if (use_glc_runoff) then handles%id_total_heat_content_frunoff_glc = register_scalar_field('ocean_model', & 'total_heat_content_frunoff_glc', Time, diag, & long_name='Area integrated heat content (relative to 0C) of solid glacier runoff', & @@ -2062,7 +2073,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'total_heat_content_lrunoff_glc', Time, diag, & long_name='Area integrated heat content (relative to 0C) of liquid glacier runoff', & units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) ! todo: update cmor names - endif + endif ; endif handles%id_total_heat_content_lprec = register_scalar_field('ocean_model', & 'total_heat_content_lprec', Time, diag, & @@ -2181,12 +2192,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name= & 'Heat Flux into Sea Water due to Iceberg Thermodynamics Area Integrated') - if (present(use_glc_runoff)) then + if (present(use_glc_runoff)) then ; if (use_glc_runoff) then handles%id_total_lat_frunoff_glc = register_scalar_field('ocean_model', & 'total_lat_frunoff_glc', Time, diag, & long_name='Area integrated latent heat flux due to melting frozen glacier runoff', & units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) ! todo: update cmor names - endif + endif ; endif handles%id_total_sens = register_scalar_field('ocean_model', & 'total_sens', Time, diag, & @@ -2337,12 +2348,10 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, !=============================================================== ! wave forcing diagnostics - if (present(use_waves)) then - if (use_waves) then - handles%id_lamult = register_diag_field('ocean_model', 'lamult', & + 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", conversion=1.0) - endif - endif + endif ; endif end subroutine register_forcing_type_diags @@ -2520,6 +2529,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 @@ -2903,8 +2918,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call cpu_clock_begin(handles%id_clock_forcing) - mom_enthalpy = .true. - if (present(enthalpy)) mom_enthalpy = .not. enthalpy + mom_enthalpy = .true. ; if (present(enthalpy)) mom_enthalpy = .not. enthalpy ! NOTE: post_data expects data to be on the rotated index map, so any ! rotations must be applied before saving the output. @@ -3113,6 +3127,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)) & @@ -3552,7 +3569,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 @@ -3578,6 +3595,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 @@ -3590,9 +3608,6 @@ 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 - call myAlloc(fluxes%ustar,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, ustar) @@ -3623,6 +3638,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.) @@ -3641,12 +3657,13 @@ 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) + shelf_sfc_acc = .false. ; if (present(shelf_sfc_accumulation)) shelf_sfc_acc = shelf_sfc_accumulation 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) @@ -3695,14 +3712,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, & @@ -3795,7 +3812,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.") @@ -3832,7 +3849,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 @@ -3844,6 +3861,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, @@ -3860,6 +3878,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 @@ -3940,6 +3959,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) @@ -4101,8 +4121,6 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) if (do_iceberg) then call rotate_array(fluxes_in%ustar_berg, turns, fluxes%ustar_berg) call rotate_array(fluxes_in%area_berg, turns, fluxes%area_berg) - !BGR: pretty sure the following line isn't supposed to be here. - call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) endif if (do_heat_added) then @@ -4239,9 +4257,6 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) Irho0 = 1.0 / Rho0 - tau2ustar = .false. - if (present(UpdateUstar)) tau2ustar = UpdateUstar - call get_mech_forcing_groups(forces, do_stress, do_ustar, do_taumag, do_shelf, & do_press, do_iceberg) @@ -4254,6 +4269,7 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) do j=jsB,jeB ; do i=is,ie if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean enddo ; enddo + tau2ustar = .false. ; if (present(UpdateUstar)) tau2ustar = UpdateUstar if (tau2ustar) then tau_mag = US%L_to_Z*sqrt((tx_mean**2) + (ty_mean**2)) if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index eb6e0eeeee..e82b1ec134 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -29,7 +29,7 @@ module MOM_grid type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain type(MOM_domain_type), pointer :: Domain_aux => NULL() !< A non-symmetric auxiliary domain type. type(hor_index_type) :: HI !< Horizontal index ranges - type(hor_index_type) :: HId2 !< Horizontal index ranges for level-2-downsampling + type(hor_index_type), allocatable :: HId(:) !< Horizontal index ranges for downsampling integer :: isc !< The start i-index of cell centers within the computational domain integer :: iec !< The end i-index of cell centers within the computational domain @@ -97,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]. @@ -112,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]. @@ -160,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 @@ -354,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 @@ -391,23 +402,6 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v if ( G%block(nblocks)%jed+G%block(nblocks)%jdg_offset > G%HI%jed + G%HI%jdg_offset ) & call MOM_error(FATAL, "MOM_grid_init: G%jed_bk > G%jed") - call get_domain_extent(G%Domain, G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, & - G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed, & - G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg, coarsen=2) - - ! Set array sizes for fields that are discretized at tracer cell boundaries. - G%HId2%IscB = G%HId2%isc ; G%HId2%JscB = G%HId2%jsc - G%HId2%IsdB = G%HId2%isd ; G%HId2%JsdB = G%HId2%jsd - G%HId2%IsgB = G%HId2%isg ; G%HId2%JsgB = G%HId2%jsg - if (G%symmetric) then - G%HId2%IscB = G%HId2%isc-1 ; G%HId2%JscB = G%HId2%jsc-1 - G%HId2%IsdB = G%HId2%isd-1 ; G%HId2%JsdB = G%HId2%jsd-1 - G%HId2%IsgB = G%HId2%isg-1 ; G%HId2%JsgB = G%HId2%jsg-1 - endif - G%HId2%IecB = G%HId2%iec ; G%HId2%JecB = G%HId2%jec - G%HId2%IedB = G%HId2%ied ; G%HId2%JedB = G%HId2%jed - G%HId2%IegB = G%HId2%ieg ; G%HId2%JegB = G%HId2%jeg - end subroutine MOM_grid_init !> set_derived_metrics calculates metric terms that are derived from other metrics. @@ -435,6 +429,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 @@ -442,6 +437,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 @@ -537,6 +533,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 @@ -547,6 +544,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 @@ -572,13 +570,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 @@ -586,6 +584,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 @@ -618,6 +617,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) @@ -633,9 +634,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 6da95df2c9..8821c0cb16 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -19,7 +19,7 @@ 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, find_col_mass @@ -43,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 @@ -66,13 +140,9 @@ 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 @@ -85,14 +155,12 @@ 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 parallel default(shared) private(dilate,htot) + !$OMP do + do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo !$OMP do do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*GV%H_to_Z @@ -101,7 +169,8 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) ! Dilate the water column to agree with the free surface height ! that is used for the dynamics. !$OMP do - do j=jsv,jev + do j=jsv,jev !$OMP parallel do default(shared) + do i=isv,iev dilate(i) = (eta_bt(i,j)*GV%H_to_Z + G%bathyT(i,j)) / & (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) @@ -112,36 +181,18 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) enddo ; enddo enddo endif + !$OMP end parallel else - if (associated(tv%eqn_of_state)) then - !$OMP do - do j=jsv,jev - if (associated(tv%p_surf)) then - do i=isv,iev ; p(i,j,1) = tv%p_surf(i,j) ; enddo - else - do i=isv,iev ; p(i,j,1) = 0.0 ; enddo - endif - do k=1,nz ; do i=isv,iev - p(i,j,K+1) = p(i,j,K) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) - enddo ; enddo - enddo - !$OMP do - do k=1,nz - call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & - 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) - enddo - !$OMP do - do j=jsv,jev - do k=nz,1,-1 ; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + I_gEarth * dz_geo(i,j,k) - enddo ; enddo - enddo - else - !$OMP do - do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + GV%H_to_RZ*h(i,j,k) / GV%Rlay(k) - enddo ; enddo ; enddo - endif + call find_dz_for_eta(h, tv, G, GV, US, dz_lay, halo_size) + !$OMP parallel default(shared) private(dilate,htot) + !$OMP do + do j=jsv,jev + do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo + do k=nz,1,-1 ; do i=isv,iev + eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,k) + enddo ; enddo + enddo + if (present(eta_bt)) then ! Dilate the water column to agree with the free surface height ! from the time-averaged barotropic solution. @@ -156,8 +207,8 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) enddo ; enddo enddo endif + !$OMP end parallel endif - !$OMP end parallel end subroutine find_eta_3d @@ -184,13 +235,8 @@ 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 @@ -199,54 +245,33 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) 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 + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie eta(i,j) = GV%H_to_Z*eta_bt(i,j) - dZ_ref enddo ; enddo else - !$OMP do - do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + h(i,j,k)*GV%H_to_Z - enddo ; enddo ; enddo - endif - else - if (associated(tv%eqn_of_state)) then - !$OMP do + !$OMP parallel do default(shared) do j=js,je - if (associated(tv%p_surf)) then - do i=is,ie ; p(i,j,1) = tv%p_surf(i,j) ; enddo - else - do i=is,ie ; p(i,j,1) = 0.0 ; enddo - endif - + do i=is,ie ; eta(i,j) = -(G%bathyT(i,j) + dZ_ref) ; enddo do k=1,nz ; do i=is,ie - p(i,j,k+1) = p(i,j,k) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) + eta(i,j) = eta(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - !$OMP do - do k = 1, nz - call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, & - G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) - enddo - !$OMP do - do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + I_gEarth * dz_geo(i,j,k) - enddo ; enddo ; enddo - else - !$OMP do - do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + GV%H_to_RZ*h(i,j,k) / GV%Rlay(k) - enddo ; enddo ; enddo endif + else + call find_dz_for_eta(h, tv, G, GV, US, dz_lay, halo_size) + !$OMP parallel default(shared) private(htot) + !$OMP do + do j=js,je + do i=is,ie ; eta(i,j) = -(G%bathyT(i,j) + dZ_ref) ; enddo + do k=1,nz ; do i=is,ie + eta(i,j) = eta(i,j) + dz_lay(i,j,k) + enddo ; enddo + enddo if (present(eta_bt)) then ! Dilate the water column to agree with the time-averaged column ! mass from the barotropic solution. @@ -260,8 +285,8 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) enddo enddo endif + !$OMP end parallel endif - !$OMP end parallel end subroutine find_eta_2d @@ -482,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 diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 1dd1d92bf2..1950fb8dd8 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -31,7 +31,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, OBC_N2) + N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC, OBC_N2, & + drdx_u, drdy_v, drdz_u, drdz_v) 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 @@ -66,6 +67,22 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan logical, optional, intent(in) :: OBC_N2 !< If present and true, use interior data !! to calculate stratification at open boundary !! condition faces. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: drdx_u !< Zonal density gradient at u + !! along surfaces of constant z + !! (not along isopycnals or + !! model interfaces) [R L-1 ~> kg m-4] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: drdy_v !< Meridional density gradient at v + !! along surfaces of constant z + !! (not along isopycnals or + !! model interfaces) [R L-1 ~> kg m-4] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: drdz_u !< Vertical density gradient + !! at u [R Z-1 ~> kg m-4] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(inout) :: drdz_v !< Vertical density gradient + !! at v [R Z-1 ~> kg m-4] ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & @@ -131,6 +148,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan real :: G_Rho0 ! The gravitational acceleration divided by density [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] logical :: present_N2_u, present_N2_v + logical :: present_drdx_u, present_drdy_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. @@ -170,6 +188,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan use_EOS = associated(tv%eqn_of_state) + present_drdx_u = PRESENT(drdx_u) + present_drdy_v = PRESENT(drdy_v) present_N2_u = PRESENT(N2_u) present_N2_v = PRESENT(N2_v) G_Rho0 = GV%g_Earth / GV%Rho0 @@ -209,6 +229,24 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan dzSyN(i,J,nz+1) = 0. enddo ; enddo endif + ! Set boundary values to zero, since they will be at places + ! where streamfunction would be zero. + if (present_drdx_u) then + do j=js,je ; do I=is-1,ie + drdx_u(I,j,1) = 0. + drdx_u(I,j,nz+1) = 0. + drdz_u(I,j,1) = 0. + drdz_u(I,j,nz+1) = 0. + enddo ; enddo + endif + if (present_drdy_v) then + do J=js-1,je ; do i=is,ie + drdy_v(i,J,1) = 0. + drdy_v(i,J,nz+1) = 0. + drdz_v(i,J,1) = 0. + drdz_v(i,J,nz+1) = 0. + enddo ; enddo + endif if (use_EOS) then if (present(halo)) then @@ -254,6 +292,7 @@ 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,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 present_drdx_u,drdx_u,drdz_u, & !$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, & @@ -416,6 +455,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif slope_x(I,j,K) = slope + if (present_drdx_u) then + drdx_u(I,j,K) = drdx + drdz_u(I,j,K) = drdz + endif if (present(dzSxN)) & dzSxN(I,j,K) = sqrt( GxSpV_u(I) * max(0., (wtL * ( dzaL * drdkL )) & + (wtR * ( dzaR * drdkR ))) / (wtL + wtR) ) & ! dz * N @@ -431,6 +474,7 @@ 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 present_drdy_v,drdy_v,drdz_v, & !$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, & @@ -599,6 +643,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan slope = slope * max(G%mask2dT(i,j), G%mask2dT(i,j+1)) endif slope_y(i,J,K) = slope + if (present_drdy_v) then + drdy_v(i,J,K) = drdy + drdz_v(i,J,K) = drdz + endif if (present(dzSyN)) & dzSyN(i,J,K) = sqrt( GxSpV_v(i) * max(0., (wtL * ( dzaL * drdkL )) & + (wtR * ( dzaR * drdkR ))) / (wtL + wtR) ) & ! dz * N diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index aa309fd56a..3b91334df2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -6,7 +6,8 @@ module MOM_open_boundary use MOM_array_transform, only : rotate_array, rotate_array_pair -use MOM_coms, only : sum_across_PEs, Set_PElist, Get_PElist, PE_here, num_PEs +use MOM_coms, only : sum_across_PEs, any_across_PEs +use MOM_coms, only : Set_PElist, Get_PElist, PE_here, num_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_debugging, only : hchksum, uvchksum, chksum use MOM_diag_mediator, only : diag_ctrl, time_type @@ -15,14 +16,13 @@ module MOM_open_boundary 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, 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 @@ -30,7 +30,7 @@ module MOM_open_boundary 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 @@ -49,13 +49,15 @@ module MOM_open_boundary public open_boundary_impose_normal_slope public open_boundary_impose_land_mask public radiation_open_bdry_conds -public update_OBC_segment_data +public read_OBC_dynamics_data +public read_OBC_tracer_data +public update_OBC_dynamics_data +public update_OBC_tracer_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 @@ -71,7 +73,9 @@ module MOM_open_boundary public setup_OBC_tracer_reservoirs public setup_OBC_thickness_reservoirs public open_boundary_register_restarts -public copy_thickness_reservoirs +public copy_OBC_radiation_coefs +public copy_OBC_tracer_reservoirs +public copy_OBC_thickness_reservoirs public update_segment_tracer_reservoirs public update_segment_thickness_reservoirs public set_initialized_OBC_tracer_reservoirs @@ -89,16 +93,41 @@ 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. When there is grid !! rotation, this is the name on the rotated internal grid. - character(len=8) :: genre !< an identifier for the segment data + 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 @@ -128,32 +157,54 @@ module MOM_open_boundary !> Tracer on OBC segment data structure, for putting into a segment tracer registry. type, public :: OBC_segment_tracer_type - real, allocatable :: t(:,:,:) !< tracer concentration array in rescaled units, - !! like [S ~> ppt] for salinity. - real :: OBC_inflow_conc = 0.0 !< tracer concentration for generic inflows in rescaled units, - !! like [S ~> ppt] for salinity. - character(len=32) :: name !< tracer name used for error messages - type(tracer_type), pointer :: Tr => NULL() !< metadata describing the tracer - real, allocatable :: tres(:,:,:) !< tracer reservoir array in rescaled units, - !! like [S ~> ppt] for salinity. - real :: scale !< A scaling factor for converting the units of input - !! data, like [S ppt-1 ~> 1] for salinity. - logical :: is_initialized !< reservoir values have been set when True - integer :: ntr_index = -1 !< index of segment tracer in the global tracer registry - integer :: fd_index = -1 !< index of segment tracer in the input fields + logical :: is_initialized !< Reservoir values have been set when True + character(len=32) :: name !< Tracer name used for error messages + integer :: ntr_index = -1 !< Index of segment tracer in the global tracer registry + real, allocatable :: t(:,:,:) !< External tracer concentration array in rescaled + !! units, like [S ~> ppt] for salinity. + real, allocatable :: tres(:,:,:) !< Tracer reservoir array in rescaled units, like + !! [S ~> ppt] for salinity. + real :: scale !< A scaling factor for converting the units of input + !! data, like [S ppt-1 ~> 1] for salinity. + real :: resrv_lfac_in = 1.0 !< The reservoir inverse length scale factor for the + !! inward direction per tracer [nondim]. The general + !! 1/Lscale_in is multiplied by this factor for a + !! specific tracer or thickness. Set to -1 to force + !! a zero effective length scale regardless of + !! Tr_InvLscale_in. + real :: resrv_lfac_out = 1.0 !< The reservoir inverse length scale factor for the + !! outward direction per tracer [nondim]. The general + !! 1/Lscale_out is multiplied by this factor for a + !! specific tracer or thickness. Set to -1 to force + !! a zero effective length scale regardless of + !! Tr_InvLscale_out. + real :: I_Lscale_in = 0.0 !< Per-tracer inverse length scale for flow into the + !! reservoir direction. Three regimes: + !! - Positive: finite length scale; I_Lscale_in = + !! resrv_lfac_in * Tr_InvLscale_in [L-1 ~> m-1]. + !! - Zero: infinite length scale; reservoir is frozen + !! [nondim]. + !! - Negative (-1): instant-update sentinel (zero + !! effective length scale) [nondim]. + real :: I_Lscale_out = 0.0 !< Per-tracer inverse length scale for flow out of the + !! reservoir direction. Three regimes: + !! - Positive: finite length scale; I_Lscale_out = + !! resrv_lfac_out * Tr_InvLscale_out [L-1 ~> m-1]. + !! - Zero: infinite length scale; reservoir is frozen + !! [nondim]. + !! - Negative (-1): instant-update sentinel (zero + !! effective length scale) [nondim]. 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, + logical :: is_initialized !< Reservoir values have been set when True + character(len=32) :: name !< Thickness name used for error messages + real, allocatable :: h(:,:,:) !< Layer thickness array in rescaled units, [Z ~> m]. + 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 @@ -190,19 +241,6 @@ 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. @@ -213,23 +251,12 @@ module MOM_open_boundary integer :: Ie_obc !< Ending local i-index of boundary segment, this may be outside of the local PE. integer :: Js_obc !< Starting local j-index of boundary segment, this may be outside of the local PE. integer :: Je_obc !< Ending local j-index of boundary segment, this may be outside of the local PE. - integer :: uamp_index !< Save where uamp is in segment%field. - integer :: uphase_index !< Save where uphase is in segment%field. - integer :: vamp_index !< Save where vamp is in segment%field. - 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. 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 - logical :: thickness_segment_data_exists !< true if thickness 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 :: dz(:,:,:) !< The layer vertical extent [Z ~> m] at OBC segment faces. real, allocatable :: dZtot(:,:) !< The total column vertical extent [Z ~> m] at OBC segment faces. - real, allocatable :: h(:,:,:) !< The cell thickness [H ~> m or kg m-2] at OBC segment faces real, allocatable :: normal_vel(:,:,:) !< The layer velocity normal to the OB !! segment [L T-1 ~> m s-1]. real, allocatable :: tangential_vel(:,:,:) !< The layer velocity tangential to the OB segment @@ -240,8 +267,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 @@ -325,22 +359,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 :: 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. @@ -459,6 +480,17 @@ module MOM_open_boundary !! 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. + logical :: ignore_dt_obc_bgc !< If true, DT_OBC_SEG_UPDATE_OBGC is ignored and all OBC segment + !! tracer data (T/S and BGC) is updated every tracer advection step. + !! If false, T/S is updated every dynamic step, which is unnecessary, + !! while BGC follows its own update schedule, which may not reproduce + !! across restarts. Once DT_OBC_SEG_UPDATE_OBGC is deprecated, only + !! the "true" path will be needed. + logical :: tracer_dz_bug !< If true, recover a bug that OBC tracer segment data is read + !! without recomputing segment layer thicknesses using the current + !! layer thicknesses and thermodynamic state. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -508,348 +540,440 @@ subroutine open_boundary_config(G, US, param_file, OBC) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables + 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 :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to ! recreate the bugs, or if false bugs are only used if actively selected. logical :: debugging_tests ! If true, do additional calls resetting values to help debug the performance ! of the open boundary condition code. - logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + logical :: obsolete_param_set, param_set + logical :: zero_vorticity, freeslip_vorticity, computed_vorticity, specified_vorticity + logical :: zero_strain, freeslip_strain, computed_strain, specified_strain ! This include declares and sets the variable "version". # include "version_variable.h" - allocate(OBC) + call log_version(param_file, mdl, version, "Controls where open boundaries are located, "//& + "what kind of boundary condition to impose, and what data to apply, if any.", & + all_default=.false.) + ! Parameter OBC_NUMBER_OF_SEGMENTS is always logged. + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", num_of_segs, & + "The number of open boundary segments.", default=0) + if (num_of_segs <= 0) & ! Do nothing if there is no OBC segments + return - call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & - default=0, do_not_log=.true.) - call log_version(param_file, mdl, version, & - "Controls where open boundaries are located, what kind of boundary condition "//& - "to impose, and what data to apply, if any.", & - all_default=(OBC%number_of_segments<=0)) - call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & - "The number of open boundary segments.", & - default=0) - call get_param(param_file, mdl, "OBC_USER_CONFIG", config1, & + allocate(OBC) + OBC%number_of_segments = num_of_segs + call get_param(param_file, mdl, "OBC_USER_CONFIG", config, & "A string that sets how the open boundary conditions are "//& " configured: \n", default="none", do_not_log=.true.) call get_param(param_file, mdl, "NK", OBC%ke, & "The number of model layers", default=0, do_not_log=.true.) - if (config1 /= "none" .and. config1 /= "dyed_obcs") OBC%user_BCs_set_globally = .true. - - if (OBC%number_of_segments > 0) then - call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, & - "If true, sets relative vorticity to zero on open boundaries.", & - default=.false.) - call get_param(param_file, mdl, "OBC_FREESLIP_VORTICITY", OBC%freeslip_vorticity, & - "If true, sets the normal gradient of tangential velocity to "//& - "zero in the relative vorticity on open boundaries. This cannot "//& - "be true if another OBC_XXX_VORTICITY option is True.", default=.true.) - call get_param(param_file, mdl, "OBC_COMPUTED_VORTICITY", OBC%computed_vorticity, & - "If true, uses the external values of tangential velocity "//& - "in the relative vorticity on open boundaries. This cannot "//& - "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) - call get_param(param_file, mdl, "OBC_SPECIFIED_VORTICITY", OBC%specified_vorticity, & - "If true, uses the external values of tangential velocity "//& - "in the relative vorticity on open boundaries. This cannot "//& - "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) - if ((OBC%zero_vorticity .and. OBC%freeslip_vorticity) .or. & - (OBC%zero_vorticity .and. OBC%computed_vorticity) .or. & - (OBC%zero_vorticity .and. OBC%specified_vorticity) .or. & - (OBC%freeslip_vorticity .and. OBC%computed_vorticity) .or. & - (OBC%freeslip_vorticity .and. OBC%specified_vorticity) .or. & - (OBC%computed_vorticity .and. OBC%specified_vorticity)) & - call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& - "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//& - "and OBC_IMPORTED_VORTICITY can be True at once.") - call get_param(param_file, mdl, "OBC_ZERO_STRAIN", OBC%zero_strain, & - "If true, sets the strain used in the stress tensor to zero on open boundaries.", & - default=.false.) - call get_param(param_file, mdl, "OBC_FREESLIP_STRAIN", OBC%freeslip_strain, & - "If true, sets the normal gradient of tangential velocity to "//& - "zero in the strain use in the stress tensor on open boundaries. This cannot "//& - "be true if another OBC_XXX_STRAIN option is True.", default=.true.) - call get_param(param_file, mdl, "OBC_COMPUTED_STRAIN", OBC%computed_strain, & - "If true, sets the normal gradient of tangential velocity to "//& - "zero in the strain use in the stress tensor on open boundaries. This cannot "//& - "be true if another OBC_XXX_STRAIN option is True.", default=.false.) - call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN", OBC%specified_strain, & - "If true, sets the normal gradient of tangential velocity to "//& - "zero in the strain use in the stress tensor on open boundaries. This cannot "//& - "be true if another OBC_XXX_STRAIN option is True.", default=.false.) - if ((OBC%zero_strain .and. OBC%freeslip_strain) .or. & - (OBC%zero_strain .and. OBC%computed_strain) .or. & - (OBC%zero_strain .and. OBC%specified_strain) .or. & - (OBC%freeslip_strain .and. OBC%computed_strain) .or. & - (OBC%freeslip_strain .and. OBC%specified_strain) .or. & - (OBC%computed_strain .and. OBC%specified_strain)) & - call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//& - "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//& - "and OBC_IMPORTED_STRAIN can be True at once.") - call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & - "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//& - "viscosity term.", default=.false.) - call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & - "If true, set the areas outside open boundaries to be land.", & - default=.false.) - call get_param(param_file, mdl, "RAMP_OBCS", OBC%ramp, & - "If true, ramps from zero to the external values over time, with"//& - "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far", & - default=.false.) - call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", OBC%ramp_timescale, & - "If RAMP_OBCS is true, this sets the ramping timescale.", & - units="days", default=1.0, scale=86400.0*US%s_to_T) - call get_param(param_file, mdl, "OBC_TIDE_N_CONSTITUENTS", OBC%n_tide_constituents, & - "Number of tidal constituents being added to the open boundary.", & - default=0) - - if (OBC%n_tide_constituents > 0) then - OBC%add_tide_constituents = .true. + if (config /= "none" .and. config /= "dyed_obcs") OBC%user_BCs_set_globally = .true. + + ! Configuration for OBC relative vorticity. + ! Old setup method + obsolete_param_set = .false. + zero_vorticity = .false. + call read_param(param_file, "OBC_ZERO_VORTICITY", zero_vorticity, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + freeslip_vorticity = .true. + call read_param(param_file, "OBC_FREESLIP_VORTICITY", freeslip_vorticity, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + computed_vorticity = .false. + call read_param(param_file, "OBC_COMPUTED_VORTICITY", computed_vorticity, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + specified_vorticity = .false. + call read_param(param_file, "OBC_SPECIFIED_VORTICITY", specified_vorticity, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + if (obsolete_param_set) then + call MOM_error(WARNING, 'OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY'//& + ' and OBC_SPECIFIED_VORTICITY are obsolete, use OBC_VORTICITY_CONFIG instead.') + if ((zero_vorticity .and. freeslip_vorticity) .or. & + (zero_vorticity .and. computed_vorticity) .or. & + (zero_vorticity .and. specified_vorticity) .or. & + (freeslip_vorticity .and. computed_vorticity) .or. & + (freeslip_vorticity .and. specified_vorticity) .or. & + (computed_vorticity .and. specified_vorticity)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& + "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//& + "and OBC_IMPORTED_VORTICITY can be True at once.") + ! "config" is set from OBC_XXX_VORTICITY if they are used. + if (zero_vorticity) then + config = 'zero' + elseif (freeslip_vorticity) then + config = 'freeslip' + elseif (computed_vorticity) then + config = 'computed' + elseif (specified_vorticity) then + config = 'specified' else - OBC%add_tide_constituents = .false. + config = 'none' endif + else + config = 'freeslip' ! Default + endif + ! New setup method (overrides old method if specified) + call read_param(param_file, "OBC_VORTICITY_CONFIG", config) + call get_param(param_file, mdl, "OBC_VORTICITY_CONFIG", config, & + "Configuration for relative vorticity in momentum advection at open "//& + "boundaries. Options are: \n"// & + " \t none - No adjustment.\n"//& + " \t zero - Sets relative vorticity to zero.\n"//& + " \t freeslip - Sets the normal gradient of tangential velocity to zero.\n"//& + " \t computed - Computes the normal gradient of tangential velocity using\n"//& + " \t external values of tangential velocity.\n"//& + " \t specified - Uses the external values of the normal gradient of\n"//& + " \t tangential velocity.", default="freeslip", do_not_read=.true.) + select case (trim(config)) + case ("none") ; OBC%vorticity_config = OBC_VORTICITY_NONE + case ("zero") ; OBC%vorticity_config = OBC_VORTICITY_ZERO + case ("freeslip") ; OBC%vorticity_config = OBC_VORTICITY_FREESLIP + case ("computed") ; OBC%vorticity_config = OBC_VORTICITY_COMPUTED + case ("specified") ; OBC%vorticity_config = OBC_VORTICITY_SPECIFIED + case default + call MOM_error(FATAL, "MOM_open_boundary: Unrecognized OBC_VORTICITY_CONFIG: "//trim(config)) + end select + + ! Configuration for OBC strain. + ! Old setup method + obsolete_param_set = .false. + zero_strain = .false. + call read_param(param_file, "OBC_ZERO_STRAIN", zero_strain, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + freeslip_strain = .true. + call read_param(param_file, "OBC_FREESLIP_STRAIN", freeslip_strain, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + computed_strain = .false. + call read_param(param_file, "OBC_COMPUTED_STRAIN", computed_strain, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + specified_strain = .false. + call read_param(param_file, "OBC_SPECIFIED_STRAIN", specified_strain, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + if (obsolete_param_set) then + call MOM_error(WARNING, 'OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN'//& + ' and OBC_SPECIFIED_STRAIN are obsolete, use OBC_STRAIN_CONFIG instead.') + if ((zero_strain .and. freeslip_strain) .or. & + (zero_strain .and. computed_strain) .or. & + (zero_strain .and. specified_strain) .or. & + (freeslip_strain .and. computed_strain) .or. & + (freeslip_strain .and. specified_strain) .or. & + (computed_strain .and. specified_strain)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//& + "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//& + "and OBC_IMPORTED_STRAIN can be True at once.") + ! "config" is set from OBC_XXX_STRAIN if they are used. + if (zero_strain) then + config = 'zero' + elseif (freeslip_strain) then + config = 'freeslip' + elseif (computed_strain) then + config = 'computed' + elseif (specified_strain) then + config = 'specified' + else + config = 'none' + endif + else + config = 'freeslip' ! Default + endif + ! New setup method (overrides old method if specified) + call read_param(param_file, "OBC_STRAIN_CONFIG", config) + call get_param(param_file, mdl, "OBC_STRAIN_CONFIG", config, & + "Configuration for strain in horizontal viscosity at open boundaries. "//& + "Options are: \n"// & + " \t none - No adjustment.\n"//& + " \t zero - Sets strain to zero.\n"//& + " \t freeslip - Sets the normal gradient of tangential velocity to zero.\n"//& + " \t computed - Computes the normal gradient of tangential velocity using\n"//& + " \t external values of tangential velocity.\n"//& + " \t specified - Uses the external values of the normal gradient of\n"//& + " \t tangential velocity.", default="freeslip", do_not_read=.true.) + select case (trim(config)) + case ("none") ; OBC%strain_config = OBC_STRAIN_NONE + case ("zero") ; OBC%strain_config = OBC_STRAIN_ZERO + case ("freeslip") ; OBC%strain_config = OBC_STRAIN_FREESLIP + case ("computed") ; OBC%strain_config = OBC_STRAIN_COMPUTED + case ("specified") ; OBC%strain_config = OBC_STRAIN_SPECIFIED + case default + call MOM_error(FATAL, "MOM_open_boundary: Unrecognized OBC_STRAIN_CONFIG: "//trim(config)) + end select - call get_param(param_file, mdl, "DEBUG", debug, default=.false.) - call get_param(param_file, mdl, "DEBUG_OBCS", 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=.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 (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, & + 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, & + 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, & + 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.debugging_tests, debuggingParam=.true.) - call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & + 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.debugging_tests, debuggingParam=.true.) - call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + 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, & + call get_param(param_file, mdl, "EXTERIOR_OBC_BUG", OBC%exterior_OBC_bug, & "If true, recover a bug in barotropic solver and other routines when "//& "boundary contitions interior to the domain are used.", & default=enable_bugs) - call get_param(param_file, mdl, "OBC_HOR_INDEXING_BUG", OBC%hor_index_bug, & + 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, & + call get_param(param_file, mdl, "OBC_RESERVOIR_INIT_BUG", OBC%reservoir_init_bug, & "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& "interior tracer concentrations regardless of properties that may be explicitly "//& "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.) - reentrant_x = .false. - call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) - reentrant_y = .false. - 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)%values_needed = .false. - OBC%segment(n)%u_values_needed = .false. - OBC%segment(n)%uamp_values_needed = OBC%add_tide_constituents - OBC%segment(n)%uphase_values_needed = OBC%add_tide_constituents - OBC%segment(n)%v_values_needed = .false. - OBC%segment(n)%vamp_values_needed = OBC%add_tide_constituents - OBC%segment(n)%vphase_values_needed = OBC%add_tide_constituents - OBC%segment(n)%t_values_needed = .false. - OBC%segment(n)%s_values_needed = .false. - OBC%segment(n)%z_values_needed = .false. - OBC%segment(n)%zamp_values_needed = OBC%add_tide_constituents - OBC%segment(n)%zphase_values_needed = OBC%add_tide_constituents - OBC%segment(n)%g_values_needed = .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. + 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=enable_bugs) + call get_param(param_file, mdl, "IGNORE_DT_OBC_SEG_UPDATE_OBGC", OBC%ignore_dt_obc_bgc, & + "If true, DT_OBC_SEG_UPDATE_OBGC is ignored and all OBC segment tracer data "//& + "(T/S and BGC) is updated every tracer advection step. If false, T/S is "//& + "updated every dynamic step, which is unnecessary, while BGC follows its own "//& + "update schedule, which may not reproduce across restarts. Once "//& + "DT_OBC_SEG_UPDATE_OBGC is deprecated, only the 'true' path will be needed.", & + default=.false.) + call get_param(param_file, mdl, "OBC_TRACER_DZ_BUG", OBC%tracer_dz_bug, & + "If true, recover a bug that OBC tracer segment data is read without "//& + "recomputing segment layer thicknesses from the current layer thicknesses "//& + "and thermodynamic state.", default=enable_bugs) + 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. - 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 - 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() + 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) - if (open_boundary_query(OBC, apply_open_OBC=.true.)) then - call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & + ! 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, & "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 - - 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 + 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) + + 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 the tracer reservoir update when the flow "//& + "is exiting the domain. If positive, the reservoir relaxes toward the "//& + "interior concentration with this length scale. If zero (default), the "//& + "length scale is truly zero: the reservoir is set instantly to the "//& + "interior concentration on outflow. If negative, the length scale is "//& + "effectively infinite: the reservoir is never updated on outflow.", & + 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 the tracer reservoir update when the flow "//& + "is entering the domain. If positive, the reservoir relaxes toward the "//& + "external OBC concentration with this length scale. If zero (default), "//& + "the length scale is truly zero: the reservoir is set instantly to the "//& + "external OBC concentration on inflow. If negative, the length scale is "//& + "effectively infinite: the reservoir is never updated on inflow.", & + units="m", default=0.0, scale=US%m_to_L) + endif - ! 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 + ! 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. + ! All segments also have the same restoring length scale. Internally, each tracer has + ! resrv_lfac_in/out attributes to rescale the length scales. resrv_lfac_in/out is only + ! used by BGC tracers at the moment. + do n=1,OBC%number_of_segments + if (Lscale_in > 0.0) then + OBC%segment(n)%Tr_InvLscale_in = 1.0 / Lscale_in + elseif (Lscale_in < 0.0) then + OBC%segment(n)%Tr_InvLscale_in = 0.0 + else ! (Lscale_in == 0.0) then + OBC%segment(n)%Tr_InvLscale_in = -1.0 ! A nondim sentinel value + endif + if (Lscale_out > 0.0) then + OBC%segment(n)%Tr_InvLscale_out = 1.0 / Lscale_out + elseif (Lscale_out < 0.0) then 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) + else ! (Lscale_out == 0.0) then + OBC%segment(n)%Tr_InvLscale_out = -1.0 ! A nondim sentinel value endif + enddo - 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 + 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 - enddo + 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: "//& @@ -906,43 +1030,268 @@ subroutine open_boundary_setup_vert(GV, US, OBC) end subroutine open_boundary_setup_vert +!> Determine which physical fields are required for this segment based on boundary-condition type +!! and segment orientation. Also enable groups of physical fields required by tides or thermodynamics. +!! Note the tidal group could be further narrowed based on modes. +subroutine segment_determine_required_fields(segment, tides, temp_salt) + type(OBC_segment_type), intent(inout) :: segment !< OBC segment + logical, optional, intent(in) :: tides !< Switch for tidal variables + logical, optional, intent(in) :: temp_salt !< Switch for thermodynamic variables + + ! Local variables + logical :: use_tide ! Local switch for tidal variables + logical :: use_temp ! Local switch for thermodynamic variables + integer :: m + integer :: F_Vn, F_Vt, F_G + integer, parameter :: & + tide_idx(6) = (/ F_UAMP, F_UPHASE, F_VAMP, F_VPHASE, F_ZAMP, F_ZPHASE /), & ! Indices for tides + temp_idx(2) = (/ F_T, F_S /) ! Indices for thermodynamics + + if (.not. associated(segment%field)) & + call MOM_error(FATAL, 'segment_determine_required_fields: segment%field is not allocated.') + + use_tide = .false. ; if (present(tides)) use_tide = tides + use_temp = .false. ; if (present(temp_salt)) use_temp = temp_salt + + ! Normal, tangential and gradient depend on segment orientation. + if (segment%is_E_or_W_2) then + F_Vn = F_U ; F_Vt = F_V ; F_G = F_VX + else + F_Vn = F_V ; F_Vt = F_U ; F_G = F_UY + endif + if (segment%Flather) & + segment%field(F_Z)%required = .true. + + if (segment%Flather .or. segment%nudged .or. segment%specified) & + segment%field(F_Vn)%required = .true. + + if (segment%nudged_tan .or. segment%specified_tan) & + segment%field(F_Vt)%required = .true. + + if (segment%nudged_grad .or. segment%specified_grad) & + segment%field(F_G)%required = .true. + + if (use_tide) then ; do m = 1, size(tide_idx) + segment%field(tide_idx(m))%required = .true. + enddo ; endif + + if (use_temp) then ; do m = 1, size(temp_idx) + segment%field(temp_idx(m))%required = .true. + enddo ; endif + +end subroutine segment_determine_required_fields + +!> Find physical field index from name +integer function find_phys_field_index(name) + character(len=*), intent(in) :: name !< Field name + + ! Local variables + integer :: i + + find_phys_field_index = 0 + do i = 1, NUM_PHYS_FIELDS ; if (trim(name) == PHYS_FIELD_NAMES(i)) then + find_phys_field_index = i + return + endif ; enddo +end function find_phys_field_index + +!> Set global flag OBC%any_needs_IO_for_data. +subroutine OBC_any_IO(OBC) + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure + + ! Local variables + integer :: m, n + logical :: use_IO + + use_IO = .false. + do n=1,OBC%number_of_segments + do m=1,OBC%segment(n)%num_fields + if (OBC%segment(n)%field(m)%use_IO) then + use_IO = .true. + exit + endif + enddo + if (use_IO) exit + enddo + + OBC%any_needs_IO_for_data = any_across_PEs(use_IO) +end subroutine OBC_any_IO + +!> Allocate data (buffer_src, buffer_dst and dz_src) for a field at an OBC segment. +subroutine allocate_segment_field_data(field, OBC, segment, US, inputdir, filename, varname, & + suffix, value, turns, nz) + type(OBC_segment_data_type), & + intent(inout) :: field !< A field of the segment + type(ocean_OBC_type), intent(in) :: OBC !< Open boundary control structure + type(OBC_segment_type), intent(inout) :: segment !< Segment to work on + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=*), intent(in) :: inputdir !< The directory of input files + character(len=*), intent(in) :: filename !< Input file name + character(len=*), intent(in) :: varname !< Variable name in the input file + character(len=*), intent(in) :: suffix !< Variable name suffix, "_segment_xxx" + real, intent(in) :: value !< Unscaled specified value of the field [a] + integer, intent(in) :: turns !< Number of quarter turns of the grid + integer, intent(in) :: nz !< Default k-axis size in buffer_dst + + ! Local variables + character(len=256) :: full_filename, full_varname ! Full filename and varname + character(len=512) :: mesg ! Error message + real :: init_value_dst ! Initial value for allocated buffer_dst array [a] + integer :: qturns ! The number of quarter turns in the range of 0 to 3 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB ! Aliases of segment geometry indices + integer, dimension(4) :: siz, siz_check ! Four-dimensional shape of a variable in input file + integer :: dim ! Loop index for siz/siz_check + integer :: nk_dst ! k-axis size of buffer_dst + + if (.not. segment%on_pe) return + + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + nk_dst = nz + + qturns = modulo(turns, 4) + + field%on_face = field_is_on_face(field%name, segment%is_E_or_W) + ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input + ! value is rescaled there. + field%scale = scale_factor_from_name(field%name, US, segment%tr_Reg) + field%use_IO = (trim(filename) /= 'none') + + if (field%use_IO) then + full_filename = trim(inputdir) // trim(filename) + full_varname = trim(varname) // trim(suffix) + + if (.not.file_exists(full_filename)) & + call MOM_error(FATAL," Unable to open OBC file " // trim(full_filename)) + + call field_size(full_filename, full_varname, siz, no_domain=.true.) + field%nk_src = siz(3) + + if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then + write(mesg, '("Brushcutter mode sizes ",I0," ",I0)') siz(1), siz(2) + call MOM_error(WARNING, mesg // " " // trim(full_filename) // " " // trim(full_varname)) + call MOM_error(FATAL,'segment data are not on the supergrid') + endif + + ! Allocate src array + if (.not.field%on_face) then + allocate(field%buffer_src(IsdB:IedB, JsdB:JedB, field%nk_src), source=0.0) + elseif (segment%is_E_or_W) then + allocate(field%buffer_src(IsdB:IedB, jsd:jed, field%nk_src), source=0.0) + else + allocate(field%buffer_src(isd:ied, JsdB:JedB, field%nk_src), source=0.0) + endif + + field%handle = init_external_field(trim(full_filename), trim(full_varname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) + + if ((field%nk_src > 1) .and. (.not. field_is_tidal(field%name))) then ! nk_src is depth + full_varname = 'dz_' // trim(full_varname) + call field_size(full_filename, full_varname, siz_check, no_domain=.true.) + do dim = 1, 4 ; if (siz(dim) /= siz_check(dim)) & + call MOM_error(FATAL, "'dz' field size is inconsistent with "//& + "its corresponding variable.") + enddo + + if (.not.field%on_face) then + allocate(field%dz_src(IsdB:IedB, JsdB:JedB, field%nk_src), source=0.0) + elseif (segment%is_E_or_W) then + allocate(field%dz_src(IsdB:IedB, jsd:jed, field%nk_src), source=0.0) + else + allocate(field%dz_src(isd:ied, JsdB:JedB, field%nk_src), source=0.0) + endif + field%dz_handle = init_external_field(trim(full_filename), trim(full_varname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) + + elseif (field_is_tidal(field%name)) then ! nk_src is constituent for tidal variables + ! expect third dimension to be number of constituents in MOM_input + if (OBC%add_tide_constituents .and. (field%nk_src /= OBC%n_tide_constituents)) & + call MOM_error(FATAL, 'Number of constituents in input data is not '//& + 'the same as the number specified') + nk_dst = field%nk_src + + else ! nk_src = 1 + nk_dst = 1 + + endif + + init_value_dst = 0.0 + else ! This data is not being read from a file. + field%value = field%scale * value + ! Change the sign of the specified velocities, depending on the number of quarter turns of the grid. + if ( ( ((field%name == 'U') .or. (field%name == 'Uamp')) .and. & + ((qturns == 1) .or. (qturns == 2)) ) .or. & + ( ((field%name == 'V') .or. (field%name == 'Vamp')) .and. & + ((qturns == 3) .or. (qturns == 2)) ) ) & + field%value = -field%value + + ! Check if this is a tidal field. If so, the number of expected constituents must be 1. + if (field_is_tidal(field%name)) then + if (OBC%add_tide_constituents .and. (OBC%n_tide_constituents > 1)) & + call MOM_error(FATAL, 'Only one constituent is supported when specifying '//& + 'tidal boundary conditions by value rather than file.') + nk_dst = 1 + endif + + if (field%name == 'SSH') & + nk_dst = 1 + + init_value_dst = field%value + endif + + ! Allocate buffer_dst array + if (.not.field%on_face) then + allocate(field%buffer_dst(IsdB:IedB, JsdB:JedB, nk_dst), source=init_value_dst) + elseif (segment%is_E_or_W) then + allocate(field%buffer_dst(IsdB:IedB, jsd:jed, nk_dst), source=init_value_dst) + else + allocate(field%buffer_dst(isd:ied, JsdB:JedB, nk_dst), source=init_value_dst) + endif +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) +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. + ! Local variables integer :: n, n_seg, m, num_manifest_fields, mm character(len=1024) :: segstr character(len=256) :: filename character(len=20) :: segname, suffix - character(len=32) :: fieldname + 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 - integer :: isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB - integer :: qturns ! The number of quarter turns in the range of 0 to 3 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(2) ! 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 - qturns = modulo(turns, 4) + if (OBC%user_BCs_set_globally) return + + routine_name = trim(mdl) // ', initialize_segment_data' + + 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(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n @@ -960,14 +1309,14 @@ subroutine initialize_segment_data(GV, US, OBC, PF, turns) 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) - ! segment%values_needed is only true if this segment is on the local PE and some values need to be read. - if (.not. OBC%segment(n_seg)%values_needed) cycle + + if (.not. segment%on_pe) cycle 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, segname, segstr, 'xyz') + ! call get_param(PF, mdl, segname, segstr, 'xyz') ! Clear out any old values segstr = '' call get_param(PF, mdl, segname, segstr) @@ -976,191 +1325,87 @@ subroutine initialize_segment_data(GV, US, OBC, PF, turns) call MOM_error(FATAL, mesg) endif - call parse_segment_manifest_str(trim(segstr), num_manifest_fields, fields) - !There are OBC%num_obgc_tracers obgc tracers that are not listed in param file - segment%num_fields = num_manifest_fields + OBC%num_obgc_tracers - - if (segment%num_fields == 0) then - call MOM_mesg('initialize_segment_data: num_fields = 0') - cycle ! cycle to next segment - endif - + segment%num_fields = NUM_PHYS_FIELDS + OBC%num_obgc_tracers allocate(segment%field(segment%num_fields)) - segment%temp_segment_data_exists = .false. - segment%salt_segment_data_exists = .false. - segment%thickness_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 ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - jsd = segment%HI%jsd ; jed = segment%HI%jed ; 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 + ! Parse and find available physical fields + call parse_segment_manifest_str(trim(segstr), num_manifest_fields, phys_inputs) - do m=1,segment%num_fields - if (m <= num_manifest_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) - segment%field(m)%genre = '' - else - ! These are obgc tracers with segments specified by external modules. - ! Set a flag so that these can be distinguished from native tracers as they may need - ! extra steps for preparation and handling. - 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_manifest_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 + 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 - - segment%field(m)%name = rotated_field_name(trim(fields(m)), turns) - - ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input - ! value is rescaled there. - segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) - segment%field(m)%on_face = field_is_on_face(segment%field(m)%name, segment%is_E_or_W) - - if (trim(filename) /= 'none') then - OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file - OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data -! segment%values_needed = .true. ! Indicates that i/o will be needed for this segment - segment%field(m)%use_IO = .true. - - 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 (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(filename) // " " // trim(fieldname)) - call MOM_error(FATAL,'segment data are not on the supergrid') - endif - - if (.not.segment%field(m)%on_face) then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz(3)), source=0.0) - elseif (segment%is_E_or_W) then - allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz(3)), source=0.0) - else - allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz(3)), source=0.0) - endif - - segment%field(m)%handle = init_external_field(trim(filename), trim(fieldname), & - ignore_axis_atts=.true., threading=SINGLE_FILE) - if (siz(3) > 1) then - if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then - ! siz(3) is constituent for tidal variables - call field_size(filename, 'constituent', siz, no_domain=.true.) - ! expect third dimension to be number of constituents in MOM_input - if (siz(3) /= OBC%n_tide_constituents .and. OBC%add_tide_constituents) then - call MOM_error(FATAL, 'Number of constituents in input data is not '//& - 'the same as the number specified') - endif - else - ! siz(3) is depth for everything else - fieldname = 'dz_'//trim(fieldname) - call field_size(filename, fieldname, siz, no_domain=.true.) - - if (.not.segment%field(m)%on_face) then - allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3)), source=0.0) - elseif (segment%is_E_or_W) then - allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3)), source=0.0) - else - allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3)), source=0.0) - endif - segment%field(m)%dz_handle = init_external_field(trim(filename), trim(fieldname), & - ignore_axis_atts=.true., threading=SINGLE_FILE) - endif - segment%field(m)%nk_src = siz(3) - else - segment%field(m)%nk_src = 1 - endif - - if (segment%field(m)%name == 'TEMP') segment%temp_segment_data_exists = .true. - if (segment%field(m)%name == 'SALT') segment%salt_segment_data_exists = .true. - if (segment%field(m)%name == 'DZ') segment%thickness_segment_data_exists = .true. - - else ! This data is not being read from a file. - segment%field(m)%value = segment%field(m)%scale * value - ! Change the sign of the specified velocities, depending on the number of quarter turns of the grid. - if ( ( ((segment%field(m)%name == 'U') .or. (segment%field(m)%name == 'Uamp')) .and. & - ((qturns == 1) .or. (qturns == 2)) ) .or. & - ( ((segment%field(m)%name == 'V') .or. (segment%field(m)%name == 'Vamp')) .and. & - ((qturns == 3) .or. (qturns == 2)) ) ) & - segment%field(m)%value = -segment%field(m)%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 ((.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 - ! Check on which values this field is providing. - if (segment%field(m)%name == 'TEMP') segment%t_values_needed = .false. - if (segment%field(m)%name == 'SALT') segment%s_values_needed = .false. - if (segment%field(m)%name == 'U') segment%u_values_needed = .false. - if (segment%field(m)%name == 'V') segment%v_values_needed = .false. - if (segment%field(m)%name == 'SSH') segment%z_values_needed = .false. - if ((segment%is_N_or_S .and. segment%field(m)%name == 'DUDY') .or. & - (segment%is_E_or_W .and. segment%field(m)%name == 'DVDX')) segment%g_values_needed = .false. - if (segment%field(m)%name == 'Uamp') segment%uamp_values_needed = .false. - if (segment%field(m)%name == 'Uphase') segment%uphase_values_needed = .false. - if (segment%field(m)%name == 'Vamp') segment%vamp_values_needed = .false. - if (segment%field(m)%name == 'Vphase') segment%vphase_values_needed = .false. - if (segment%field(m)%name == 'SSHamp') segment%zamp_values_needed = .false. - if (segment%field(m)%name == 'SSHphase') segment%zphase_values_needed = .false. - - ! Store the field number for later retrievals. - if (segment%field(m)%name == 'Uamp') segment%uamp_index = m - if (segment%field(m)%name == 'Uphase') segment%uphase_index = m - if (segment%field(m)%name == 'Vamp') segment%vamp_index = m - if (segment%field(m)%name == 'Vphase') segment%vphase_index = m - if (segment%field(m)%name == 'SSHamp') segment%zamp_index = m - if (segment%field(m)%name == 'SSHphase') segment%zphase_index = m - + ! 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 - ! Check for any values that have not been provided. - if (segment%u_values_needed .or. segment%uamp_values_needed .or. segment%uphase_values_needed .or. & - segment%v_values_needed .or. segment%vamp_values_needed .or. segment%vphase_values_needed .or. & - segment%t_values_needed .or. segment%s_values_needed .or. segment%g_values_needed .or. & - segment%z_values_needed .or. segment%zamp_values_needed .or. segment%zphase_values_needed ) then - write(mesg,'("Values needed for OBC segment ",I0)') n - call MOM_error(FATAL, mesg) - endif + ! 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 + 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 - call sum_across_PES(IO_needs, 2) - OBC%any_needs_IO_for_data = (IO_needs(1) > 0) - OBC%update_OBC = (IO_needs(2) > 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 @@ -1264,9 +1509,8 @@ end subroutine set_segnum_signs !! 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 @@ -1564,8 +1808,6 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reent OBC%segment(l_seg)%open = .true. OBC%Flather_u_BCs_exist_globally = .true. OBC%open_u_BCs_exist_globally = .true. - OBC%segment(l_seg)%z_values_needed = .true. - OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'ORLANSKI') then OBC%segment(l_seg)%radiation = .true. OBC%segment(l_seg)%open = .true. @@ -1593,14 +1835,11 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reent elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. OBC%nudged_u_BCs_exist_globally = .true. - OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then OBC%segment(l_seg)%nudged_tan = .true. OBC%nudged_u_BCs_exist_globally = .true. - OBC%segment(l_seg)%v_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. @@ -1608,13 +1847,10 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reent elseif (trim(action_str(a_loop)) == 'SIMPLE') then OBC%segment(l_seg)%specified = .true. OBC%specified_u_BCs_exist_globally = .true. ! This avoids deallocation - OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then OBC%segment(l_seg)%specified_tan = .true. - OBC%segment(l_seg)%v_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_u_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") @@ -1658,11 +1894,6 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reent 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 @@ -1708,8 +1939,6 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reent 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. @@ -1737,14 +1966,11 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reent 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. @@ -1752,13 +1978,10 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reent 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.") @@ -1801,10 +2024,6 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reent 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 @@ -1840,7 +2059,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 @@ -1909,7 +2128,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 @@ -1925,7 +2144,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 @@ -1936,19 +2155,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 @@ -2016,7 +2251,7 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) 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 @@ -2266,9 +2501,9 @@ 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 @@ -2284,9 +2519,9 @@ 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 @@ -2300,12 +2535,12 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) if (segment%is_E_or_W) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - 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 @@ -2503,7 +2738,7 @@ subroutine set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS) type(ocean_OBC_type), intent(in) :: OBC !< Open boundary control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure character(len=12) :: x_var_name, y_var_name - integer :: i, j, k, m, n + integer :: m do m=1,OBC%ntr ! Set the names of the reservoirs for this tracer in the restart file @@ -2521,8 +2756,88 @@ subroutine set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS) end subroutine set_initialized_OBC_tracer_reservoirs +!> Copy radiation and oblique boundary condition coefficients (phase speeds and normalizing +!! denominator) from the global restart arrays into the per-segment arrays. +subroutine copy_OBC_radiation_coefs(OBC) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + integer :: nz, i, j, k, n, is, ie, js, je + + if (.not. associated(OBC)) return + if (OBC%gamma_uv >= 1.0) return + + nz = OBC%ke + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%is_E_or_W) then ! EW segment + I = segment%HI%IsdB ; js = segment%HI%jsd ; je = segment%HI%jed + if (segment%radiation) then + do k=1,nz ; do j=js,je + segment%rx_norm_rad(I,j,k) = OBC%rx_normal(I,j,k) + enddo ; enddo + endif + if (segment%oblique) then + do k=1,nz ; do j=js,je + segment%rx_norm_obl(I,j,k) = OBC%rx_oblique_u(I,j,k) + segment%ry_norm_obl(I,j,k) = OBC%ry_oblique_u(I,j,k) + segment%cff_normal(I,j,k) = OBC%cff_normal_u(I,j,k) + enddo ; enddo + endif + elseif (segment%is_N_or_S) then ! NS segment + J = segment%HI%JsdB ; is = segment%HI%isd ; ie = segment%HI%ied + if (segment%radiation) then + do k=1,nz ; do i=is,ie + segment%ry_norm_rad(i,J,k) = OBC%ry_normal(i,J,k) + enddo ; enddo + endif + if (segment%oblique) then + do k=1,nz ; do i=is,ie + segment%rx_norm_obl(i,J,k) = OBC%rx_oblique_v(i,J,k) + segment%ry_norm_obl(i,J,k) = OBC%ry_oblique_v(i,J,k) + segment%cff_normal(i,J,k) = OBC%cff_normal_v(i,J,k) + enddo ; enddo + endif + endif + enddo + +end subroutine copy_OBC_radiation_coefs + +!> Copy restart fields OBC%tres_x/y to per-segment tracer reservoir segment%tr_Reg%Tr(m)%tres. +subroutine copy_OBC_tracer_reservoirs(OBC) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + integer :: n, m, i, j, k, is, ie, js, je, nz + + if (.not. associated(OBC)) return + ! The allocated checks are needed for some user cases (e.g. "dyed_obcs"), where per-segment + ! tracers are registered after global restart arrays OBC%tres_x/y are allocated (or not). + if (.not. (allocated(OBC%tres_x) .or. allocated(OBC%tres_y))) return + + nz = OBC%ke + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. (segment%on_pe .and. associated(segment%tr_Reg))) cycle + if (segment%is_E_or_W .and. allocated(OBC%tres_x)) then ! EW segment + I = segment%HI%IsdB ; js = segment%HI%jsd ; je = segment%HI%jed + do m=1, segment%tr_Reg%ntseg ; do k=1,nz ; do j=js,je + segment%tr_Reg%Tr(m)%tres(I,j,k) = segment%tr_Reg%Tr(m)%scale * OBC%tres_x(I,j,k,m) + enddo ; enddo ; enddo + elseif (segment%is_N_or_S .and. allocated(OBC%tres_y)) then ! NS segment + J = segment%HI%JsdB ; is = segment%HI%isd ; ie = segment%HI%ied + do m=1, segment%tr_Reg%ntseg ; do k=1,nz ; do i=is,ie + segment%tr_Reg%Tr(m)%tres(i,J,k) = segment%tr_Reg%Tr(m)%scale * OBC%tres_y(i,J,k,m) + enddo ; enddo ; enddo + endif + enddo ! end segment loop +end subroutine copy_OBC_tracer_reservoirs + !> Fill segment%h_Reg from restart fields. -subroutine copy_thickness_reservoirs(OBC, G, GV) +subroutine copy_OBC_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 @@ -2570,7 +2885,7 @@ subroutine copy_thickness_reservoirs(OBC, G, GV) endif endif -end subroutine copy_thickness_reservoirs +end subroutine copy_OBC_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) @@ -2578,7 +2893,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. @@ -2626,80 +2941,6 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, eps = 1.0e-20*US%m_s_to_L_T**2 - !! Copy previously calculated phase velocity from global arrays into segments - !! This is terribly inefficient and temporary solution for continuity across restarts - !! 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) - if (.not. segment%on_pe) cycle - if (segment%is_E_or_W .and. segment%radiation) then - do k=1,GV%ke - I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - segment%rx_norm_rad(I,j,k) = OBC%rx_normal(I,j,k) - enddo - enddo - elseif (segment%is_N_or_S .and. segment%radiation) then - do k=1,GV%ke - J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - segment%ry_norm_rad(i,J,k) = OBC%ry_normal(i,J,k) - enddo - enddo - endif - if (segment%is_E_or_W .and. segment%oblique) then - do k=1,GV%ke - I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - segment%rx_norm_obl(I,j,k) = OBC%rx_oblique_u(I,j,k) - segment%ry_norm_obl(I,j,k) = OBC%ry_oblique_u(I,j,k) - segment%cff_normal(I,j,k) = OBC%cff_normal_u(I,j,k) - enddo - enddo - elseif (segment%is_N_or_S .and. segment%oblique) then - do k=1,GV%ke - J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - segment%rx_norm_obl(i,J,k) = OBC%rx_oblique_v(i,J,k) - segment%ry_norm_obl(i,J,k) = OBC%ry_oblique_v(i,J,k) - segment%cff_normal(i,J,k) = OBC%cff_normal_v(i,J,k) - enddo - enddo - endif - enddo - endif - - ! Now tracers (if any) - do n=1,OBC%number_of_segments - segment => OBC%segment(n) - if (associated(segment%tr_Reg)) then - if (segment%is_E_or_W) then - I = segment%HI%IsdB - do m=1,OBC%ntr - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,GV%ke - do j=segment%HI%jsd,segment%HI%jed - segment%tr_Reg%Tr(m)%tres(I,j,k) = segment%tr_Reg%Tr(m)%scale * OBC%tres_x(I,j,k,m) - enddo - enddo - endif - enddo - else - J = segment%HI%JsdB - do m=1,OBC%ntr - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,GV%ke - do i=segment%HI%isd,segment%HI%ied - segment%tr_Reg%Tr(m)%tres(i,J,k) = segment%tr_Reg%Tr(m)%scale * OBC%tres_y(i,J,k,m) - enddo - enddo - endif - enddo - endif - endif - enddo - gamma_u = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max do n=1,OBC%number_of_segments @@ -2825,15 +3066,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=Js_obc,Je_obc rx_avg = rx_tang_rad(I,J,k) -! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then -! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * dt * G%IdxBu(I-1,J) -! elseif (G%mask2dCu(I-1,j) > 0.0) then -! rx_avg = u_new(I-1,j,k) * dt * G%IdxBu(I-1,J) -! elseif (G%mask2dCu(I-1,j+1) > 0.0) then -! rx_avg = u_new(I-1,j+1,k) * dt * G%IdxBu(I-1,J) -! else -! rx_avg = 0.0 -! endif + ! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then + ! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * dt * G%IdxBu(I-1,J) + ! elseif (G%mask2dCu(I-1,j) > 0.0) then + ! rx_avg = u_new(I-1,j,k) * dt * G%IdxBu(I-1,J) + ! elseif (G%mask2dCu(I-1,j+1) > 0.0) then + ! rx_avg = u_new(I-1,j+1,k) * dt * G%IdxBu(I-1,J) + ! else + ! rx_avg = 0.0 + ! endif segment%tangential_grad(I,J,k) = ((v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) / (1.0+rx_avg) enddo ; enddo @@ -3070,15 +3311,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=Js_obc,Je_obc rx_avg = rx_tang_rad(I,J,k) -! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then -! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * dt * G%IdxBu(I+1,J) -! elseif (G%mask2dCu(I+1,j) > 0.0) then -! rx_avg = u_new(I+1,j,k) * dt * G%IdxBu(I+1,J) -! elseif (G%mask2dCu(I+1,j+1) > 0.0) then -! rx_avg = u_new(I+1,j+1,k) * dt * G%IdxBu(I+1,J) -! else -! rx_avg = 0.0 -! endif + ! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then + ! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * dt * G%IdxBu(I+1,J) + ! elseif (G%mask2dCu(I+1,j) > 0.0) then + ! rx_avg = u_new(I+1,j,k) * dt * G%IdxBu(I+1,J) + ! elseif (G%mask2dCu(I+1,j+1) > 0.0) then + ! rx_avg = u_new(I+1,j+1,k) * dt * G%IdxBu(I+1,J) + ! else + ! rx_avg = 0.0 + ! endif segment%tangential_grad(I,J,k) = ((v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) / (1.0+rx_avg) enddo ; enddo @@ -3314,15 +3555,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=Is_obc,Ie_obc ry_avg = ry_tang_rad(I,J,k) -! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then -! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * dt * G%IdyBu(I,J-1)) -! elseif (G%mask2dCv(i,J-1) > 0.0) then -! ry_avg = v_new(i,J-1,k) * dt *G%IdyBu(I,J-1) -! elseif (G%mask2dCv(i+1,J-1) > 0.0) then -! ry_avg = v_new(i+1,J-1,k) * dt *G%IdyBu(I,J-1) -! else -! ry_avg = 0.0 -! endif + ! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then + ! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * dt * G%IdyBu(I,J-1)) + ! elseif (G%mask2dCv(i,J-1) > 0.0) then + ! ry_avg = v_new(i,J-1,k) * dt *G%IdyBu(I,J-1) + ! elseif (G%mask2dCv(i+1,J-1) > 0.0) then + ! ry_avg = v_new(i+1,J-1,k) * dt *G%IdyBu(I,J-1) + ! else + ! ry_avg = 0.0 + ! endif segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+ry_avg) enddo ; enddo @@ -3559,15 +3800,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=Is_obc,Ie_obc ry_avg = ry_tang_rad(I,J,k) -! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then -! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * dt * G%IdyBu(I,J+1) -! elseif (G%mask2dCv(i,J+1) > 0.0) then -! ry_avg = v_new(i,J+1,k) * dt * G%IdyBu(I,J+1) -! elseif (G%mask2dCv(i+1,J+1) > 0.0) then -! ry_avg = v_new(i+1,J+1,k) * dt * G%IdyBu(I,J+1) -! else -! ry_avg = 0.0 -! endif + ! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then + ! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * dt * G%IdyBu(I,J+1) + ! elseif (G%mask2dCv(i,J+1) > 0.0) then + ! ry_avg = v_new(i,J+1,k) * dt * G%IdyBu(I,J+1) + ! elseif (G%mask2dCv(i+1,J+1) > 0.0) then + ! ry_avg = v_new(i+1,J+1,k) * dt * G%IdyBu(I,J+1) + ! else + ! ry_avg = 0.0 + ! endif segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+ry_avg) enddo ; enddo @@ -3963,29 +4204,36 @@ 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 dZtot with extra values at the end to avoid segmentation faults in cases where ! it is interpolated to OBC vorticity points. + allocate(segment%dz(IsdB:IedB,jsd-1:jed+1,OBC%ke), source=0.0) allocate(segment%dZtot(IsdB:IedB,jsd-1:jed+1), source=0.0) - allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0) + 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) @@ -4001,29 +4249,36 @@ 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 dZtot with extra values at the end to avoid segmentation faults in cases where ! it is interpolated to OBC vorticity points. + allocate(segment%dz(isd-1:ied+1,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%dZtot(isd-1:ied+1,JsdB:JedB), source=0.0) - allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0) + 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) @@ -4045,11 +4300,11 @@ 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%dz)) deallocate(segment%dz) 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) @@ -4061,6 +4316,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) @@ -4162,625 +4420,679 @@ 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 and remap segment data for a single field index m. This is the shared per-field subroutine +!! used by read_OBC_dynamics_data and read_OBC_tracer_data. +subroutine read_OBC_field_data(G, GV, US, OBC, segment, m, 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(OBC_segment_type), pointer :: segment !< Segment whose field is being read + integer, intent(in) :: m !< Field index within segment%field + 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, nk_dst - type(OBC_segment_type), pointer :: segment => NULL() - integer, dimension(4) :: siz + integer :: i, j + integer :: IsdB, IedB, JsdB, JedB real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input [various units] + real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] + real :: dz_stack(SZK_(GV)) ! Distance between the interfaces at corner points [Z ~> m] 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 :: 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, bug_offset real :: net_dz_src ! Total vertical extent of the incoming flow in the source field [Z ~> m] real :: net_dz_int ! Total vertical extent of the incoming flow in the model [Z ~> m] real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim] - real :: tidal_vel ! Interpolated tidal velocity at the OBC points [L T-1 ~> m s-1] - real :: tidal_elev ! Interpolated tidal elevation at the OBC points [Z ~> m] - real :: ramp_value ! If OBC%ramp is True, where we are on the ramp from 0 to 1, or 1 otherwise [nondim]. - real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] integer :: turns ! Number of index quarter turns - real :: time_delta ! Time since tidal reference date [T ~> s] logical :: flip_buffer ! If true, the input buffer needs to be transposed - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - nz = GV%ke + 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) return + + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + ni_seg = segment%ie_obc - segment%is_obc + 1 ! Global number of q points + nj_seg = segment%je_obc - segment%js_obc + 1 ! Global number of q points + i_seg_offset = G%idg_offset - segment%HI%IsgB + j_seg_offset = G%jdg_offset - segment%HI%JsgB + + turns = modulo(G%HI%turns, 4) + + ! 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 + + 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 + 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 (.not.segment%field(m)%on_face) then + segment%field(m)%buffer_src(:,JsdB,:) = & + tmp_buffer(2*(IsdB+i_seg_offset+1)-1:2*(IedB+i_seg_offset)+1:2, 1, :) + else + segment%field(m)%buffer_src(:,JsdB,:) = & + tmp_buffer(2*(IsdB+i_seg_offset+1)+bug_offset:2*(IedB+i_seg_offset):2, 1, :) + endif + endif + else ! Not brushcutter_mode. + if (segment%is_E_or_W) then + if (.not.segment%field(m)%on_face) then + segment%field(m)%buffer_src(IsdB,:,:) = & + tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset+1,:) + else + segment%field(m)%buffer_src(IsdB,:,:) = & + tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset,:) + endif + else + if (.not.segment%field(m)%on_face) then + segment%field(m)%buffer_src(:,JsdB,:) = & + tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset+1,1,:) + else + segment%field(m)%buffer_src(:,JsdB,:) = & + tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset,1,:) + endif + endif + endif + + ! no dz for tidal variables + if (segment%field(m)%nk_src <= 1) then ! This is 2-d data with no remapping. + segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) + elseif (field_is_tidal(segment%field(m)%name)) then + ! The 3rd axis for tidal variables is the tidal constituent, so there is no remapping. + segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:) + else + ! Read in 3-d data that may need to be remapped onto the new grid + ! This is also where the 2-d tidal data values (apart from phase and amp) are actually read in. + call time_interp_external(segment%field(m)%dz_handle, Time, tmp_buffer_in, scale=US%m_to_Z) + + if (turns /= 0) 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 (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then + ni_buf = size(tmp_buffer, 1) - 1 + call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) + else + call rotate_array(tmp_buffer_in, turns, tmp_buffer) + endif + endif ! 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 (.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)%dz_src(IsdB,:,:) = & + tmp_buffer(1, 2*(JsdB+j_seg_offset+1)+bug_offset:2*(JedB+j_seg_offset):2, :) + endif + else + 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)%dz_src(:,JsdB,:) = & + tmp_buffer(2*(IsdB+i_seg_offset+1)+bug_offset:2*(IedB+i_seg_offset):2, 1, :) + endif + endif + else ! Not brushcutter_mode. + if (segment%is_E_or_W) then + if (.not.segment%field(m)%on_face) then + segment%field(m)%dz_src(IsdB,:,:) = & + tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset+1,:) + else + segment%field(m)%dz_src(IsdB,:,:) = & + tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset,:) + endif + else + if (.not.segment%field(m)%on_face) then + segment%field(m)%dz_src(:,JsdB,:) = & + tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset+1,1,:) + else + segment%field(m)%dz_src(:,JsdB,:) = & + tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset,1,:) + endif + endif + endif + + 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) * segment%dz(I,j,:) + G%mask2dCu(I,j+1) * segment%dz(I,j+1,:)) + call remapping_core_h(OBC%remap_z_CS, & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & + segment%field(m)%buffer_src(I,J,:), & + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:)) + endif + enddo + else + do j = JsdB+1, JedB + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(I,j,:) = 0.0 ! initialize remap destination buffer + if (G%mask2dCu(I,j)>0.) then + net_dz_src = sum( segment%field(m)%dz_src(I,j,:) ) + net_dz_int = sum( segment%dz(I,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, segment%dz(I,j,:), segment%field(m)%buffer_dst(I,j,:)) + endif + enddo + endif + else + J = JsdB + if (.not.segment%field(m)%on_face) then + ! Do q points for the whole segment + do I = max(IsdB, G%isd), min(IedB, G%ied-1) + segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer + if ((G%mask2dCv(i,J) > 0.0) .or. (G%mask2dCv(i+1,J) > 0.0)) then + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + dz_stack(:) = (1.0 / (G%mask2dCv(i,J) + G%mask2dCv(i+1,J))) * & + (G%mask2dCv(i,J) * segment%dz(i,J,:) + G%mask2dCv(i+1,J) * segment%dz(i+1,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,:)) + endif + enddo + else + do i = IsdB+1, IedB + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(i,J,:) = 0.0 ! initialize remap destination buffer + if (G%mask2dCv(i,J)>0.) then + net_dz_src = sum( segment%field(m)%dz_src(i,J,:) ) + net_dz_int = sum( segment%dz(i,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, segment%dz(i,J,:), segment%field(m)%buffer_dst(i,J,:)) + endif + enddo + endif + endif + endif + deallocate(tmp_buffer) + if (turns /= 0) deallocate(tmp_buffer_in) +end subroutine read_OBC_field_data + +!> Read OBC segment data for the dynamical fields, with field indices +!! m=1..NUM_PHYS_FIELDS-2 (U, V, gradients, SSH, and tidal constituents). +subroutine read_OBC_dynamics_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 :: n, m + type(OBC_segment_type), pointer :: segment => NULL() + + if (.not. associated(OBC)) return + if (OBC%user_BCs_set_globally) return + + call update_OBC_segment_dz(G, GV, US, OBC, h, tv) + + 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 + + do m=1, NUM_PHYS_FIELDS-2 + call read_OBC_field_data(G, GV, US, OBC, segment, m, Time) + enddo ! end dynamical field loop + enddo ! end segment loop +end subroutine read_OBC_dynamics_data + +!> Read OBC segment data for tracer fields, with field indices +!! m=NUM_PHYS_FIELDS-1..segment%num_fields (T, S, and BGC tracers). +!! If optional arguments h and tv are not given, it is assumed that segment%dz has been calculated +!! by a prior call to read_OBC_dynamics_data. Otherwise, segment%dz is recalculated with h and tv. +!! The optional argument include_bgc (default .true.) allows BGC fields to be read +!! independently. +subroutine read_OBC_tracer_data(G, GV, US, OBC, Time, h, tv, include_bgc) + 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(time_type), intent(in) :: Time !< Model time + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: h !< Thickness for recomputing dz [H ~> m or kg m-2] + type(thermo_var_ptrs), optional, intent(in) :: tv !< Thermodynamics structure for recomputing dz + logical, optional, intent(in) :: include_bgc !< Read BGC tracers + + ! Local variables + logical :: do_bgc ! If true, read BGC tracer fields + integer :: n, m + type(OBC_segment_type), pointer :: segment => NULL() + + if (.not. associated(OBC)) return + if (OBC%user_BCs_set_globally) return + + do_bgc = .true. ; if (present(include_bgc)) do_bgc = include_bgc + + if (present(h) .and. present(tv)) & + call update_OBC_segment_dz(G, GV, US, OBC, h, tv) + + 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 + + do m=NUM_PHYS_FIELDS-1, segment%num_fields + if (.not. allocated(segment%field(m)%buffer_dst)) cycle + if (segment%field(m)%bgc_tracer .and. (.not. do_bgc)) cycle + call read_OBC_field_data(G, GV, US, OBC, segment, m, Time) + enddo ! end tracer field loop + enddo ! end segment loop +end subroutine read_OBC_tracer_data + +!> Compute segment%dz and segment%dZtot at all OBC segments from the current layer thicknesses. +!! These arrays are the target vertical grid used for remapping OBC data to the model grid. +subroutine update_OBC_segment_dz(G, GV, US, OBC, h, 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 !< 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(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + + ! Local variables + integer :: i, j, k, n + type(OBC_segment_type), pointer :: segment => NULL() + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Distance between interfaces around a layer [Z ~> m] + + dz(:,:,:) = 0.0 + call thickness_to_dz(h, tv, dz, G, GV, US) + call pass_var(dz, G%Domain) + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + + ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points + segment%dZtot(:,:) = 0.0 + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do k=1,GV%ke ; do j=max(segment%HI%jsd-1, G%jsd), min(segment%HI%jed+1, G%jed) + segment%dz(I,j,k) = dz(segment%HI%isd,j,k) + segment%dZtot(I,j) = segment%dZtot(I,j) + segment%dz(I,j,k) + enddo ; enddo + else + J = segment%HI%JsdB + do k=1,GV%ke ; do i=max(segment%HI%isd-1, G%isd), min(segment%HI%ied+1, G%ied) + segment%dz(i,J,k) = dz(i,segment%HI%jsd,k) + segment%dZtot(i,J) = segment%dZtot(i,J) + segment%dz(i,J,k) + enddo ; enddo + endif + enddo ! end segment loop +end subroutine update_OBC_segment_dz + +!> Update OBC segment dynamical fields: normal/tangential velocity, gradient, SSH, and +!! the thickness reservoir. +subroutine update_OBC_dynamics_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 + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + integer :: c, i, j, k, n, nz + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: is_seg, ie_seg, js_seg, je_seg ! Orientation-agnostic loop ranges + integer :: i_offset_in, j_offset_in ! Indexing offset for interior cells + integer :: F_G, F_VN, F_VNAMP, F_VNPHASE, F_VT, F_VTAMP, F_VTPHASE ! Field indices + real :: ramp_value ! If OBC%ramp is True, where we are on the ramp from 0 to 1, or 1 otherwise [nondim]. + real :: time_delta ! Time since tidal reference date [T ~> s] + real :: tidal_amp, tidal_phase ! Tidal amplitude [Z ~> m] and phase [rad] + + if (.not. associated(OBC)) return + if (OBC%user_BCs_set_globally) return + + nz = GV%ke + + if (OBC%add_tide_constituents) & + time_delta = time_minus_signed(Time, OBC%time_ref, scale=US%s_to_T) + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + + if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain + + ! Segment indices are on q points: + ! | x | x | x | x | jsd/jed (if southern boundary) + ! |-----------|-----------|-----------|-----------| JsdB/JedB + ! IsdB isd ied IedB + ! | x | x | x | x | jsd/jed (if northern boundary) + + 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 + 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 + 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 (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 + + ! 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 + + 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 + + ! 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 + + 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 + enddo ! end segment loop +end subroutine update_OBC_dynamics_data + +!> Update the OBC segment tracer reservoir from segment%field(m)%buffer_dst for tracer field +!! indices m=NUM_PHYS_FIELDS-1..segment%num_fields. The optional argument include_bgc (default +!! true) allows BGC fields to be updated independently. +subroutine update_OBC_tracer_data(OBC, include_bgc) + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, optional, intent(in) :: include_bgc !< Update BGC tracers - turns = modulo(G%HI%turns, 4) + ! Local variables + logical :: do_bgc ! If true, update BGC tracer fields + type(OBC_segment_type), pointer :: segment => NULL() + integer :: i, j, k, n, m, nt, nz + integer :: is_seg, ie_seg, js_seg, je_seg ! Orientation-agnostic loop ranges if (.not. associated(OBC)) return + if (OBC%user_BCs_set_globally) return - if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref) + do_bgc = .true. ; if (present(include_bgc)) do_bgc = include_bgc - if (OBC%number_of_segments >= 1) then - dz(:,:,:) = 0.0 - call thickness_to_dz(h, tv, dz, G, GV, US) - call pass_var(dz, G%Domain) - endif + nz = OBC%ke 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 - if (.not. segment%on_pe) cycle ! continue to next segment if not in computational domain - - ! NOTE: segment%is_obc and segment%ie_obc are range of indices for the full segment. - ! The other data set here are in segment%HI, but here they defined slightly differently. - ni_seg = segment%ie_obc-segment%is_obc+1 - nj_seg = segment%je_obc-segment%js_obc+1 - is_obc = max(segment%is_obc,isd-1) - 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 - segment%Htot(:,:) = 0.0 - segment%dZtot(:,:) = 0.0 if (segment%is_E_or_W) then - allocate(normal_trans_bt(segment%HI%IsdB:segment%HI%IedB,segment%HI%jsd:segment%HI%jed), source=0.0) - if (segment%direction == OBC_DIRECTION_W) ishift = 1 - I=segment%HI%IsdB - ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points - do k=1,GV%ke ; do j = max(segment%HI%jsd-1,G%jsd), min(segment%HI%jed+1,G%jed) - segment%dZtot(I,j) = segment%dZtot(I,j) + dz(i+ishift,j,k) - enddo ; enddo - do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed - segment%h(I,j,k) = h(i+ishift,j,k) - segment%Htot(I,j) = segment%Htot(I,j) + segment%h(I,j,k) - enddo ; enddo - do j=segment%HI%jsd,segment%HI%jed - segment%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 - ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points - do k=1,GV%ke ; do i = max(segment%HI%isd-1,G%isd), min(segment%HI%ied+1,G%ied) - segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,j+jshift,k) - enddo ; enddo - do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied - segment%h(i,J,k) = h(i,j+jshift,k) - segment%Htot(i,J) = segment%Htot(i,J) + segment%h(i,J,k) - enddo ; enddo - do i=segment%HI%isd,segment%HI%ied - segment%Cg(i,J) = sqrt(GV%g_prime(1) * max(0.0, segment%dZtot(i,J))) - enddo + is_seg = segment%HI%IsdB ; ie_seg = is_seg + js_seg = segment%HI%jsd ; je_seg = segment%HI%jed + else + is_seg = segment%HI%isd ; ie_seg = segment%HI%ied + js_seg = segment%HI%JsdB ; je_seg = js_seg 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') - - nk_dst = GV%ke - if (field_is_tidal(segment%field(m)%name)) nk_dst = siz(3) - if (segment%field(m)%nk_src <= 1) nk_dst = 1 - if (.not.segment%field(m)%on_face) then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc, js_obc:je_obc, nk_dst), source=0.0) - elseif (segment%is_E_or_W) then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc, js_obc+1:je_obc, nk_dst), source=0.0) - else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc, js_obc:je_obc, nk_dst), source=0.0) - endif - endif - ! read source data interpolated to the current model time - ! NOTE: buffer is sized for vertex points, but may be used for faces - if (siz(1)==1) then - if (OBC%brushcutter_mode) then - allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currently on supergrid - else - allocate(tmp_buffer(1,nj_seg,segment%field(m)%nk_src)) ! segment data is currently on 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 + 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 + if (segment%field(m)%bgc_tracer .and. (.not. do_bgc)) cycle + nt = segment%field(m)%tr_index + 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 + enddo ! end tracer loop + enddo ! end segment loop +end subroutine update_OBC_tracer_data - 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 +!> 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 - 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(is_obc,:,:) = & - tmp_buffer(1, 2*(js_obc+j_seg_offset+1)-1:2*(je_obc+j_seg_offset)+1:2, :) - else - segment%field(m)%buffer_src(is_obc,:,:) = & - tmp_buffer(1, 2*(js_obc+j_seg_offset+1)+bug_offset:2*(je_obc+j_seg_offset):2, :) - endif - else - if (.not.segment%field(m)%on_face) then - segment%field(m)%buffer_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+i_seg_offset+1)-1:2*(ie_obc+i_seg_offset)+1:2, 1, :) - else - segment%field(m)%buffer_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+i_seg_offset+1)+bug_offset:2*(ie_obc+i_seg_offset):2, 1, :) - endif - endif - else ! Not brushcutter_mode. - if (segment%is_E_or_W) then - if (.not.segment%field(m)%on_face) then - segment%field(m)%buffer_src(is_obc,:,:) = & - tmp_buffer(1,js_obc+j_seg_offset+1:je_obc+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,:) - endif - else - if (.not.segment%field(m)%on_face) then - segment%field(m)%buffer_src(:,js_obc,:) = & - tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset+1,1,:) - else - segment%field(m)%buffer_src(:,js_obc,:) = & - tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset,1,:) - endif - endif - endif + ! 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 - ! 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) - - if (turns /= 0) 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 (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then - ni_buf = size(tmp_buffer, 1) - 1 - call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) - else - call rotate_array(tmp_buffer_in, turns, tmp_buffer) - endif - endif ! 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 (.not.segment%field(m)%on_face) then - segment%field(m)%dz_src(is_obc,:,:) = & - tmp_buffer(1, 2*(js_obc+j_seg_offset+1)-1:2*(je_obc+j_seg_offset)+1:2, :) - else - segment%field(m)%dz_src(is_obc,:,:) = & - tmp_buffer(1, 2*(js_obc+j_seg_offset+1)+bug_offset:2*(je_obc+j_seg_offset):2, :) - endif - else - if (.not.segment%field(m)%on_face) then - segment%field(m)%dz_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+i_seg_offset+1)-1:2*(ie_obc+i_seg_offset)+1:2, 1, :) - else - segment%field(m)%dz_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+i_seg_offset+1)+bug_offset:2*(ie_obc+i_seg_offset):2, 1, :) - endif - endif - else ! Not brushcutter_mode. - if (segment%is_E_or_W) then - if (.not.segment%field(m)%on_face) then - segment%field(m)%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 (.not.segment%field(m)%on_face) then - segment%field(m)%dz_src(:,js_obc,:) = & - tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset+1,1,:) - else - segment%field(m)%dz_src(:,js_obc,:) = & - tmp_buffer(is_obc+i_seg_offset+1:ie_obc+i_seg_offset,1,:) - endif - endif - endif + if (.not. associated(OBC)) return - 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 + nz = GV%ke - if (segment%is_E_or_W) then - ishift = 1 - if (segment%direction == OBC_DIRECTION_E) ishift = 0 - I=is_obc - if (.not.segment%field(m)%on_face) then - ! Do q points for the whole segment - do J=max(js_obc,jsd),min(je_obc,jed-1) - ! Using the h remapping approach - ! Pretty sure we need to check for source/target grid consistency here - !### For a concave corner between OBC segments, there are 3 thicknesses we might - ! consider using. - segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer - if (G%mask2dCu(I,j)>0. .and. G%mask2dCu(I,j+1)>0.) then - dz_stack(:) = 0.5*(dz(i+ishift,j,:) + dz(i+ishift,j+1,:)) - 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 - ! 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 - else - jshift = 1 - if (segment%direction == OBC_DIRECTION_N) jshift = 0 - J=js_obc - if (.not.segment%field(m)%on_face) then - ! Do q points for the whole segment - do I=max(is_obc,isd),min(ie_obc,ied-1) - segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer - 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 - endif - 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 - nk_dst = GV%ke - if (field_is_tidal(segment%field(m)%name)) nk_dst = 1 - if (segment%field(m)%name == 'SSH') nk_dst = 1 - if (.not.segment%field(m)%on_face) then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc, js_obc:je_obc, nk_dst), & - source=segment%field(m)%value) - elseif (segment%is_E_or_W) then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc, js_obc+1:je_obc, nk_dst), & - source=segment%field(m)%value) - else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc, js_obc:je_obc, nk_dst), & - source=segment%field(m)%value) - endif - endif - endif - enddo ! end field loop - - ! Start second loop to update all fields now that data for all fields are available. - ! (split because tides depend on multiple variables). - do m = 1,segment%num_fields - !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 + do n=1,OBC%number_of_segments + segment => OBC%segment(n) - ! endif + if (.not. segment%on_pe) cycle - ! from this point on, data are entirely on segments - will - ! write all segment loops as 2d loops. - if (segment%is_E_or_W) then - js_obc2 = js_obc+1 - is_obc2 = is_obc - else - js_obc2 = js_obc - is_obc2 = is_obc+1 - 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 - 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 - if (trim(segment%field(m)%name) == 'SSH') then - ramp_value = 1.0 - if (OBC%ramp) ramp_value = OBC%ramp_value - do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - tidal_elev = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - segment%SSH(i,j) = ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) - enddo ; enddo - endif + 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 - ! Set the thickness reservoir data. - if (OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used) then - do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc - segment%h_Reg%h(i,j,k) = segment%h(i,j,k) + ! 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 - if (.not. segment%h_Reg%is_initialized) then - ! If the thickness 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%h_Reg%h_res(i,j,k) = segment%h_Reg%h(i,j,k) - enddo ; enddo ; enddo - segment%h_Reg%is_initialized=.true. - endif + segment%h_Reg%is_initialized = .true. endif + endif - ! Set the inflow and reservoir data for tracers. - if ((trim(segment%field(m)%name) == 'TEMP') .or. (trim(segment%field(m)%name) == 'SALT') .or. & - (trim(segment%field(m)%genre) == 'obgc')) then - if (trim(segment%field(m)%name) == 'TEMP') then - nt = 1 - elseif (trim(segment%field(m)%name) == 'SALT') then - nt = 2 - elseif (trim(segment%field(m)%genre) == 'obgc') then - nt = get_tracer_index(segment,trim(segment%field(m)%name)) - if (nt < 0) call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) - endif - if (allocated(segment%field(m)%buffer_dst)) then - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo ; enddo ; enddo - if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then - ! If the tracer reservoir has not yet been initialized, then set to external value. - 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 + ! 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)) .or. & + (segment%field(m)%bgc_tracer .and. (.not. OBC%update_OBC_seg_data))) 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 field loop - deallocate(dz_stack) - deallocate(normal_trans_bt) - + enddo ! end tracer field loop enddo ! end segment loop - -end subroutine update_OBC_segment_data +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 @@ -4809,7 +5121,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 @@ -4947,9 +5259,6 @@ subroutine segment_thickness_reservoir_init(GV, US, OBC, param_file) 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 - character(len=256) :: mesg ! Message for error messages. - character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list integer, save :: init_calls = 0 @@ -4972,10 +5281,6 @@ subroutine segment_thickness_reservoir_init(GV, US, OBC, param_file) 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 @@ -5005,38 +5310,39 @@ subroutine segment_thickness_reservoir_init(GV, US, OBC, param_file) 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, & - OBC_scalar, OBC_array, scale, fd_index) +!> Register a tracer on an OBC segment, allocate its t and tres arrays, and set the +!! per-tracer inverse length scales (I_Lscale_in/out) that control reservoir relaxation. +subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, OBC_scalar, & + scale, resrv_lfac_in, resrv_lfac_out) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(tracer_type), target :: tr_ptr !< A target that can be used to set a pointer to the - !! stored value of tr. This target must be - !! an enduring part of the control structure, - !! because the tracer registry will use this memory, - !! but it also means that any updates to this - !! structure in the calling module will be - !! available subsequently to the tracer registry. + type(tracer_type), target :: tr_ptr !< Tracer to register; must persist in the caller's + !! control structure for the lifetime of the segment. integer, intent(in) :: ntr_index !< index of segment tracer in the global tracer registry type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values type(OBC_segment_type), intent(inout) :: segment !< current segment data structure - real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer - !! 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. + real, optional, intent(in) :: OBC_scalar !< If present, use this spatially uniform value as the + !! OBC inflow concentration in the tracer's internal + !! units, like [S ~> ppt] for salinity. Mutually + !! exclusive with resrv_lfac_in and resrv_lfac_out. real, optional, intent(in) :: scale !< A scaling factor that should be used with any !! data that is read in to convert it to the internal !! units of this tracer, in units like [S ppt-1 ~> 1] !! for salinity. - integer, optional, intent(in) :: fd_index !< index of segment tracer in the input field + real, optional, intent(in) :: resrv_lfac_in !< Per-tracer multiplier for the inward reservoir + !! relaxation length scale [nondim]. + real, optional, intent(in) :: resrv_lfac_out !< Per-tracer multiplier for the outward reservoir + !! relaxation length scale [nondim]. -! Local variables + ! 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 :: ntseg, m, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB character(len=256) :: mesg ! Message for error messages. + real :: init_value ! Initial tracer concentration in OBC-rescaled units [A ~> a] + + if (present(OBC_scalar) .and. (present(resrv_lfac_in) .or. present(resrv_lfac_out))) & + call MOM_error(FATAL, "register_segment_tracer: OBC_scalar and resrv_lfac_in/out are "// & + "mutually exclusive for tracer "//trim(tr_ptr%name)) call segment_tracer_registry_init(param_file, segment) @@ -5053,10 +5359,8 @@ subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - segment%tr_Reg%Tr(ntseg)%Tr => tr_ptr segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name segment%tr_Reg%Tr(ntseg)%ntr_index = ntr_index - if (present(fd_index)) segment%tr_Reg%Tr(ntseg)%fd_index = fd_index segment%tr_Reg%Tr(ntseg)%scale = 1.0 if (present(scale)) then @@ -5081,31 +5385,59 @@ subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & "MOM register_segment_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& " with a locked tracer registry.") - if (present(OBC_scalar)) segment%tr_Reg%Tr(ntseg)%OBC_inflow_conc = OBC_scalar ! initialize tracer value later - if (present(OBC_array)) then - 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. - 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. - endif + if (present(OBC_scalar)) then + init_value = OBC_scalar + segment%tr_Reg%Tr(ntseg)%is_initialized = .true. + segment%tr_Reg%Tr(ntseg)%resrv_lfac_in = 0.0 + segment%tr_Reg%Tr(ntseg)%resrv_lfac_out = 0.0 + else + init_value = 0.0 + segment%tr_Reg%Tr(ntseg)%is_initialized = .false. + ! Currently, resrv_lfac_in/out are for BGC tracers only. + if (present(resrv_lfac_in)) segment%tr_Reg%Tr(ntseg)%resrv_lfac_in = resrv_lfac_in + if (present(resrv_lfac_out)) segment%tr_Reg%Tr(ntseg)%resrv_lfac_out = resrv_lfac_out + endif + + if (segment%is_E_or_W) then + allocate(segment%tr_Reg%Tr(ntseg)%t(IsdB:IedB,jsd:jed,1:GV%ke), source=init_value) + allocate(segment%tr_Reg%Tr(ntseg)%tres(IsdB:IedB,jsd:jed,1:GV%ke), source=init_value) + elseif (segment%is_N_or_S) then + allocate(segment%tr_Reg%Tr(ntseg)%t(isd:ied,JsdB:JedB,1:GV%ke), source=init_value) + allocate(segment%tr_Reg%Tr(ntseg)%tres(isd:ied,JsdB:JedB,1:GV%ke), source=init_value) endif + ! Assign per-tracer inverse length scales from the per-tracer factor (resrv_lfac) and the + ! segment-level inverse length scale (Tr_InvLscale). Three regimes for each direction: + ! I_Lscale > 0 : finite relaxation length scale. + ! I_Lscale = 0 : infinite length scale; reservoir does not update. + ! I_Lscale = -1 : instant-update sentinel; reservoir is immediately replaced by interior or + ! external values. + ! For the two edge cases, resrv_lfac overrides Tr_InvLscale entirely, i.e., + ! resrv_lfac = 0 : I_Lscale = 0 + ! resrv_lfac = -1 : I_Lscale = -1 + segment%tr_Reg%Tr(ntseg)%I_Lscale_in = & + segment%tr_Reg%Tr(ntseg)%resrv_lfac_in * segment%Tr_InvLscale_in + if ((segment%tr_Reg%Tr(ntseg)%resrv_lfac_in == -1.0) .or. & + (segment%tr_Reg%Tr(ntseg)%I_Lscale_in < 0.0)) & + segment%tr_Reg%Tr(ntseg)%I_Lscale_in = -1.0 + segment%tr_Reg%Tr(ntseg)%I_Lscale_out = & + segment%tr_Reg%Tr(ntseg)%resrv_lfac_out * segment%Tr_InvLscale_out + if ((segment%tr_Reg%Tr(ntseg)%resrv_lfac_out == -1.0) .or. & + (segment%tr_Reg%Tr(ntseg)%I_Lscale_out < 0.0)) & + segment%tr_Reg%Tr(ntseg)%I_Lscale_out = -1.0 end subroutine register_segment_tracer !> Clean up the segment tracer registry. subroutine segment_tracer_registry_end(Reg) type(segment_tracer_registry_type), pointer :: Reg !< pointer to tracer registry -! Local variables - integer n + ! Local variables + integer :: n if (associated(Reg)) then - do n = 1, Reg%ntseg + do n=1, Reg%ntseg if (allocated(Reg%Tr(n)%t)) deallocate(Reg%Tr(n)%t) + if (allocated(Reg%Tr(n)%tres)) deallocate(Reg%Tr(n)%tres) enddo deallocate(Reg) endif @@ -5115,8 +5447,6 @@ end subroutine segment_tracer_registry_end 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) @@ -5149,12 +5479,10 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) name = 'temp' call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) - call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & - OBC_array=segment%temp_segment_data_exists, scale=US%degC_to_C) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, scale=US%degC_to_C) name = 'salt' call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) - call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & - OBC_array=segment%salt_segment_data_exists, scale=US%ppt_to_S) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, scale=US%ppt_to_S) enddo end subroutine register_temp_salt_segments @@ -5201,16 +5529,21 @@ end subroutine get_obgc_segments_props !> Registers a named tracer in the segment tracer registries for the OBC segments on which it is active. subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry - type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values - character(len=*), intent(in) :: tr_name !< Tracer name -! Local variables - integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf, ntr_id, fd_id - integer :: i, j, k, n, m + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + character(len=*), intent(in) :: tr_name !< Tracer name + + ! Local variables + integer :: ntr_id + integer :: n, m type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - type(tracer_type), pointer :: tr_ptr => NULL() + type(tracer_type), pointer :: tr_ptr => NULL() + real :: resrv_lfac_in ! Per-tracer multiplier for the inward reservoir + ! relaxation length scale [nondim]. + real :: resrv_lfac_out ! Per-tracer multiplier for the outward reservoir + ! relaxation length scale [nondim]. if (.not. associated(OBC)) return @@ -5218,14 +5551,17 @@ subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) segment => OBC%segment(n) if (.not. segment%on_pe) cycle call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, tr_name) - ! get the obgc field index - fd_id = -1 + resrv_lfac_in = 1.0 + resrv_lfac_out = 1.0 do m=1,segment%num_fields - if (lowercase(segment%field(m)%name) == lowercase(tr_name)) fd_id = m + if (lowercase(segment%field(m)%name) == lowercase(tr_name)) then + resrv_lfac_in = segment%field(m)%resrv_lfac_in + resrv_lfac_out = segment%field(m)%resrv_lfac_out + endif enddo - call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, OBC_array=.True., fd_index=fd_id) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & + resrv_lfac_in=resrv_lfac_in, resrv_lfac_out=resrv_lfac_out) enddo - end subroutine register_obgc_segments !> Stores the interior tracer values on the segment, and in some cases also sets the tracer reservoir values. @@ -5433,7 +5769,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] @@ -5801,10 +6136,20 @@ 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. +!> Update OBC tracer reservoirs (segment%tr_Reg%Tr%tres) using a backward-Euler implicit step, +!! then copy the result into OBC%tres_x / OBC%tres_y for restart I/O. +!! +!! The reservoir at each boundary cell is nudged toward the adjacent interior tracer (on outflow) +!! or the open-ocean boundary value (on inflow), weighted by the volume flux and the per-tracer +!! inverse length scale I_Lscale. Three regimes, set at registration via I_Lscale_in/out: +!! - **Frozen** (I_Lscale = 0): tres is unchanged every timestep. +!! - **Finite length scale** (I_Lscale > 0): tres relaxes toward the interior or boundary value +!! at a rate proportional to the flux and I_Lscale. +!! - **Instant update** (I_Lscale = -1): tres is immediately replaced by the interior value +!! (outflow) or the boundary value (inflow). 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 + 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 @@ -5814,122 +6159,115 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, Reg) type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry - ! Local variable + ! Local variables 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, m, n, ntr, nz, ntr_id, fd_id - integer :: ishift, idir, jshift, jdir - real :: resrv_lfac_out ! The reservoir inverse length scale scaling factor for the outward - ! direction per field [nondim] - real :: resrv_lfac_in ! The reservoir inverse length scale scaling factor for the inward - ! direction per field [nondim] - real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs - ! 1 if the length scale of reservoir is zero [nondim] - real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights - ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward - ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward - ! It's clear that a_in and a_out cannot be both non-zero [nondim] + integer :: dir ! Sign convention so that positive flux_to_res means flow toward the + ! reservoir: -1 for W/S segments, +1 for E/N segments. + real :: face_area ! Interior cell face area adjacent to the OBC boundary [H L ~> m2 or kg m-1]. + real :: flux_to_res ! Signed volume/mass flux directed toward the reservoir (positive = interior + ! to reservoir), equals dir * uhr or dir * vhr [H L2 ~> m3 or kg]. + real :: resrv_lfac_out ! Per-tracer multiplier on segment%Tr_InvLscale_out for the outward + ! direction [nondim]. + real :: resrv_lfac_in ! Per-tracer multiplier on segment%Tr_InvLscale_in for the inward + ! direction [nondim]. + real :: L_out, L_in ! Nondimensional exchange weight = flux * InvLscale * resrv_lfac / face_area + ! for the outflow (L_out >= 0) and inflow (L_in <= 0) directions [nondim]. + ! Active only in finite/infinite length-scale mode (mask_L = 1). + real :: a_out, a_in ! In instant-update (zero length scale) mode: +1 on outflow (a_out) or + ! -1 on inflow (a_in), selecting which boundary value is applied instantly + ! to the reservoir. Both are 0 in finite/infinite length-scale mode, and + ! a_out and a_in cannot be simultaneously non-zero [nondim]. + real :: mask_L_out, mask_L_in ! 1 in finite/infinite length-scale mode (activates L term); + ! 0 in instant-update mode [nondim]. mask_L = 1 - mask_a. + real :: mask_a_out, mask_a_in ! 1 in instant-update (zero length scale) mode (activates a term); + ! 0 in finite/infinite length-scale mode [nondim]. + real :: fac1 ! Implicit-update denominator = 1 + L_out - L_in [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, m, n, nz, ntr_id + integer :: is, ie, js, je, ii, ji + + if (.not. associated(OBC)) return + if (.not. OBC%OBC_pe) return + nz = GV%ke - ntr = Reg%ntr - if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + do n=1,OBC%number_of_segments segment => OBC%segment(n) - if (.not. associated(segment%tr_Reg)) cycle - b_in = 0.0 ; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0 - b_out = 0.0 ; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0 + if (.not.(segment%on_pe .and. associated(segment%tr_Reg))) cycle + ! dir switches the sign of the flow so that positive is into the reservoir + if ((segment%direction == OBC_DIRECTION_W) .or. (segment%direction == OBC_DIRECTION_S)) then + dir = -1 + else + dir = 1 + endif 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 tracer concentration implicitly using a Backward-Euler timestep - do m=1,segment%tr_Reg%ntseg - ntr_id = segment%tr_Reg%Tr(m)%ntr_index - fd_id = segment%tr_Reg%Tr(m)%fd_index - if (fd_id == -1) then - resrv_lfac_out = 1.0 - resrv_lfac_in = 1.0 - else - resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out - resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in - endif - I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale - if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz - ! Calculate weights. Both a and u_L are nondim. Adding them together has no meaning. - ! However, since they cannot be both non-zero, adding them works like a switch. - ! When InvLscale_out is 0 and outflow, only interior data is applied to reservoirs - ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs - a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k))) - a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k))) - u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & - ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) - u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & - ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) - fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in)) - segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1) * & - ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(I,j,k)+ & - ((u_L_out+a_out)*Reg%Tr(ntr_id)%t(I+ishift,j,k) - & - (u_L_in+a_in)*segment%tr_Reg%Tr(m)%t(I,j,k))) - if (allocated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) - enddo ; endif - enddo + I = segment%HI%IsdB ; ii = segment%HI%isd + js = segment%HI%jsd ; je = segment%HI%jed + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_Reg%Tr(m)%ntr_index + resrv_lfac_out = segment%tr_Reg%Tr(m)%resrv_lfac_out + resrv_lfac_in = segment%tr_Reg%Tr(m)%resrv_lfac_in + mask_a_in = max(0.0, -segment%tr_Reg%Tr(m)%I_Lscale_in) ; mask_L_in = 1.0 - mask_a_in + mask_a_out = max(0.0, -segment%tr_Reg%Tr(m)%I_Lscale_out) ; mask_L_out = 1.0 - mask_a_out + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + do k=1,nz ; do j=js,je + ! Calculate weights. Both a and 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 + flux_to_res = dir * uhr(I,j,k) + ! I_face_area would be more efficient but it changes answers. + face_area = (h(ii,j,k) + GV%H_subroundoff) * G%dyCu(I,j) + a_out = mask_a_out * max(0.0, sign(1.0, flux_to_res)) + a_in = mask_a_in * min(0.0, sign(1.0, flux_to_res)) + ! Below, segment%Tr_InvLscale_out * resrv_lfac_out can be replaced by segment%I_Lscale_out, + ! but it changes answers. + L_out = mask_L_out * G%mask2dT(ii,j) * max(0.0, & + flux_to_res * segment%Tr_InvLscale_out * resrv_lfac_out / face_area) + L_in = mask_L_in * G%mask2dT(ii,j) * min(0.0, & + flux_to_res * segment%Tr_InvLscale_in * resrv_lfac_in / face_area) + fac1 = 1.0 + (L_out - L_in) + segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0 / fac1) * & + ((1.0 - a_out + a_in) * segment%tr_Reg%Tr(m)%tres(I,j,k) + & + ((L_out + a_out) * Reg%Tr(ntr_id)%t(ii,j,k) - & + (L_in + a_in ) * segment%tr_Reg%Tr(m)%t(I,j,k))) + enddo ; enddo + if (allocated(OBC%tres_x)) then ; do k=1,nz ; do j=js,je + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) + enddo ; 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 - do m=1,segment%tr_Reg%ntseg - ntr_id = segment%tr_Reg%Tr(m)%ntr_index - fd_id = segment%tr_Reg%Tr(m)%fd_index - if (fd_id == -1) then - resrv_lfac_out = 1.0 - resrv_lfac_in = 1.0 - else - resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out - resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in - endif - I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale - if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz - a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k))) - a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k))) - v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & - ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & - ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in)) - segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1) * & - ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(i,J,k) + & - ((v_L_out+a_out)*Reg%Tr(ntr_id)%t(i,J+jshift,k) - & - (v_L_in+a_in)*segment%tr_Reg%Tr(m)%t(i,J,k))) - if (allocated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) - enddo ; endif - enddo + J = segment%HI%JsdB ; ji = segment%HI%jsd + is = segment%HI%isd ; ie = segment%HI%ied + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_Reg%Tr(m)%ntr_index + resrv_lfac_out = segment%tr_Reg%Tr(m)%resrv_lfac_out + resrv_lfac_in = segment%tr_Reg%Tr(m)%resrv_lfac_in + mask_a_in = max(0.0, -segment%tr_Reg%Tr(m)%I_Lscale_in) ; mask_L_in = 1.0 - mask_a_in + mask_a_out = max(0.0, -segment%tr_Reg%Tr(m)%I_Lscale_out) ; mask_L_out = 1.0 - mask_a_out + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + do k=1,nz ; do i=is,ie + flux_to_res = dir * vhr(i,J,k) + face_area = (h(i,ji,k) + GV%H_subroundoff) * G%dxCv(i,J) + a_out = mask_a_out * max(0.0, sign(1.0, flux_to_res)) + a_in = mask_a_in * min(0.0, sign(1.0, flux_to_res)) + L_out = mask_L_out * G%mask2dT(i,ji) * max(0.0, & + flux_to_res * segment%Tr_InvLscale_out * resrv_lfac_out / face_area) + L_in = mask_L_in * G%mask2dT(i,ji) * min(0.0, & + flux_to_res * segment%Tr_InvLscale_in * resrv_lfac_in / face_area) + fac1 = 1.0 + (L_out - L_in) + segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0 / fac1) * & + ((1.0 - a_out + a_in) * segment%tr_Reg%Tr(m)%tres(i,J,k) + & + ((L_out + a_out) * Reg%Tr(ntr_id)%t(i,ji,k) - & + (L_in + a_in ) * segment%tr_Reg%Tr(m)%t(i,J,k))) + enddo ; enddo + if (allocated(OBC%tres_y)) then ; do k=1,nz ; do i=is,ie + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; enddo ; endif enddo endif - enddo ; endif ; endif - + enddo end subroutine update_segment_tracer_reservoirs !> Update the OBC thickness reservoirs after the thicknesses have been updated. @@ -5953,7 +6291,7 @@ subroutine update_segment_thickness_reservoirs(G, GV, uhr, vhr, h, OBC) 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, m, n, nz, fd_id + 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] @@ -5970,8 +6308,8 @@ subroutine update_segment_thickness_reservoirs(G, GV, uhr, vhr, h, OBC) 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 + 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 @@ -6088,7 +6426,7 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) 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 (.not.(segment%on_pe .and. associated(segment%tr_Reg))) cycle if (segment%is_E_or_W) then I = segment%HI%IsdB @@ -6108,7 +6446,7 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif ! Vertically remap the reservoir tracer concentrations - do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + do m=1,segment%tr_Reg%ntseg I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (present(PCM_cell)) then @@ -6126,7 +6464,7 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) enddo ; endif - endif ; enddo + enddo ! Vertically remap the reservoir thicknesses? if (associated(segment%h_Reg)) then @@ -6197,7 +6535,7 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif ! Vertically remap the reservoir tracer concentrations - do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + do m=1,segment%tr_Reg%ntseg I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (present(PCM_cell)) then @@ -6215,7 +6553,7 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) enddo ; endif - endif ; enddo + enddo ! Vertically remap the reservoir thicknesses? if (associated(segment%h_Reg)) then @@ -6435,14 +6773,8 @@ 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 @@ -6488,7 +6820,6 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) ! These are set by initialize_segment_data OBC%brushcutter_mode = OBC_in%brushcutter_mode OBC%update_OBC = OBC_in%update_OBC - OBC%needs_IO_for_data = OBC_in%needs_IO_for_data OBC%any_needs_IO_for_data = OBC_in%any_needs_IO_for_data OBC%update_OBC_seg_data = OBC_in%update_OBC_seg_data @@ -6529,6 +6860,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%remappingScheme = OBC_in%remappingScheme OBC%exterior_OBC_bug = OBC_in%exterior_OBC_bug OBC%hor_index_bug = OBC_in%hor_index_bug + OBC%ignore_dt_obc_bgc = OBC_in%ignore_dt_obc_bgc + OBC%tracer_dz_bug = OBC_in%tracer_dz_bug OBC%n_tide_constituents = OBC_in%n_tide_constituents OBC%add_tide_constituents = OBC_in%add_tide_constituents @@ -6596,8 +6929,6 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) segment%open = segment_in%open segment%gradient = segment_in%gradient - call rotate_OBC_segment_values_needed(segment_in, segment, qturns) - ! 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 @@ -6641,7 +6972,7 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) endif ! Orientation is based on the index ordering, and setup_segment_indices - ! is based on the the original order in the intput files. + ! 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 global indexing offset. @@ -6726,53 +7057,6 @@ function rotate_OBC_segment_direction(direction, turns) result(rotated_dir) end function rotate_OBC_segment_direction -!> Copies which values are needed and field indices from one OBC segment type to another, -!! taking the difference in the number of turns into account. -subroutine rotate_OBC_segment_values_needed(segment_in, segment, turns) - type(OBC_segment_type), intent(in) :: segment_in !< The unrotated segment to use as a source - type(OBC_segment_type), intent(inout) :: segment !< The rotated segment to initialize - integer, intent(in) :: turns !< The number of quarter turns of the grid to apply - - integer :: qturns ! The number of quarter turns in the range of 0 to 3 - - qturns = modulo(turns, 4) - - if ((qturns == 0) .or. (qturns == 2)) then - segment%u_values_needed = segment_in%u_values_needed - segment%v_values_needed = segment_in%v_values_needed - segment%uamp_values_needed = segment_in%uamp_values_needed - segment%vamp_values_needed = segment_in%vamp_values_needed - segment%uphase_values_needed = segment_in%uphase_values_needed - segment%vphase_values_needed = segment_in%vphase_values_needed - segment%uamp_index = segment_in%uamp_index - segment%vamp_index = segment_in%vamp_index - segment%uphase_index = segment_in%uphase_index - segment%vphase_index = segment_in%vphase_index - else ! NOTE: [uv]_values_needed are swapped - segment%u_values_needed = segment_in%v_values_needed - segment%v_values_needed = segment_in%u_values_needed - segment%uamp_values_needed = segment_in%vamp_values_needed - segment%vamp_values_needed = segment_in%uamp_values_needed - segment%uphase_values_needed = segment_in%vphase_values_needed - segment%vphase_values_needed = segment_in%uphase_values_needed - segment%uamp_index = segment_in%vamp_index - segment%vamp_index = segment_in%uamp_index - segment%uphase_index = segment_in%vphase_index - segment%vphase_index = segment_in%uphase_index - endif - segment%z_values_needed = segment_in%z_values_needed - segment%g_values_needed = segment_in%g_values_needed - segment%t_values_needed = segment_in%t_values_needed - segment%s_values_needed = segment_in%s_values_needed - segment%zamp_values_needed = segment_in%zamp_values_needed - segment%zphase_values_needed = segment_in%zphase_values_needed - segment%zamp_index = segment_in%zamp_index - segment%zphase_index = segment_in%zphase_index - segment%values_needed = segment_in%values_needed - -end subroutine rotate_OBC_segment_values_needed - - !> 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 @@ -6875,16 +7159,7 @@ subroutine write_OBC_info(OBC, G, GV, US) if (OBC%user_BCs_set_globally) call MOM_mesg("user_BCs_set_globally", verb=1) if (OBC%update_OBC) call MOM_mesg("update_OBC", verb=1) if (OBC%update_OBC_seg_data) call MOM_mesg("update_OBC_seg_data", verb=1) - if (OBC%needs_IO_for_data) call MOM_mesg("needs_IO_for_data", verb=1) if (OBC%any_needs_IO_for_data) call MOM_mesg("any_needs_IO_for_data", verb=1) - if (OBC%zero_vorticity) call MOM_mesg("zero_vorticity", verb=1) - if (OBC%freeslip_vorticity) call MOM_mesg("freeslip_vorticity", verb=1) - if (OBC%computed_vorticity) call MOM_mesg("computed_vorticity", verb=1) - if (OBC%specified_vorticity) call MOM_mesg("specified_vorticity", verb=1) - if (OBC%zero_strain) call MOM_mesg("zero_strain", verb=1) - if (OBC%freeslip_strain) call MOM_mesg("freeslip_strain", verb=1) - if (OBC%computed_strain) call MOM_mesg("computed_strain", verb=1) - if (OBC%specified_strain) call MOM_mesg("specified_strain", verb=1) if (OBC%zero_biharmonic) call MOM_mesg("zero_biharmonic", verb=1) if (OBC%brushcutter_mode) call MOM_mesg("brushcutter_mode", verb=1) if (OBC%check_reconstruction) call MOM_mesg("check_reconstruction", verb=1) @@ -6954,37 +7229,14 @@ subroutine write_OBC_info(OBC, G, GV, US) if (segment%specified_grad) call MOM_mesg(" specified_grad", verb=1) if (segment%open) call MOM_mesg(" open", verb=1) if (segment%gradient) call MOM_mesg(" gradient", verb=1) - if (segment%values_needed) call MOM_mesg(" values_needed", verb=1) if (modulo(turns, 2) == 0) then if (segment%is_N_or_S) call MOM_mesg(" is_N_or_S", verb=1) if (segment%is_E_or_W) call MOM_mesg(" is_E_or_W", verb=1) - if (segment%u_values_needed) call MOM_mesg(" u_values_needed", verb=1) - if (segment%uamp_values_needed) call MOM_mesg(" uamp_values_needed", verb=1) - if (segment%uphase_values_needed) call MOM_mesg(" uphase_values_needed", verb=1) - if (segment%v_values_needed) call MOM_mesg(" v_values_needed", verb=1) - if (segment%vamp_values_needed) call MOM_mesg(" vamp_values_needed", verb=1) - if (segment%vphase_values_needed) call MOM_mesg(" vphase_values_needed", verb=1) else ! The x- and y-directions are swapped. if (segment%is_E_or_W) call MOM_mesg(" is_N_or_S", verb=1) if (segment%is_N_or_S) call MOM_mesg(" is_E_or_W", verb=1) - if (segment%v_values_needed) call MOM_mesg(" u_values_needed", verb=1) - if (segment%vamp_values_needed) call MOM_mesg(" uamp_values_needed", verb=1) - if (segment%vphase_values_needed) call MOM_mesg(" uphase_values_needed", verb=1) - if (segment%u_values_needed) call MOM_mesg(" v_values_needed", verb=1) - if (segment%uamp_values_needed) call MOM_mesg(" vamp_values_needed", verb=1) - if (segment%uphase_values_needed) call MOM_mesg(" vphase_values_needed", verb=1) endif - if (segment%t_values_needed) call MOM_mesg(" t_values_needed", verb=1) - if (segment%s_values_needed) call MOM_mesg(" s_values_needed", verb=1) - if (segment%z_values_needed) call MOM_mesg(" z_values_needed", verb=1) - if (segment%zamp_values_needed) call MOM_mesg(" zamp_values_needed", verb=1) - if (segment%zphase_values_needed) call MOM_mesg(" zphase_values_needed", verb=1) - if (segment%g_values_needed) call MOM_mesg(" g_values_needed", verb=1) -! if (segment%is_E_or_W_2) call MOM_mesg(" is_E_or_W_2", verb=1) - if (segment%temp_segment_data_exists) call MOM_mesg(" temp_segment_data_exists", verb=1) - if (segment%salt_segment_data_exists) call MOM_mesg(" salt_segment_data_exists", verb=1) - if (segment%thickness_segment_data_exists) call MOM_mesg(" thickness_segment_data_exists", & - verb=1) + ! if (segment%is_E_or_W_2) call MOM_mesg(" is_E_or_W_2", verb=1) write(mesg, '(" Tr_InvLscale_out ", ES16.6)') segment%Tr_InvLscale_out*US%m_to_L call MOM_mesg(mesg, verb=1) @@ -7034,7 +7286,6 @@ subroutine chksum_OBC_segment_data(segment, GV, US, nk, nseg_out) real :: norm ! A sign change used when rotating a normal component [nondim] real :: tang ! A sign change used when rotating a tangential component [nondim] character(len=8) :: sn, segno - character(len=1024) :: mesg integer :: dir ! This indicates the internal logical orientation of a segment dir = segment%direction @@ -7054,11 +7305,9 @@ subroutine chksum_OBC_segment_data(segment, GV, US, nk, nseg_out) norm = -1.0 ; tang = 1.0 endif - if (allocated(segment%Cg)) call write_2d_array_vals("Cg"//trim(sn), segment%Cg, dir, nk, unscale=US%L_T_to_m_s) if (allocated(segment%Htot)) call write_2d_array_vals("Htot"//trim(sn), segment%Htot, dir, nk, unscale=GV%H_to_mks) if (allocated(segment%dZtot)) call write_2d_array_vals("dZtot"//trim(sn), segment%dZtot, dir, nk, unscale=US%Z_to_m) if (allocated(segment%SSH)) call write_2d_array_vals("SSH"//trim(sn), segment%SSH, dir, nk, unscale=US%Z_to_m) - if (allocated(segment%h)) call write_3d_array_vals("h"//trim(sn), segment%h, dir, nk, unscale=GV%H_to_mks) if (allocated(segment%normal_vel)) & call write_3d_array_vals("normal_vel"//trim(sn), segment%normal_vel, dir, nk, unscale=norm*US%L_T_to_m_s) if (allocated(segment%normal_vel_bt)) & diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index 53f8ea406b..e82bfbd621 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -26,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 @@ -91,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 @@ -141,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), & @@ -218,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 @@ -309,8 +309,8 @@ 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 call find_eta(h, tv, G, GV, US, eta, halo_size=1) diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90 index b312cc3a39..8e6beec4fe 100644 --- a/src/core/MOM_stoch_eos.F90 +++ b/src/core/MOM_stoch_eos.F90 @@ -19,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 @@ -33,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 f227cfc5a5..78ef287dfc 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -58,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) @@ -147,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) @@ -219,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) @@ -309,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 e47242711a..1e197dfe2b 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -5,6 +5,10 @@ !> 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 @@ -35,6 +39,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, & @@ -51,6 +57,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 c43f71481e..1041999e72 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -91,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]. @@ -292,10 +292,23 @@ module MOM_variables Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [H T-1 ~> m s-1 or Pa s m-1]. ! The following elements are pointers so they can be used as targets for pointers in the restart registry. - real, pointer, dimension(:,:) :: MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. - real, pointer, dimension(:,:) :: Lam2 => NULL() !< (Langmuir Number)^-2 [nondim]. - real, pointer, dimension(:,:) :: h_ML => NULL() !< Instantaneous active mixing layer thickness [H ~> m or kg m-2]. - real, pointer, dimension(:,:) :: sfc_buoy_flx => NULL() !< Surface buoyancy flux (derived) [Z2 T-3 ~> m2 s-3]. + real, pointer, dimension(:,:) :: MLD => NULL() + !< Instantaneous active mixing layer depth as used by the mixed layer restratification + !! parameterization [Z ~> m]. + real, pointer, dimension(:,:) :: Lam2 => NULL() + !< (Langmuir Number)^-2 [nondim]. + real, pointer, dimension(:,:) :: h_ML => NULL() + !< Instantaneous active mixing layer thickness as used by the mixed layer restratification + !! parameterization [H ~> m or kg m-2] + real, pointer, dimension(:,:) :: MLD_param => NULL() + !< Instantaneous active mixed or mixing layer depth as used by the brine plume parameterization. + !! It could be coordinated with MLD above but we may want the ability to use different scales + !! in different parameterizations [Z ~> m]. + real, pointer, dimension(:,:) :: h_ML_param => NULL() + !< Instantaneous active mixed or mixing layer thickness as used by the brine plume + !! parameterization [H ~> m or kg m-2]. + real, pointer, dimension(:,:) :: sfc_buoy_flx => NULL() + !< Surface buoyancy flux (derived) [Z2 T-3 ~> m2 s-3]. real, pointer, dimension(:,:,:) :: Kd_shear => NULL() !< The shear-driven turbulent diapycnal diffusivity at the interfaces between layers !! in tracer columns [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -405,7 +418,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 diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index a4b3dbbffb..ef6d9d8eb0 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -76,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 @@ -133,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 b1db788b90..e8c116d99c 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -150,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 @@ -490,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 @@ -771,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 a8ded110f0..56efe2fd42 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -194,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 @@ -294,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) @@ -399,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 diff --git a/src/diagnostics/MOM_diagnose_KdWork.F90 b/src/diagnostics/MOM_diagnose_KdWork.F90 index 999002b5d1..b981da9af1 100644 --- a/src/diagnostics/MOM_diagnose_KdWork.F90 +++ b/src/diagnostics/MOM_diagnose_KdWork.F90 @@ -34,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] @@ -125,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 @@ -742,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 @@ -755,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 diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8bb85762bb..de44b07c49 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -22,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, find_col_mass +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 @@ -35,6 +36,7 @@ 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 @@ -58,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. @@ -99,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 @@ -116,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 @@ -210,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] @@ -219,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 @@ -313,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) @@ -336,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 @@ -353,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 @@ -363,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 @@ -411,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) @@ -451,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) @@ -487,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) @@ -527,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) @@ -892,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 @@ -904,11 +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]. - 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 @@ -952,6 +983,131 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) 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 + d_from_ssh(k) = d_from_ssh(k-1) + h(i,j,k) * GV%H_to_Z + enddo + else + ! 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 + 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 + 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_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 + endif + call post_data(CS%id_chcint, tmp, CS%diag) + endif end subroutine calculate_vertical_integrals @@ -1452,20 +1608,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 @@ -1475,8 +1631,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 @@ -1524,12 +1680,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 @@ -1550,7 +1706,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = tv%frazil(i,j) * I_time_int enddo ; enddo - call post_data(IDs%id_fraz, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_fraz, work_2d, diag) endif ! post time-averaged salt deficit @@ -1558,7 +1714,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = tv%salt_deficit(i,j) * I_time_int enddo ; enddo - call post_data(IDs%id_salt_deficit, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_salt_deficit, work_2d, diag) endif ! post temperature of P-E+R @@ -1566,7 +1722,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) enddo ; enddo - call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_Heat_PmE, work_2d, diag) endif ! post geothermal heating or internal heat source/sinks @@ -1574,50 +1730,50 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) enddo ; enddo - call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_intern_heat, work_2d, diag) endif if (tv%T_is_conT) then ! Internal T&S variables are conservative temperature & absolute salinity - if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) + if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag) ! Use TEOS-10 function calls convert T&S diagnostics from conservative temp ! to potential temperature. 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)) @@ -1788,6 +1944,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) @@ -1893,6 +2055,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, & @@ -2079,22 +2286,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) @@ -2326,6 +2517,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 1ff0b4bacc..45d2c76146 100644 --- a/src/diagnostics/MOM_harmonic_analysis.F90 +++ b/src/diagnostics/MOM_harmonic_analysis.F90 @@ -5,13 +5,13 @@ !> Inline harmonic analysis (conventional) module MOM_harmonic_analysis -use MOM_time_manager, only : time_type, real_to_time, time_type_to_real +use MOM_time_manager, only : time_type, real_to_time, time_to_real, time_minus_signed use MOM_time_manager, only : set_date, get_date, increment_date use MOM_time_manager, only : operator(+), operator(-), operator(<), operator(>), operator(>=) use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type use MOM_file_parser, only : param_file_type, get_param -use MOM_io, only : file_exists, open_ASCII_file, READONLY_FILE, close_file +use MOM_io, only : file_exists, 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 @@ -239,8 +239,8 @@ subroutine HA_init(Time, US, param_file, nc, CS) 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 @@ -337,7 +337,7 @@ subroutine HA_accum(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 !!! if (ha1%old_time < 0.0) then @@ -410,8 +410,9 @@ subroutine HA_accum(key, data, Time, G, CS) 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 + ! 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) diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 642f10f74e..77b7b863ce 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -54,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 012fcff931..10807a9aca 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -217,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 @@ -254,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 @@ -282,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_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 9f37965874..ad5fa84e76 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -15,7 +15,7 @@ module MOM_sum_output use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta -use MOM_io, only : create_MOM_file, reopen_MOM_file +use MOM_io, only : create_MOM_file, reopen_MOM_file, close_file use MOM_io, only : MOM_infra_file, MOM_netcdf_file, MOM_field use MOM_io, only : file_exists, slasher, vardesc, var_desc, MOM_write_field use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout @@ -137,7 +137,8 @@ module MOM_sum_output integer :: previous_calls = 0 !< The number of times write_energy has been called. integer :: prev_n = 0 !< The value of n from the last call. type(MOM_netcdf_file) :: fileenergy_nc !< The file handle for the netCDF version of the energy file. - integer :: fileenergy_ascii !< The unit number of the ascii version of the energy file. + integer :: fileenergy_ascii = -1 + !< The unit number of the ascii version of the energy file. type(MOM_field), dimension(NUM_FIELDS+MAX_FIELDS_) :: & fields !< fieldtype variables for the output fields. character(len=200) :: energyfile !< The name of the energy file with path. @@ -306,14 +307,25 @@ end subroutine MOM_sum_output_init !> MOM_sum_output_end deallocates memory used by the MOM_sum_output module. subroutine MOM_sum_output_end(CS) - type(Sum_output_CS), pointer :: CS !< The control structure returned by a - !! previous call to MOM_sum_output_init. + type(Sum_output_CS), pointer :: CS + !< Control structure returned by a previous call to MOM_sum_output_init. + + logical :: is_open + ! True if CS%fileenergy_ascii is open + if (associated(CS)) then if (CS%do_APE_calc) then deallocate(CS%DL%depth, CS%DL%area, CS%DL%vol_below) deallocate(CS%lH) endif + if (is_root_PE()) then + is_open = .false. + if (CS%fileenergy_ascii /= -1) & + inquire(unit=CS%fileenergy_ascii, opened=is_open) + if (is_open) call close_file(CS%fileenergy_ascii) + endif + deallocate(CS) endif end subroutine MOM_sum_output_end @@ -411,9 +423,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. @@ -477,6 +489,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci Tr_units ! The units for each of the tracers integer :: nTr_stocks ! The total number of tracers in all registered tracer packages integer :: iyear, imonth, iday, ihour, iminute, isecond, itick ! For call to get_date() + logical :: is_open ! True if the CS%fileenergy_ascii has been opened ! A description for output of each of the fields. type(vardesc) :: vars(NUM_FIELDS+MAX_FIELDS_) @@ -616,7 +629,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci ! Reopen or create a text output file, with an explanatory header line. if (is_root_pe()) then if (day > CS%Start_time) then - call open_ASCII_file(CS%fileenergy_ascii, trim(CS%energyfile), action=APPEND_FILE) + is_open = .false. + if (CS%fileenergy_ascii /= -1) & + inquire(unit=CS%fileenergy_ascii, opened=is_open) + if (.not. is_open) & + call open_ASCII_file(CS%fileenergy_ascii, trim(CS%energyfile), action=APPEND_FILE) else call open_ASCII_file(CS%fileenergy_ascii, trim(CS%energyfile), action=WRITEONLY_FILE) if (abs(CS%timeunit - 86400.0) < 1.0) then diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index f6a884004f..9ce2af08f4 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -137,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]. @@ -552,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 @@ -854,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]. @@ -881,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] @@ -1374,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 @@ -1404,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) @@ -1431,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 e716d9221f..f576118fb6 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -52,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 @@ -418,7 +420,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, & @@ -853,8 +854,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 @@ -1958,7 +1957,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] @@ -1999,7 +1997,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] @@ -2188,7 +2185,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. @@ -2236,7 +2232,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_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 89dbe9630b..3314b6f460 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -721,7 +721,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] diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index ec910e8233..e80af3fdf9 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -726,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 5a2898ae49..af7f1dc936 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -728,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/framework/MOM_ANN.F90 b/src/framework/MOM_ANN.F90 index e14ca23747..3086f4e92e 100644 --- a/src/framework/MOM_ANN.F90 +++ b/src/framework/MOM_ANN.F90 @@ -30,7 +30,7 @@ module MOM_ANN !! i.e. stores the matrix A and bias b !! for matrix-vector multiplication !! y = A*x + b. -type, private :: layer_type; private +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 @@ -723,7 +723,7 @@ end function ANN_unit_tests !! 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 +!! \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. !! diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90 index 30aeadcdf1..5b59220ba1 100644 --- a/src/framework/MOM_array_transform.F90 +++ b/src/framework/MOM_array_transform.F90 @@ -14,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. @@ -62,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 @@ -71,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. @@ -358,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 4683dabfac..123eeeb675 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -2194,7 +2194,7 @@ end subroutine chksum_v_3d !> chksum1d does a checksum of a 1-dimensional array. subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs, logunit) - real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1) [abitrary]. + 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) @@ -2203,8 +2203,8 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs, logunit) integer, optional, intent(in) :: logunit !< IO unit for checksum logging integer :: is, ie, i, bc, sum1, sum_bc, ioUnit - real :: sum ! The global sum of the array [arbitrary] - real, allocatable :: sum_here(:) ! The sum on each PE [arbitrary] + 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 @@ -2255,12 +2255,12 @@ end subroutine chksum1d !> chksum2d does a checksum of all data in a 2-d array. 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, iounit - real :: sum ! The global sum of the array [arbitrary] + real :: sum ! The global sum of the array [A] iounit = error_unit ; if (present(logunit)) iounit = logunit @@ -2286,12 +2286,12 @@ end subroutine chksum2d !> chksum3d does a checksum of all data in a 2-d array. 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 [arbitrary] + real :: sum ! The global sum of the array [A] iounit = error_unit ; if (present(logunit)) iounit = logunit @@ -2317,7 +2317,7 @@ 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. & @@ -2333,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 @@ -2356,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 @@ -2373,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 @@ -2456,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 @@ -2496,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 @@ -2536,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 @@ -2643,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. @@ -2678,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 97b93d8bfe..649dd79025 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -25,34 +25,53 @@ 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. +integer, parameter :: accum_width = digits(1_int64) + !< Accumulator width; total available bits for summation (excluding sign bit) +integer, parameter :: prec_width = 46 + !< Precision width; total bits for computed results +integer, parameter :: guard_width = accum_width - prec_width + !< Number of guard bits reserved for carry overflow + +! A sum of N points does N - 1 additions, which at most adds N - 1 carry bits. +! For G guard bits, the maximum value is 2**G - 1. A summation of N values +! therefore requires that N - 1 <= 2**G - 1, or simply N <= 2**G. + +integer, parameter :: max_summands = 2**guard_width + !< Maximum number of summable points that can guarantee no carry overflow. + !! Assumes that guard_bits is less than number of bits in a default integer. + +integer(kind=int64), parameter :: prec = (2_int64)**prec_width + !< EPF upper bound (exclusive). For each EPF bin e(i), 0 <= e(i) < prec. + +real, parameter :: r_prec = 2.**prec_width + !< Real-value of prec [nondim] +real, parameter :: I_prec = 2.**(-prec_width) + !< Inverse real-value of prec [nondim] + +integer, parameter :: efp_digits = 6 + !< The number of base `prec` digits used to represent an EFP value. +real, parameter, dimension(efp_digits) :: & + pr = [r_prec**2, r_prec, 1., r_prec**(-1), r_prec**(-2), r_prec**(-3)] + !< An array of the real precision of each of the integers in arbitrary + !! units [a] +real, parameter, dimension(efp_digits) :: & + I_pr = [r_prec**(-2), r_prec**(-1), 1., r_prec, r_prec**2, r_prec**3] + !< An array of the inverse of the real precision of each of the integers in + !! arbitrary units [a-1] +real, parameter :: max_efp_float = pr(1) * real(huge(1_int64)) + !< The largest float with an EFP representation in arbitrary units [a]. + !! NOTE: Only the first bin can exceed precision, but is bounded by the + !! largest signed integer. + +logical :: overflow_error = .false. + !< This becomes true if an overflow is encountered. +logical :: NaN_error = .false. + !< This becomes true if a NaN is encountered. +logical :: debug = .false. + !< Making this true enables debugging output. -integer(kind=int64), parameter :: prec = (2_int64)**46 !< The precision of each integer. -real, parameter :: r_prec=2.0**46 !< A real version of prec [nondim]. -real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec [nondim]. -integer, parameter :: max_count_prec=2**(63-46)-1 - !< The number of values that can be added together - !! with the current value of prec before there will - !! be roundoff problems. - -integer, parameter :: ni=6 !< The number of long integers to use to represent - !< a real number. -real, parameter, dimension(ni) :: & - pr = (/ r_prec**2, r_prec, 1.0, 1.0/r_prec, 1.0/r_prec**2, 1.0/r_prec**3 /) - !< An array of the real precision of each of the integers in arbitrary units [a] -real, parameter, dimension(ni) :: & - I_pr = (/ 1.0/r_prec**2, 1.0/r_prec, 1.0, r_prec, r_prec**2, r_prec**3 /) - !< An array of the inverse of the real precision of each of the integers in arbitrary units [a-1] -real, parameter :: max_efp_float = pr(1) * (2.**63 - 1.) - !< The largest float with an EFP representation in arbitrary units [a]. - !! NOTE: Only the first bin can exceed precision, - !! but is bounded by the largest signed integer. - -logical :: overflow_error = .false. !< This becomes true if an overflow is encountered. -logical :: NaN_error = .false. !< This becomes true if a NaN is encountered. -logical :: debug = .false. !< Making this true enables debugging output. +! This module provides interfaces to the non-domain-oriented communication subroutines. !> Find an accurate and order-invariant sum of a distributed 2d or 3d field, in some cases after !! undoing the scaling of the input array and restoring that scaling in the returned value @@ -78,7 +97,7 @@ module MOM_coms !! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. !! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. type, public :: EFP_type ; private - integer(kind=int64), dimension(ni) :: v !< The value in this type + integer(kind=int64), dimension(efp_digits) :: v !< The value in this type end type EFP_type !> Add two extended-fixed-point numbers @@ -123,7 +142,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64), dimension(efp_digits) :: ints_sum integer(kind=int64) :: ival, prec_error real :: rs ! The remaining value to add, in arbitrary units [a] real :: max_mag_term ! A running maximum magnitude of the values in arbitrary units [a] @@ -132,11 +151,11 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, character(len=256) :: mesg integer :: i, j, n, is, ie, js, je, sgn - if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + if (num_PEs() > max_summands) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() + prec_error = huge(1_int64) / num_PEs() is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) if (present(isr)) then @@ -162,37 +181,16 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, descale = 1.0 ; if (do_unscale) descale = unscale overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 + ints_sum(:) = 0 if (over_check) then - if ((je+1-js)*(ie+1-is) < max_count_prec) then - ! This is the most common case, so handle the do_unscale case separately for efficiency. - if (do_unscale) then - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, unscale*array(i,j), max_mag_term) - enddo ; enddo - else - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term) - enddo ; enddo - endif - call carry_overflow(ints_sum, prec_error) - elseif ((ie+1-is) < max_count_prec) then - do j=js,je - do i=is,ie - call increment_ints_faster(ints_sum, descale*array(i,j), max_mag_term) - enddo - call carry_overflow(ints_sum, prec_error) - enddo - else - do j=js,je ; do i=is,ie - call increment_ints(ints_sum, real_to_ints(descale*array(i,j), prec_error), prec_error) - enddo ; enddo - endif + call increment_block_ints(array, is, ie, js, je, descale, ints_sum, & + max_mag_term, prec_error) else do j=js,je ; do i=is,ie sgn = 1 ; if (array(i,j)<0.0) sgn = -1 rs = abs(descale*array(i,j)) - do n=1,ni + do n=1,efp_digits ival = int(rs*I_pr(n), kind=int64) rs = rs - ival*pr(n) ints_sum(n) = ints_sum(n) + sgn*ival @@ -207,7 +205,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, err = err+2 if (NaN_error) & err = err+4 - if (err > 0) then ; do n=1,ni ; ints_sum(n) = 0 ; enddo ; endif + if (err > 0) then ; do n=1,efp_digits ; ints_sum(n) = 0 ; enddo ; endif else if (NaN_error) then call MOM_error(FATAL, "NaN in input field of reproducing_EFP_sum(_2d).") @@ -221,7 +219,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, endif endif - if (do_sum_across_PEs) call sum_across_PEs(ints_sum, ni) + if (do_sum_across_PEs) call sum_across_PEs(ints_sum, efp_digits) call regularize_ints(ints_sum) @@ -264,7 +262,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & !! arbitrary units as array [a] or [A ~> a] ! Local variables - integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64), dimension(efp_digits) :: ints_sum integer(kind=int64) :: prec_error real :: rsum(1) ! The running sum, in arbitrary units [a] real :: descale ! A local copy of unscale if it is present [a A-1 ~> 1] or 1 @@ -274,11 +272,11 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & type(EFP_type) :: EFP_val ! An extended fixed point version of the sum integer :: i, j, is, ie, js, je - if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + if (num_PEs() > max_summands) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() + prec_error = huge(1_int64) / num_PEs() is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) if (present(isr)) then @@ -338,7 +336,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & endif if (debug) then - write(mesg,'("2d RS: ", ES24.16, 6 Z17.16)') sum*descale, ints_sum(1:ni) + write(mesg,'("2d RS: ", ES24.16, 6 Z17.16)') sum*descale, ints_sum(1:efp_digits) call MOM_mesg(mesg, 3) endif @@ -361,7 +359,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 @@ -380,18 +378,18 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su real :: max_mag_term ! A running maximum magnitude of the val's in arbitrary units [a] real :: descale ! A local copy of unscale if it is present [a A-1 ~> 1] or 1 real :: I_unscale ! The Adcroft reciprocal of unscale [A a-1 ~> 1] - integer(kind=int64), dimension(ni) :: ints_sum - integer(kind=int64), dimension(ni,size(array,3)) :: ints_sums + integer(kind=int64), dimension(efp_digits) :: ints_sum + integer(kind=int64), dimension(efp_digits,size(array,3)) :: ints_sums integer(kind=int64) :: prec_error character(len=256) :: mesg logical :: do_sum_across_PEs, do_unscale integer :: i, j, k, is, ie, js, je, ke, isz, jsz, n - if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + if (num_PEs() > max_summands) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() + prec_error = huge(1_int64) / num_PEs() max_mag_term = 0.0 is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) ; ke = size(array,3) @@ -411,7 +409,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) @@ -424,40 +422,21 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su if (present(EFP_lay_sums)) then ; if (size(EFP_lay_sums) < ke) then call MOM_error(FATAL, "Sums is smaller than the vertical extent of array in reproducing_sum(_3d).") endif ; endif - ints_sums(:,:) = 0 + overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 - if (jsz*isz < max_count_prec) then - do k=1,ke - if (do_unscale) then - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sums(:,k), unscale*array(i,j,k), max_mag_term) - enddo ; enddo - else - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) - enddo ; enddo - endif - call carry_overflow(ints_sums(:,k), prec_error) - enddo - elseif (isz < max_count_prec) then - do k=1,ke ; do j=js,je - do i=is,ie - call increment_ints_faster(ints_sums(:,k), descale*array(i,j,k), max_mag_term) - enddo - call carry_overflow(ints_sums(:,k), prec_error) - enddo ; enddo - else - do k=1,ke ; do j=js,je ; do i=is,ie - call increment_ints(ints_sums(:,k), & - real_to_ints(descale*array(i,j,k), prec_error), prec_error) - enddo ; enddo ; enddo - endif + + ints_sums(:,:) = 0 + do k=1,ke + call increment_block_ints(array(:,:,k), is, ie, js, je, descale, & + ints_sums(:,k), max_mag_term, prec_error) + enddo + if (present(err)) then err = 0 if (abs(max_mag_term) >= prec_error*pr(1)) err = err+1 if (overflow_error) err = err+2 if (NaN_error) err = err+2 - if (err > 0) then ; do k=1,ke ; do n=1,ni ; ints_sums(n,k) = 0 ; enddo ; enddo ; endif + if (err > 0) then ; do k=1,ke ; do n=1,efp_digits ; ints_sums(n,k) = 0 ; enddo ; enddo ; endif else if (NaN_error) call MOM_error(FATAL, "NaN in input field of reproducing_sum(_3d).") if (abs(max_mag_term) >= prec_error*pr(1)) then @@ -467,7 +446,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su if (overflow_error) call MOM_error(FATAL, "Overflow in reproducing_sum(_3d).") endif - if (do_sum_across_PEs) call sum_across_PEs(ints_sums(:,1:ke), ni*ke) + if (do_sum_across_PEs) call sum_across_PEs(ints_sums(:,1:ke), efp_digits*ke) sum = 0.0 do k=1,ke @@ -486,46 +465,26 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su endif if (debug) then - do n=1,ni ; ints_sum(n) = 0 ; enddo - do k=1,ke ; do n=1,ni ; ints_sum(n) = ints_sum(n) + ints_sums(n,k) ; enddo ; enddo - write(mesg,'("3D RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:ni) + do n=1,efp_digits ; ints_sum(n) = 0 ; enddo + do k=1,ke ; do n=1,efp_digits ; ints_sum(n) = ints_sum(n) + ints_sums(n,k) ; enddo ; enddo + write(mesg,'("3D RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:efp_digits) call MOM_mesg(mesg, 3) endif else - ints_sum(:) = 0 overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 - if (jsz*isz < max_count_prec) then - do k=1,ke - if (do_unscale) then - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, unscale*array(i,j,k), max_mag_term) - enddo ; enddo - else - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) - enddo ; enddo - endif - call carry_overflow(ints_sum, prec_error) - enddo - elseif (isz < max_count_prec) then - do k=1,ke ; do j=js,je - do i=is,ie - call increment_ints_faster(ints_sum, descale*array(i,j,k), max_mag_term) - enddo - call carry_overflow(ints_sum, prec_error) - enddo ; enddo - else - do k=1,ke ; do j=js,je ; do i=is,ie - call increment_ints(ints_sum, real_to_ints(descale*array(i,j,k), prec_error), & - prec_error) - enddo ; enddo ; enddo - endif + + ints_sum(:) = 0 + do k=1,ke + call increment_block_ints(array(:,:,k), is, ie, js, je, descale, & + ints_sum, max_mag_term, prec_error) + enddo + if (present(err)) then err = 0 if (abs(max_mag_term) >= prec_error*pr(1)) err = err+1 if (overflow_error) err = err+2 if (NaN_error) err = err+2 - if (err > 0) then ; do n=1,ni ; ints_sum(n) = 0 ; enddo ; endif + if (err > 0) then ; do n=1,efp_digits ; ints_sum(n) = 0 ; enddo ; endif else if (NaN_error) call MOM_error(FATAL, "NaN in input field of reproducing_sum(_3d).") if (abs(max_mag_term) >= prec_error*pr(1)) then @@ -535,7 +494,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su if (overflow_error) call MOM_error(FATAL, "Overflow in reproducing_sum(_3d).") endif - if (do_sum_across_PEs) call sum_across_PEs(ints_sum, ni) + if (do_sum_across_PEs) call sum_across_PEs(ints_sum, efp_digits) call regularize_ints(ints_sum) sum = ints_to_real(ints_sum) @@ -543,7 +502,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su if (present(EFP_sum)) EFP_sum%v(:) = ints_sum(:) if (debug) then - write(mesg,'("3d RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:ni) + write(mesg,'("3d RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:efp_digits) call MOM_mesg(mesg, 3) endif endif @@ -568,7 +527,7 @@ function real_to_ints(r, prec_error, overflow) result(ints) !! precision parameter, and is used to detect overflows. logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being !! done on a value that is too large to be represented - integer(kind=int64), dimension(ni) :: ints + integer(kind=int64), dimension(efp_digits) :: ints ! This subroutine converts a real number to an equivalent representation ! using several long integers. @@ -594,7 +553,7 @@ function real_to_ints(r, prec_error, overflow) result(ints) call MOM_error(FATAL,"Overflow in real_to_ints conversion of "//trim(mesg)) endif - do i=1,ni + do i=1,efp_digits ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) ints(i) = sgn*ival @@ -605,21 +564,21 @@ end function real_to_ints !> Convert the array of integers that constitute an extended-fixed-point !! representation into a real number function ints_to_real(ints) result(r) - integer(kind=int64), dimension(ni), intent(in) :: ints !< The array of EFP integers + integer(kind=int64), dimension(efp_digits), intent(in) :: ints !< The array of EFP integers real :: r ! The real number that is extracted in arbitrary units [a] ! This subroutine reverses the conversion in real_to_ints. integer :: i r = 0.0 - do i=1,ni ; r = r + pr(i)*ints(i) ; enddo + do i=1,efp_digits ; r = r + pr(i)*ints(i) ; enddo end function ints_to_real !> Increment an array of integers that constitutes an extended-fixed-point !! representation with a another EFP number subroutine increment_ints(int_sum, int2, prec_error) - integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - integer(kind=int64), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=int64), dimension(efp_digits), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=int64), dimension(efp_digits), intent(in) :: int2 !< The array of EFP integers being added integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time @@ -629,7 +588,7 @@ subroutine increment_ints(int_sum, int2, prec_error) ! representation in real_to_ints. integer :: i - do i=ni,2,-1 + do i=efp_digits,2,-1 int_sum(i) = int_sum(i) + int2(i) ! Carry the local overflow. if (int_sum(i) > prec) then @@ -649,43 +608,213 @@ subroutine increment_ints(int_sum, int2, prec_error) end subroutine increment_ints -!> Increment an EFP number with a real number without doing any carrying of -!! of overflows and using only minimal error checking. -subroutine increment_ints_faster(int_sum, r, max_mag_term) - integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - real, intent(in) :: r !< The real number being added in arbitrary units [a] - real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's - !! in arbitrary units [a] - ! This subroutine increments a number with another, both using the integer - ! representation in real_to_ints, but without doing any carrying of overflow. - ! The entire operation is embedded in a single call for greater speed. - real :: rs ! The remaining value to add, in arbitrary units [a] +!> Sum the elements of an array in EFP form and append the result to an +!! existing EFP array. +subroutine increment_block_ints(array, is, ie, js, je, descale, ints_sum, & + max_mag_term, prec_error) + real, intent(in) :: array(:,:) + !< The field being added, in arbitrary units [A ~> a] + integer, intent(in) :: is + !< Start i-index of the summed domain + integer, intent(in) :: ie + !< End i-index of the summed domain + integer, intent(in) :: js + !< Start j-index of the summed domain + integer, intent(in) :: je + !< End j-index of the summed domain + real, intent(in) :: descale + !< Factor to descale array to physical value [a A-1 ~> 1] + integer(kind=int64), intent(inout) :: ints_sum(efp_digits) + !< The array of EFP integers being incremented + real, intent(inout) :: max_mag_term + !< A running maximum magnitude of the r's, in arbitrary units [a] + integer(kind=int64), intent(in) :: prec_error + !< The maximum resolvable value for a given number of PEs + + integer :: i, j, ib, jb, ibs, ibe, jbs, jbe + ! Loop indices + integer :: b + ! Block counter + integer :: ni, nj + ! Array summation domain size along each axis + integer :: isize_max + ! Largest block size in i. Typically equal to ni + integer :: jsize + ! Number of j-rows per block. + integer :: nblocks, niblocks, njblocks + ! Number of total blocks, and number of blocks in i and j + integer(kind=int64) :: e(efp_digits) + ! The EPF representation of each array element + integer(kind=int64) :: block_sum(efp_digits), array_sum(efp_digits) + ! The cumulant per-block and total array EFP sums + real :: r, rmag + ! Local array element value and its magnitude [a] + real :: max_pos, max_neg, block_max_pos, block_max_neg + ! Largest positive and negative values (whole array and per-block) used to + ! find the largest maximum magnitude of array in a thread-safe manner [a] + integer :: inan, iovf, lnan, lovf + ! Thread-safe tracking of NaN and overflow state + integer :: max_sum_count + ! The total number of local sum operations that ensures no carry overflow + + max_pos = max(0., max_mag_term) + max_neg = max(0., -max_mag_term) + inan = 0 ; iovf = 0 + + ! Reduce the maximum number of summations to account for the cumulant + ! summations of array_sum and ints_sum. + max_sum_count = max_summands - 2 + + ! Get the compute domain size + ni = ie - is + 1 + nj = je - js + 1 + + ! Partition in i so that the widest i-slice fits within max_sum_count. + niblocks = (ni + max_sum_count - 1) / max_sum_count + ! = ⌈ni / max_sum_count⌉ + + ! NOTE: niblocks is typically one, since default max_sum_count is ~130k. + + ! For a balanced i-partition, the number of i-points per block is either + ! ⌊ni / niblocks⌋ or ⌈ni / niblocks⌉. Use the upper bound to find jsize. + + isize_max = (ni + niblocks - 1) / niblocks + ! = ⌈ni / niblocks⌉ + + ! Set jsize so that the widest i-slice times the number of j-rows does not + ! exceed max_sum_count. + jsize = max_sum_count / isize_max + ! = ⌊max_sum_count / isize_max⌋ + + ! Choose enough j-blocks so that no j-block has more than jsize rows. + njblocks = (nj + jsize - 1) / jsize + ! = ⌈nj / jsize⌉ + + nblocks = niblocks * njblocks + + ! Abort if the number of blocks also exceeds the carry-bit summation limit. + ! For default settings, this would be over 17 billion points per PE. + if (nblocks > max_sum_count) call MOM_error(FATAL, & + "reproducing sum: Number of blocks exceeds summmation carry limit.") + + array_sum(:) = 0 + + do jb=1,njblocks ; do ib=1,niblocks + ! Use evenly distributed blocks, either ⌊n / nblocks⌋ or ⌈n / nblocks⌉. + jbs = js + ((jb - 1) * nj) / njblocks + jbe = js + (jb * nj) / njblocks - 1 + + ibs = is + ((ib - 1) * ni) / niblocks + ibe = is + (ib * ni) / niblocks - 1 + + block_sum(:) = 0 + block_max_pos = 0. + block_max_neg = 0. + + ! Compute the sum of each block + do j=jbs,jbe ; do i=ibs,ibe + + ! Convert array(i,j) to EFP form + r = descale * array(i,j) + call efp_decompose(r, e, rmag, lnan, lovf) + + ! Verify that the conversion was completed + inan = max(inan, lnan) + iovf = max(iovf, lovf) + + if (r >= 0.) then + if (rmag > block_max_pos) block_max_pos = rmag + else + if (rmag > block_max_neg) block_max_neg = rmag + endif + + ! Add the EFP result (including potential carry bits) + block_sum(:) = block_sum(:) + e(:) + enddo ; enddo + + array_sum(:) = array_sum(:) + block_sum(:) + + ! Redistribute carry bits across bins + ! For the final pass (or single pass) this is handled by ints_sum. + b = (jb - 1) * niblocks + ib + if (b < nblocks) call carry_overflow(array_sum, prec_error) + + ! Update maximum magnitudes + max_pos = max(max_pos, block_max_pos) + max_neg = max(max_neg, block_max_neg) + enddo ; enddo + + ! Finally, apply the cumulant result + ints_sum(:) = ints_sum(:) + array_sum(:) + + ! Redistribute carry bits to normalize the final result. + call carry_overflow(ints_sum, prec_error) + + ! Extract the maximum value while preserving sign (NOTE: ties to positive) + if (max_pos >= max_neg) then + max_mag_term = max_pos + else + max_mag_term = -max_neg + endif + + ! Transfer error/warning signals to module flags + if (inan /= 0) NaN_error = .true. + if (iovf /= 0) overflow_error = .true. +end subroutine increment_block_ints + + +!> Decompose one real into its 6 signed EFP bin contributions. NaNs and +!! overflows are reported by flags, rather than the module-level error +!! logicals, so that the routine is free of side effects. +pure subroutine efp_decompose(r, e, rmag, is_nan, is_ovf) + real, intent(in) :: r + !< The real number being decomposed [a] + integer(kind=int64), intent(out) :: e(efp_digits) + !< Signed contribution to EFP bins + real, intent(out) :: rmag + !< Equals abs(r), or 0 if r is NaN/Inf [a] + integer, intent(out) :: is_nan + !< Equals 1 if r is a NaN or Inf, else 0 + integer, intent(out) :: is_ovf + !< Equals 1 if abs(r) has no EFP representation, else 0 + + real :: rs + ! The remaining value to add, in arbitrary units [a] integer(kind=int64) :: ival - integer :: sgn, i + integer :: sgn + integer :: n - if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif - sgn = 1 ; if (r<0.0) sgn = -1 - rs = abs(r) - if (rs > abs(max_mag_term)) max_mag_term = r + e(:) = 0 + rmag = 0.0 ; is_nan = 0 ; is_ovf = 0 + + if ((r >= 1e30) .eqv. (r < 1e30)) then + is_nan = 1 + return + endif + + sgn = 1 + if (r < 0.0) sgn = -1 + + rs = abs(r) ; rmag = rs ! Abort if the number has no EFP representation if (rs > max_efp_float) then - overflow_error = .true. + is_ovf = 1 return endif - do i=1,ni - ival = int(rs*I_pr(i), kind=int64) - rs = rs - ival*pr(i) - int_sum(i) = int_sum(i) + sgn*ival + do n=1,efp_digits + ival = int(rs * I_pr(n), kind=int64) + rs = rs - ival * pr(n) + e(n) = sgn * ival enddo +end subroutine efp_decompose -end subroutine increment_ints_faster !> This subroutine handles carrying of the overflow. subroutine carry_overflow(int_sum, prec_error) - integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + integer(kind=int64), dimension(efp_digits), intent(inout) :: int_sum !< The array of EFP integers being !! modified by carries, but without changing value. integer(kind=int64), intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global @@ -695,7 +824,7 @@ subroutine carry_overflow(int_sum, prec_error) ! This subroutine handles carrying of the overflow. integer :: i, num_carry - do i=ni,2,-1 ; if (abs(int_sum(i)) >= prec) then + do i=efp_digits,2,-1 ; if (abs(int_sum(i)) >= prec) then num_carry = int(int_sum(i) * I_prec) int_sum(i) = int_sum(i) - num_carry*prec int_sum(i-1) = int_sum(i-1) + num_carry @@ -709,7 +838,7 @@ end subroutine carry_overflow !> This subroutine carries the overflow, and then makes sure that !! all integers are of the same sign as the overall value. subroutine regularize_ints(int_sum) - integer(kind=int64), dimension(ni), & + integer(kind=int64), dimension(efp_digits), & intent(inout) :: int_sum !< The array of integers being modified to take a !! regular form with all integers of the same sign, !! but without changing value. @@ -719,7 +848,7 @@ subroutine regularize_ints(int_sum) logical :: positive integer :: i, num_carry - do i=ni,2,-1 ; if (abs(int_sum(i)) >= prec) then + do i=efp_digits,2,-1 ; if (abs(int_sum(i)) >= prec) then num_carry = int(int_sum(i) * I_prec) int_sum(i) = int_sum(i) - num_carry*prec int_sum(i-1) = int_sum(i-1) + num_carry @@ -727,7 +856,7 @@ subroutine regularize_ints(int_sum) ! Determine the sign of the final number. positive = .true. - do i=1,ni + do i=1,efp_digits if (abs(int_sum(i)) > 0) then if (int_sum(i) < 0) positive = .false. exit @@ -735,12 +864,12 @@ subroutine regularize_ints(int_sum) enddo if (positive) then - do i=ni,2,-1 ; if (int_sum(i) < 0) then + do i=efp_digits,2,-1 ; if (int_sum(i) < 0) then int_sum(i) = int_sum(i) + prec int_sum(i-1) = int_sum(i-1) - 1 endif ; enddo else - do i=ni,2,-1 ; if (int_sum(i) > 0) then + do i=efp_digits,2,-1 ; if (int_sum(i) > 0) then int_sum(i) = int_sum(i) - prec int_sum(i-1) = int_sum(i-1) + 1 endif ; enddo @@ -778,7 +907,7 @@ function EFP_minus(EFP1, EFP2) !! subtracted from the first extended fixed point number integer :: i - do i=1,ni ; EFP_minus%v(i) = -1*EFP2%v(i) ; enddo + do i=1,efp_digits ; EFP_minus%v(i) = -1*EFP2%v(i) ; enddo call increment_ints(EFP_minus%v(:), EFP1%v(:)) end function EFP_minus @@ -792,13 +921,13 @@ subroutine EFP_assign(EFP1, EFP2) ! variable on the RHS (EFP2) to the components of the variable on the LHS ! (EFP1). - do i=1,ni ; EFP1%v(i) = EFP2%v(i) ; enddo + do i=1,efp_digits ; EFP1%v(i) = EFP2%v(i) ; enddo 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) @@ -855,29 +984,30 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=int64), dimension(ni,nval) :: ints + integer(kind=int64), dimension(efp_digits,nval) :: ints integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: i, n - if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + if (num_PEs() > max_summands) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() + prec_error = huge(1_int64) / num_PEs() + ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. - do i=1,nval ; do n=1,ni ; ints(n,i) = EFPs(i)%v(n) ; enddo ; enddo + do i=1,nval ; do n=1,efp_digits ; ints(n,i) = EFPs(i)%v(n) ; enddo ; enddo - call sum_across_PEs(ints(:,:), ni*nval) + call sum_across_PEs(ints(:,:), efp_digits*nval) if (present(errors)) errors(:) = .false. do i=1,nval overflow_error = .false. call carry_overflow(ints(:,i), prec_error) - do n=1,ni ; EFPs(i)%v(n) = ints(n,i) ; enddo + do n=1,efp_digits ; 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 ",i0," val was ",ES12.6, ", prec_error = ",ES12.6)') & @@ -902,29 +1032,30 @@ subroutine EFP_val_sum_across_PEs(EFP, error) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=int64), dimension(ni) :: ints + integer(kind=int64), dimension(efp_digits) :: ints integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: n - if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + if (num_PEs() > max_summands) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() + prec_error = huge(1_int64) / num_PEs() + ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. - do n=1,ni ; ints(n) = EFP%v(n) ; enddo + do n=1,efp_digits ; ints(n) = EFP%v(n) ; enddo - call sum_across_PEs(ints(:), ni) + call sum_across_PEs(ints(:), efp_digits) if (present(error)) error = .false. overflow_error = .false. call carry_overflow(ints(:), prec_error) - do n=1,ni ; EFP%v(n) = ints(n) ; enddo + do n=1,efp_digits ; EFP%v(n) = ints(n) ; enddo if (present(error)) error = overflow_error if (overflow_error) then write (mesg,'("EFP_val_sum_across_PEs error val was ",ES12.6, ", prec_error = ",ES12.6)') & diff --git a/src/framework/MOM_diag_buffers.F90 b/src/framework/MOM_diag_buffers.F90 new file mode 100644 index 0000000000..da88389306 --- /dev/null +++ b/src/framework/MOM_diag_buffers.F90 @@ -0,0 +1,547 @@ +!> 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 k-direction + integer, intent(in) :: ke !< The end slot of the array k-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 + + + local_fail = .false. + + call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je) + call buffer%set_fill_value(fill_value) + 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, ks=1, ke=10 + real, parameter :: fill_value = -123.456 + + 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) + call buffer%set_fill_value(fill_value) + 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 a464137aa1..6fe071e859 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -2,20 +2,22 @@ ! 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 capabilies. +!> 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_array_transform, only : symmetric_sum +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 @@ -28,36 +30,37 @@ 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 +use MOM_domains, only : get_domain_extent, clone_MOM_domain implicit none ; private #undef __DO_SAFETY_CHECKS__ #define IMPLIES(A, B) ((.not. (A)) .or. (B)) -#define MAX_DSAMP_LEV 2 public set_axes_info, post_data, register_diag_field, time_type +public post_data_3d_by_column, post_data_3d_final public post_product_u, post_product_sum_u, post_product_v, post_product_sum_v -public set_masks_for_axes +public set_masks_for_axes, MOM_diag_send_complete ! post_data_1d_k is a deprecated interface that can be replaced by a call to post_data, but ! it is being retained for backward compatibility to older versions of the ocean_BGC code. public post_data_1d_k public safe_alloc_ptr, safe_alloc_alloc public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled public diag_mediator_init, diag_mediator_end, set_diag_mediator_grid -public diag_mediator_infrastructure_init +public diag_mediator_infrastructure_init, diag_mediator_set_OBC_info public diag_mediator_close_registration, get_diag_time_end 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 @@ -72,6 +75,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 @@ -125,9 +133,11 @@ module MOM_diag_mediator logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled !! 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 + integer :: downsample_level_factor = 1 !< If greater than 1, the factor by which this diagnostic will be downsampled + integer :: downsample_level_index = 0 !< If greater than 0, the index for the downsample level for this diagnostic + !! in the diag_cs%dsamp array. + ! 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 @@ -135,7 +145,11 @@ module MOM_diag_mediator ! For masking 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 + type(diag_dsamp), dimension(:), allocatable :: 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 @@ -152,9 +166,10 @@ module MOM_diag_mediator end type diag_grid_storage ! Integers to encode the total cell methods -!integer :: PPP=111 ! x:point,y:point,z:point, this kind of diagnostic is not currently present in diag_table.MOM6 -!integer :: PPS=112 ! x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6 -!integer :: PPM=113 ! x:point,y:point,z:mean , this kind of diagnostic is not currently present in diag_table.MOM6 +! Note that vorticity points (the PPP and PPM methods) are not fully dealt with for downsampling. +integer :: PPP=111 !< x:point,y:point,z:point +!integer :: PPS=112 ! x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6 +integer :: PPM=113 !< x:point,y:point,z:mean integer :: PSP=121 !< x:point,y:sum,z:point integer :: PSS=122 !< x:point,y:sum,z:point integer :: PSM=123 !< x:point,y:sum,z:mean @@ -162,18 +177,17 @@ 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 integer :: MMS=332 !< x:mean,y:mean,z:sum integer :: SSS=222 !< x:sum,y:sum,z:sum integer :: MMM=333 !< x:mean,y:mean,z:mean -integer :: MSK=-1 !< Use the downsample method of a mask !> 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 @@ -183,7 +197,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, @@ -247,20 +261,23 @@ 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. + logical :: symmetric_downsample_sums !< If true, use rotationally symmetric sums when downsampling diagnostics. + + ! 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 @@ -273,6 +290,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] @@ -287,8 +305,11 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: mask3dCui => null() real, dimension(:,:,:), pointer :: mask3dCvi => null() - type(diagcs_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample control container - + integer :: num_diag_dsamp_levels !< The number of downsampled levels requested in the parameters files (default 0) + integer, dimension(:), allocatable :: diag_dsamp_levels !< The downsample levels requested by diag registrations + type(diagcs_dsamp), dimension(:), allocatable :: dsamp !< An array of downsampling control containers + !! for each level of downsampling that is being used, + !! with a size determined at runtime via NUM_DIAG_DOWNSAMP_LEV !>@} ! Space for diagnostics is dynamically allocated as it is needed. @@ -298,7 +319,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 @@ -320,8 +341,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,8 +359,18 @@ module MOM_diag_mediator !> Number of checksum-only diagnostics integer :: num_chksum_diags + integer, dimension(:,:), allocatable :: OBC_u !< An array that indicates the presence and direction + !! of any open boundary conditions at u-points, + !! with a value of 0 for no OBC, 1 for an + !! Eastern OBC or -1 for a Western OBC + integer, dimension(:,:), allocatable :: OBC_v !< An array that indicates the presence and direction + !! of any open boundary conditions at v-points, + !! with a value of 0 for no OBC, 1 for a Northern OBC + !! or -1 for a Southern OBC 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 @@ -370,62 +401,56 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) real, allocatable, dimension(:) :: IaxB, iax ! Index-based integer and half-integer i-axis labels [nondim] real, allocatable, dimension(:) :: JaxB, jax ! Index-based integer and half-integer j-axis labels [nondim] - set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical - if (diag_cs%index_space_axes) then allocate(IaxB(G%IsgB:G%IegB)) - do i=G%IsgB, G%IegB - Iaxb(i)=real(i) + do I=G%IsgB,G%IegB + Iaxb(I) = real(I) enddo allocate(iax(G%isg:G%ieg)) - do i=G%isg, G%ieg - iax(i)=real(i)-0.5 + do i=G%isg,G%ieg + iax(i) = real(i)-0.5 enddo allocate(JaxB(G%JsgB:G%JegB)) - do j=G%JsgB, G%JegB - JaxB(j)=real(j) + do J=G%JsgB,G%JegB + JaxB(J) = real(J) enddo allocate(jax(G%jsg:G%jeg)) - do j=G%jsg, G%jeg - jax(j)=real(j)-0.5 + do j=G%jsg,G%jeg + jax(j) = real(j)-0.5 enddo endif ! Horizontal axes for the native grids - if (G%symmetric) then - if (diag_cs%index_space_axes) then - id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & - 'q point grid-space longitude', G%Domain, position=EAST) - id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & - 'q point grid space latitude', G%Domain, position=NORTH) + if (diag_cs%index_space_axes) then + if (G%symmetric) then + id_xq = diag_axis_init('Iq', IaxB(G%IsgB:G%IegB), 'none', 'x', & + 'Boundary (q) point grid-space longitude', G%Domain, position=EAST) + id_yq = diag_axis_init('Jq', JaxB(G%JsgB:G%JegB), 'none', 'y', & + 'Boundary (q) point grid-space latitude', G%Domain, position=NORTH) else - id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', G%Domain, position=EAST) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', G%Domain, position=NORTH) - endif - else - if (diag_cs%index_space_axes) then id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & - 'q point grid-space longitude', G%Domain, position=EAST) + 'Boundary (q) point grid-space longitude', G%Domain, position=EAST) id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & - 'q point grid space latitude', G%Domain, position=NORTH) + 'Boundary (q) point grid-space latitude', G%Domain, position=NORTH) + endif + id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & + 'Tracer (h) point grid-space longitude', G%Domain) + id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & + 'Tracer (h) point grid-space latitude', G%Domain) + else + if (G%symmetric) then + id_xq = diag_axis_init('xq', G%gridLonB(G%IsgB:G%IegB), G%x_axis_units, 'x', & + 'q point nominal longitude', G%Domain, position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%JsgB:G%JegB), G%y_axis_units, 'y', & + 'q point nominal latitude', G%Domain, position=NORTH) else id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & 'q point nominal longitude', G%Domain, position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & 'q point nominal latitude', G%Domain, position=NORTH) endif - endif - - if (diag_cs%index_space_axes) then - id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & - 'h point grid-space longitude', G%Domain) - id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & - 'h point grid space latitude', G%Domain) - else id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & 'h point nominal longitude', G%Domain) id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & @@ -488,11 +513,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)) @@ -585,7 +613,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) @@ -602,7 +630,7 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, j, nz, dl + integer :: i, j, nz, dl, dlfac real, dimension(:), pointer :: gridLonT_dsamp =>NULL() ! The longitude of downsampled T points for labeling ! the output axes, often in units of [degrees_N] or ! [km] or [m] or [gridpoints]. @@ -617,44 +645,46 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n ! [km] or [m] or [gridpoints]. - id_zl = id_zl_native ; id_zi = id_zi_native - !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!") + ! Axes group for native downsampled diagnostics + !Loop over the downsampling levels requested in parameters. + do dl=1, diag_cs%num_diag_dsamp_levels + dlfac = diag_cs%diag_dsamp_levels(dl) ! The actual downsampling factor for this level 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+dlfac*i) ; enddo + do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB ; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dlfac*j) ; enddo id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', G%Domain, coarsen=2) + 'q point nominal longitude', G%Domain, coarsen=dl) 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) + 'q point nominal latitude', G%Domain, coarsen=dl) + 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+dlfac*i-2) ; enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg ; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dlfac*j-2) ; enddo id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', G%Domain, coarsen=2) + 'q point nominal longitude', G%Domain, coarsen=dl) 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) + 'q point nominal latitude', G%Domain, coarsen=dl) + 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+dlfac*i-2) ; enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg ; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dlfac*j-2) ; enddo id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & - 'h point nominal longitude', G%Domain, coarsen=2) + 'h point nominal longitude', G%Domain, coarsen=dl) id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & - 'h point nominal latitude', G%Domain, coarsen=2) + 'h point nominal latitude', G%Domain, coarsen=dl) - deallocate(gridLonT_dsamp,gridLatT_dsamp) + deallocate(gridLonT_dsamp, gridLatT_dsamp) ! Axis groupings for the model layers + id_zl = id_zl_native ; id_zi = id_zi_native + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) @@ -692,7 +722,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)) @@ -706,7 +736,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), G, 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 @@ -867,7 +897,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 @@ -877,63 +907,71 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, dl + integer :: c, dl, dlfac 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 - 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!") + ! 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=1, diag_cs%num_diag_dsamp_levels + dlfac = diag_cs%diag_dsamp_levels(dl) ! The actual downsampling factor for this level do c=1, diag_cs%num_diag_coords ! Level/layer h-points in diagnostic coordinate axes => diag_cs%remap_axesTL(c) call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, & - dl, G%isc, G%jsc, 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 + dlfac, xyz_method(axes), G%isc, G%jsc, G%isd, G%jsd, & + G%HId(dl)%isc, G%HId(dl)%iec, G%HId(dl)%jsc, G%HId(dl)%jec, G%HId(dl)%isd, G%HId(dl)%ied, & + G%HId(dl)%jsd, G%HId(dl)%jed) + 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 + dlfac, xyz_method(axes), G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId(dl)%IscB, G%HId(dl)%IecB, G%HId(dl)%jsc, G%HId(dl)%jec, G%HId(dl)%IsdB, G%HId(dl)%IedB, & + G%HId(dl)%jsd, G%HId(dl)%jed) + diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, & - dl, G%isc, G%JscB, G%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 + dlfac, xyz_method(axes), G%isc, G%JscB, G%isd, G%JsdB, & + G%HId(dl)%isc, G%HId(dl)%iec, G%HId(dl)%JscB, G%HId(dl)%JecB, G%HId(dl)%isd, G%HId(dl)%ied, & + G%HId(dl)%JsdB, G%HId(dl)%JedB) + diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, & - dl, G%IscB, G%JscB, G%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 + dlfac, xyz_method(axes), G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId(dl)%IscB, G%HId(dl)%IecB, G%HId(dl)%JscB, G%HId(dl)%JecB, G%HId(dl)%IsdB, G%HId(dl)%IedB, & + G%HId(dl)%JsdB, G%HId(dl)%JedB) + diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, & - dl, G%isc, G%jsc, 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 + dlfac, xyz_method(axes), G%isc, G%jsc, G%isd, G%jsd, & + G%HId(dl)%isc, G%HId(dl)%iec, G%HId(dl)%jsc, G%HId(dl)%jec, G%HId(dl)%isd, G%HId(dl)%ied, & + G%HId(dl)%jsd, G%HId(dl)%jed) + 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 + dlfac, xyz_method(axes), G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId(dl)%IscB, G%HId(dl)%IecB, G%HId(dl)%jsc, G%HId(dl)%jec, G%HId(dl)%IsdB, G%HId(dl)%IedB, & + G%HId(dl)%jsd, G%HId(dl)%jed) + diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, & - dl, G%isc, G%JscB, G%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 + dlfac, xyz_method(axes), G%isc, G%JscB, G%isd, G%JsdB, & + G%HId(dl)%isc, G%HId(dl)%iec, G%HId(dl)%JscB, G%HId(dl)%JecB, G%HId(dl)%isd, G%HId(dl)%ied, & + G%HId(dl)%JsdB, G%HId(dl)%JedB) + diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, & - dl, G%IscB, G%JscB, G%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 + dlfac, xyz_method(axes), G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId(dl)%IscB, G%HId(dl)%IecB, G%HId(dl)%JscB, G%HId(dl)%JecB, G%HId(dl)%IsdB, G%HId(dl)%IedB, & + G%HId(dl)%JsdB, G%HId(dl)%JedB) + diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask enddo enddo end subroutine set_masks_for_axes_dsamp @@ -1012,7 +1050,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, & @@ -1058,10 +1096,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.') @@ -1122,6 +1160,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 @@ -1134,7 +1173,7 @@ subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coor type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles type(axes_grp), intent(out) :: axes !< The group of 1D axes - integer, intent(in) :: dl !< Downsample level + integer, intent(in) :: dl !< Downsample level index integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the @@ -1171,10 +1210,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.') @@ -1196,7 +1235,8 @@ subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coor else axes%v_cell_method = '' endif - axes%downsample_level = dl + axes%downsample_level_index = dl + axes%downsample_level_factor = diag_cs%diag_dsamp_levels(dl) if (present(nz)) axes%nz = nz if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number if (present(is_h_point)) axes%is_h_point = is_h_point @@ -1236,6 +1276,7 @@ subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coor endif endif + if (.Not. allocated(axes%dsamp)) allocate(axes%dsamp(diag_cs%num_diag_dsamp_levels)) axes%dsamp(dl)%mask2d => null() if (axes%rank==2) then if (axes%is_h_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dT @@ -1358,11 +1399,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 @@ -1423,28 +1460,31 @@ 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 - + real, dimension(:,:), pointer :: ones => NULL() ! An array of ones for testing where masks do not apply [nondim] + real, dimension(:,:), pointer :: mask_in => NULL() ! A pointer to the input mask [nondim] + integer :: dl, dlfac 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 @@ -1484,38 +1524,45 @@ 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) - if (dl > 1) then + dlfac = 1 + if (not_static .and. associated(diag%axes)) & + dlfac = diag%axes%downsample_level_factor ! Static field downsampling is not supported yet. + ! Downsample the diag field and mask as appropriate. + if (dlfac > 1) then + dl = diag%axes%downsample_level_index 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) + ! Replicate the downsampling of other fields to find unmasked points. + allocate(ones, mold=locmask) ; ones(:,:) = 1.0 + mask_in => mask + call downsample_field_2d(ones, locmask_dsamp, dlfac, diag%xyz_method, mask_in, diag_cs, diag, & + isv_o, jsv_o, isv, iev, jsv, jev) + deallocate(ones) + where (abs(locmask_dsamp) > 0.0) locmask_dsamp = 1.0 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 @@ -1540,22 +1587,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) @@ -1566,7 +1606,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif endif endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dlfac<2) & deallocate( locfield ) end subroutine post_data_2d_low @@ -1592,8 +1632,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) @@ -1614,12 +1653,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 @@ -1630,9 +1666,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)) @@ -1652,13 +1685,13 @@ 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, & - staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + diag_cs%dz_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & + diag_cs%OBC_u, diag_cs%OBC_v, staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) else call vertically_reintegrate_diag_field( & diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & diag_cs%h_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & - staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + diag_cs%OBC_u, diag_cs%OBC_v, staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then @@ -1682,12 +1715,12 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & - diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, field, remapped_field) + diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, diag_cs%OBC_u, diag_cs%OBC_v, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) else call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & - diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, field, remapped_field) + diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, diag_cs%OBC_u, diag_cs%OBC_v, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then @@ -1711,17 +1744,16 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz+1)) if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then call vertically_interpolate_diag_field(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & - diag_cs%G, dz_diag, staggered_in_x, staggered_in_y, & + diag_cs%G, dz_diag, diag_cs%OBC_u, diag_cs%OBC_v, staggered_in_x, staggered_in_y, & diag%axes%mask3d, field, remapped_field) else call vertically_interpolate_diag_field(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & - diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & + diag_cs%G, h_diag, diag_cs%OBC_u, diag_cs%OBC_v, staggered_in_x, staggered_in_y, & diag%axes%mask3d, field, remapped_field) endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then - ! Since 3d masks do not vary in the vertical, just use as much as is - ! needed. + ! Since 3d masks do not vary in the vertical, just use as much as is needed. call post_data_3d_low(diag, remapped_field, diag_cs, is_static, & mask=diag%axes%mask3d) else @@ -1758,12 +1790,14 @@ 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 + real, dimension(:,:,:), pointer :: ones => NULL() ! An array of ones for testing where masks do not apply [nondim] + real, dimension(:,:,:), pointer :: mask_in => NULL() ! A pointer to the input mask [nondim] + integer :: dl, dlfac integer :: time_days integer :: time_seconds @@ -1772,13 +1806,14 @@ 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, ! but non-symmetric arrays are using a NE-grid indexing. Send_data ! actually only uses the difference between ie and is to determine ! 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 + !isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je 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 @@ -1831,11 +1866,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 @@ -1843,25 +1874,38 @@ 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) - if (dl > 1) then + dlfac = 1 + if (not_static .and. associated(diag%axes)) & + dlfac = diag%axes%downsample_level_factor ! Static field downsampling is not supported yet. + ! Downsample the diag field and mask as appropriate. + if (dlfac > 1) then + dl = diag%axes%downsample_level_index isv_o = isv ; jsv_o = jsv - call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + !Note that downsample_diag_field_3d takes the downsampling index + 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) + ! Replicate the downsampling of other fields to find unmasked points. + allocate(ones, mold=locmask) ; ones(:,:,:) = 1.0 + mask_in => mask + call downsample_field_3d(ones, locmask_dsamp, dlfac, diag%xyz_method, mask_in, diag_cs, diag, & + isv_o, jsv_o, isv, iev, jsv, jev) + deallocate(ones) + where (abs(locmask_dsamp) > 0.0) locmask_dsamp = 1.0 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 @@ -1887,22 +1931,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) @@ -1915,15 +1952,70 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) endif endif - if (diag%fms_xyave_diag_id>0) then + if (diag%fms_xyave_diag_id>0 .and. dlfac<2) then call post_xy_average(diag_cs, diag, locfield) endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dlfac<2) & deallocate( locfield ) 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 @@ -2089,9 +2181,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. @@ -2107,8 +2199,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 @@ -2203,7 +2295,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 @@ -2211,9 +2303,10 @@ 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 + character(len=2) :: dl_str diag_cs => axes_in%diag_cs @@ -2235,6 +2328,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 @@ -2325,12 +2426,13 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time endif ! axes%rank == 3 enddo ! i - !Register downsampled diagnostics - do dl=2,MAX_DSAMP_LEV + ! Register downsampled diagnostics + do dl=1, diag_cs%num_diag_dsamp_levels ! Do not attempt to checksum the downsampled diagnostics if (diag_cs%diag_as_chksum) cycle - new_module_name = trim(module_name)//'_d2' + write(dl_str, '(i0)') diag_cs%diag_dsamp_levels(dl) + new_module_name = trim(module_name)//'_d'//trim(dl_str) axes_d2 => null() if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then @@ -2383,7 +2485,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time ! For each diagnostic coordinate register the diagnostic again under a different module name do i=1,diag_cs%num_diag_coords - new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//'_d2' + new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//'_d'//trim(dl_str) ! Register diagnostics remapped to z vertical coordinate if (axes_in%rank == 3) then @@ -2430,7 +2532,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time endif ! associated(remap_axes) endif ! axes%rank == 3 enddo ! i - enddo + enddo ! dl dimensions = "" if (axes_in%is_h_point) dimensions = trim(dimensions)//" xh, yh," @@ -2439,14 +2541,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 = '' @@ -2466,7 +2561,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, & @@ -2476,7 +2571,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. @@ -2554,8 +2649,8 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, 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) this_diag%fms_xyave_diag_id = fms_xyave_id - !Encode and save the cell methods for this diag - call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) + ! Encode and save the cell methods for this diagnostic + this_diag%xyz_method = xyz_method(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 register_diag_field_expand_cmor = .true. @@ -2569,7 +2664,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 @@ -2603,8 +2698,8 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, 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) this_diag%fms_xyave_diag_id = fms_xyave_id - !Encode and save the cell methods for this diag - call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) + ! Encode and save the cell methods for this diagnostic + this_diag%xyz_method = xyz_method(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 register_diag_field_expand_cmor = .true. @@ -2621,7 +2716,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. @@ -2726,7 +2821,7 @@ subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name 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" @@ -2744,10 +2839,9 @@ subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name end subroutine add_diag_to_list -!> Adds the encoded "cell_methods" for a diagnostics as a diag% property -!! This allows access to the cell_method for a given diagnostics at the time of sending -subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) - type(diag_type), pointer :: diag !< This diagnostic +!> Returns an integer encoding the "cell_methods" for diagnostic, allowing simpler +!! access to the cell_method for a given diagnostic at the time of sending +integer function xyz_method(axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates !! axes for this field character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. @@ -2758,21 +2852,21 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho !! Use '' have no method. logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields !! (vertically integrated). Default/absent for intensive. - 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 - mstr = diag%axes%v_cell_method + mstr = axes%v_cell_method if (present(v_extensive)) then - if (present(v_cell_method)) call MOM_error(FATAL, "attach_cell_methods: " // & + if (present(v_cell_method)) call MOM_error(FATAL, "xyz_method: " // & 'Vertical cell method was specified along with the vertically extensive flag.') if (v_extensive) then mstr='sum' @@ -2788,7 +2882,7 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho xyz_method = xyz_method + 2 endif - mstr = diag%axes%y_cell_method + mstr = axes%y_cell_method if (present(y_cell_method)) mstr = y_cell_method if (trim(mstr)=='sum') then xyz_method = xyz_method + 10 @@ -2796,7 +2890,7 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho xyz_method = xyz_method + 20 endif - mstr = diag%axes%x_cell_method + mstr = axes%x_cell_method if (present(x_cell_method)) mstr = x_cell_method if (trim(mstr)=='sum') then xyz_method = xyz_method + 100 @@ -2804,14 +2898,13 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho xyz_method = xyz_method + 200 endif - diag%xyz_method = xyz_method -end subroutine add_xyz_method +end function xyz_method !> 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, 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. @@ -2925,10 +3018,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" @@ -2994,13 +3129,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 @@ -3037,7 +3172,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, & @@ -3049,7 +3184,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. @@ -3078,12 +3213,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 @@ -3139,7 +3274,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 @@ -3183,14 +3318,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 @@ -3225,13 +3353,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. @@ -3311,6 +3439,7 @@ subroutine diag_mediator_infrastructure_init(err_msg) call MOM_diag_manager_init(err_msg=err_msg) end subroutine diag_mediator_infrastructure_init + !> diag_mediator_init initializes the MOM diag_mediator and opens the available !! diagnostics file, if appropriate. subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) @@ -3329,7 +3458,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! is not necessary that the metrics and axis labels be set up yet. ! Local variables - integer :: ios, i, new_unit + integer :: ios, i, new_unit, dl, dlfac logical :: opened, new_file integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping @@ -3337,13 +3466,15 @@ 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 + character(len=16) :: dsamp_domain_name 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) @@ -3382,9 +3513,14 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, 'USE_INDEX_DIAGNOSTIC_AXES', diag_cs%index_space_axes, & - 'If true, use a grid index coordinate convention for diagnostic axes. ',& + 'If true, use a grid index coordinate convention for diagnostic axes. ', & + default=.false.) + call get_param(param_file, mdl, 'SYMMETRIC_DOWNSAMPLE_SUMS', diag_cs%symmetric_downsample_sums, & + 'If true, use rotationally symmetric sums when downsampling diagnostics.', & 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* @@ -3404,6 +3540,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 @@ -3430,26 +3567,82 @@ 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 + allocate(diag_cs%h_old(G%isd:G%ied,G%jsd:G%jed,nz), source=0.0) #endif + allocate(diag_cs%OBC_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0) + allocate(diag_cs%OBC_v(G%isd:G%ied,G%JsdB:G%JedB), source=0) 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 - !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 - diag_cs%dsamp(2)%jsd = G%HId2%jsd ; diag_cs%dsamp(2)%jed = G%HId2%jed - diag_cs%dsamp(2)%isg = G%HId2%isg ; diag_cs%dsamp(2)%ieg = G%HId2%ieg - diag_cs%dsamp(2)%jsg = G%HId2%jsg ; diag_cs%dsamp(2)%jeg = G%HId2%jeg - diag_cs%dsamp(2)%isgB = G%HId2%isgB ; diag_cs%dsamp(2)%iegB = G%HId2%iegB - diag_cs%dsamp(2)%jsgB = G%HId2%jsgB ; diag_cs%dsamp(2)%jegB = G%HId2%jegB - + ! In this code design + ! diag_cs%num_diag_dsamp_levels is the number of downsampling levels requested in the parameters + ! diag_cs%diag_dsamp_levels(dl) is the actual downsampling factor for each level, + ! which is used to as the division factor to define the axes for that level. + ! Note that the downsampling axes and domains are created at initialization based on what is + ! requested in the parameter files (default is none) regardless of whether + ! any downsampled diagnostics are present in the diag_table. + ! Are downsampled diagnostics requested? + call get_param(param_file, mdl, 'NUM_DIAG_DOWNSAMP_LEV', diag_cs%num_diag_dsamp_levels, & + 'The number of diagnostic downsample levels to use. '//& + 'For each level, an entry in DIAG_DOWNSAMP_LEV must be provided.', & + default=0) + if (diag_cs%num_diag_dsamp_levels > 0) then + allocate(diag_cs%diag_dsamp_levels(diag_cs%num_diag_dsamp_levels)) + call get_param(param_file, mdl, 'DIAG_DOWNSAMP_LEVS', diag_cs%diag_dsamp_levels, & + 'A comma separated list of diagnostic downsample levels to be used. ', & + fail_if_missing=.true.) + + allocate(diag_cs%dsamp(diag_cs%num_diag_dsamp_levels)) + ! Initialize the global grid extents for all requested levels of diagnostics coarsening. + allocate(G%HId(diag_cs%num_diag_dsamp_levels)) + !Allocate downsampling domains + allocate(G%Domain%mpp_domain_d(diag_cs%num_diag_dsamp_levels)) + !Create and populated the downsampling domains and grids + do dl=1, diag_cs%num_diag_dsamp_levels + dlfac = diag_cs%diag_dsamp_levels(dl) + !Create the auxiliary mpp_domain for this level of downsampled diagnostics + !Downsample diagnostics calculations do not need halos. + write(dsamp_domain_name, '(a,i0)') trim("MOM_domain_d"),dlfac + call clone_MOM_domain(G%Domain, G%Domain%mpp_domain_d(dl), coarsen=dlfac, & !halo_size=0, & + domain_name=dsamp_domain_name) + + !Set the grid extents for this level of downsampling. + call get_domain_extent(G%Domain, G%HId(dl)%isc, G%HId(dl)%iec, G%HId(dl)%jsc, G%HId(dl)%jec, & + G%HId(dl)%isd, G%HId(dl)%ied, G%HId(dl)%jsd, G%HId(dl)%jed, & + G%HId(dl)%isg, G%HId(dl)%ieg, G%HId(dl)%jsg, G%HId(dl)%jeg, & + coarsen=dl) + + ! Set array sizes for fields that are discretized at tracer cell boundaries. + G%HId(dl)%IscB = G%HId(dl)%isc ; G%HId(dl)%JscB = G%HId(dl)%jsc + G%HId(dl)%IsdB = G%HId(dl)%isd ; G%HId(dl)%JsdB = G%HId(dl)%jsd + G%HId(dl)%IsgB = G%HId(dl)%isg ; G%HId(dl)%JsgB = G%HId(dl)%jsg + if (G%symmetric) then + G%HId(dl)%IscB = G%HId(dl)%isc-1 ; G%HId(dl)%JscB = G%HId(dl)%jsc-1 + G%HId(dl)%IsdB = G%HId(dl)%isd-1 ; G%HId(dl)%JsdB = G%HId(dl)%jsd-1 + G%HId(dl)%IsgB = G%HId(dl)%isg-1 ; G%HId(dl)%JsgB = G%HId(dl)%jsg-1 + endif + G%HId(dl)%IecB = G%HId(dl)%iec ; G%HId(dl)%JecB = G%HId(dl)%jec + G%HId(dl)%IedB = G%HId(dl)%ied ; G%HId(dl)%JedB = G%HId(dl)%jed + G%HId(dl)%IegB = G%HId(dl)%ieg ; G%HId(dl)%JegB = G%HId(dl)%jeg + + !Downsample indices for diagnostics that are on a coarser grid than the model grid. + diag_cs%dsamp(dl)%isc = G%HId(dl)%isc - (G%HId(dl)%isd-1) + diag_cs%dsamp(dl)%iec = G%HId(dl)%iec - (G%HId(dl)%isd-1) + diag_cs%dsamp(dl)%jsc = G%HId(dl)%jsc - (G%HId(dl)%jsd-1) + diag_cs%dsamp(dl)%jec = G%HId(dl)%jec - (G%HId(dl)%jsd-1) + diag_cs%dsamp(dl)%isd = G%HId(dl)%isd ; diag_cs%dsamp(dl)%ied = G%HId(dl)%ied + diag_cs%dsamp(dl)%jsd = G%HId(dl)%jsd ; diag_cs%dsamp(dl)%jed = G%HId(dl)%jed + diag_cs%dsamp(dl)%isg = G%HId(dl)%isg ; diag_cs%dsamp(dl)%ieg = G%HId(dl)%ieg + diag_cs%dsamp(dl)%jsg = G%HId(dl)%jsg ; diag_cs%dsamp(dl)%jeg = G%HId(dl)%jeg + diag_cs%dsamp(dl)%isgB = G%HId(dl)%isgB ; diag_cs%dsamp(dl)%iegB = G%HId(dl)%iegB + diag_cs%dsamp(dl)%jsgB = G%HId(dl)%jsgB ; diag_cs%dsamp(dl)%jegB = G%HId(dl)%jegB + enddo + endif ! Initialze available diagnostic log file if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then write(this_pe,'(i6.6)') PE_here() @@ -3490,8 +3683,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 "//& @@ -3539,11 +3732,44 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) end subroutine diag_mediator_init +!> diag_mediator_set_OBC_info stores limited information about the locations and orientations +!! of open boundary condition segments at velocity points.. +subroutine diag_mediator_set_OBC_info(G, OBC_seg_u, OBC_seg_v, diag_cs) + type(ocean_grid_type), intent(inout) :: G !< The ocean grid type. + integer, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & + intent(in) :: OBC_seg_u !< An array that indicates the presence and direction + !! of any open boundary conditions at u-points, + !! with a value of 0 for no OBC, a positive value for an + !! Eastern OBC or a negative value for a Western OBC + integer, dimension(G%isd:G%ied,G%JsdB:G%JedB), & + intent(in) :: OBC_seg_v !< An array that indicates the presence and direction + !! of any open boundary conditions at v-points, + !! with a value of 0 for no OBC, a positive value for a + !! Northern OBC or a negative value for a Southern OBC + type(diag_ctrl), intent(inout) :: diag_cs !< A defined type used to regulate diagnostics + + integer :: i, j + + do j=G%jsd,G%jed ; do i=G%IsdB,G%IedB + diag_cs%OBC_u(I,j) = 0 + if (OBC_seg_u(I,j) > 0) diag_cs%OBC_u(I,j) = 1 + if (OBC_seg_u(I,j) < 0) diag_cs%OBC_u(I,j) = -1 + enddo ; enddo + + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + diag_cs%OBC_v(i,J) = 0.0 + if (OBC_seg_v(i,J) > 0) diag_cs%OBC_v(i,J) = 1 + if (OBC_seg_v(i,J) < 0) diag_cs%OBC_v(i,J) = -1 + enddo ; enddo + +end subroutine diag_mediator_set_OBC_info + + !> 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 @@ -3572,7 +3798,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) :: & @@ -3640,6 +3866,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, & @@ -3701,11 +3928,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 @@ -3771,7 +4021,7 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) if (associated(diag_cs%mask3dBi)) deallocate(diag_cs%mask3dBi) if (associated(diag_cs%mask3dCui)) deallocate(diag_cs%mask3dCui) if (associated(diag_cs%mask3dCvi)) deallocate(diag_cs%mask3dCvi) - do dl=2,MAX_DSAMP_LEV + do dl=1, diag_cs%num_diag_dsamp_levels if (associated(diag_cs%dsamp(dl)%mask2dT)) deallocate(diag_cs%dsamp(dl)%mask2dT) if (associated(diag_cs%dsamp(dl)%mask2dBu)) deallocate(diag_cs%dsamp(dl)%mask2dBu) if (associated(diag_cs%dsamp(dl)%mask2dCu)) deallocate(diag_cs%dsamp(dl)%mask2dCu) @@ -3832,7 +4082,7 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) deallocate(diag_cs%remap_axesCvi) endif - do dl=2,MAX_DSAMP_LEV + do dl=1, diag_cs%num_diag_dsamp_levels if (allocated(diag_cs%dsamp(dl)%remap_axesTL)) & deallocate(diag_cs%dsamp(dl)%remap_axesTL) if (allocated(diag_cs%dsamp(dl)%remap_axesTi)) & @@ -3862,28 +4112,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 @@ -3928,7 +4156,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 @@ -3956,7 +4184,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 @@ -4009,7 +4237,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 @@ -4034,7 +4262,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 @@ -4051,7 +4279,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 @@ -4069,7 +4297,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 @@ -4085,7 +4313,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 @@ -4119,7 +4347,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. @@ -4127,7 +4355,7 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: k, dl + integer :: k, dl, dlfac !print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec !print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb @@ -4143,32 +4371,37 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) ! original dB-sym extents 0 56 0 56 ! coarse d extents 1 28 1 28 - do dl=2,MAX_DSAMP_LEV + do dl=1, diag_cs%num_diag_dsamp_levels + dlfac = diag_cs%diag_dsamp_levels(dl) !Actual downsampling factor for this level ! 2d mask - call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl, G%isc, G%jsc, G%isd, G%jsd, & - G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) - call downsample_mask(G%mask2dBu, diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB, G%JscB, G%IsdB, G%JsdB, & - G%HId2%IscB,G%HId2%IecB, G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) - call downsample_mask(G%mask2dCu, diag_cs%dsamp(dl)%mask2dCu, dl, G%IscB, G%jsc, G%IsdB, G%jsd, & - G%HId2%IscB,G%HId2%IecB, G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) - call downsample_mask(G%mask2dCv, diag_cs%dsamp(dl)%mask2dCv, dl,G %isc ,G%JscB, G%isd, G%JsdB, & - G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dlfac, MMP, G%isc, G%jsc, G%isd, G%jsd, & + G%HId(dl)%isc, G%HId(dl)%iec, G%HId(dl)%jsc, G%HId(dl)%jec, G%HId(dl)%isd, G%HId(dl)%ied, & + G%HId(dl)%jsd, G%HId(dl)%jed) + call downsample_mask(G%mask2dBu, diag_cs%dsamp(dl)%mask2dBu, dlfac, PPP,G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId(dl)%IscB,G%HId(dl)%IecB, G%HId(dl)%JscB,G%HId(dl)%JecB,G%HId(dl)%IsdB,G%HId(dl)%IedB, & + G%HId(dl)%JsdB,G%HId(dl)%JedB) + call downsample_mask(G%mask2dCu, diag_cs%dsamp(dl)%mask2dCu, dlfac, PMP, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId(dl)%IscB,G%HId(dl)%IecB, G%HId(dl)%jsc, G%HId(dl)%jec,G%HId(dl)%IsdB,G%HId(dl)%IedB, & + G%HId(dl)%jsd, G%HId(dl)%jed) + call downsample_mask(G%mask2dCv, diag_cs%dsamp(dl)%mask2dCv, dlfac, MPP, G %isc ,G%JscB, G%isd, G%JsdB, & + G%HId(dl)%isc ,G%HId(dl)%iec, G%HId(dl)%JscB,G%HId(dl)%JecB,G%HId(dl)%isd ,G%HId(dl)%ied, & + G%HId(dl)%JsdB,G%HId(dl)%JedB) ! 3d native masks are needed by diag_manager but the native variables ! can only be masked 2d - for ocean points, all layers exists. - allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz)) - allocate(diag_cs%dsamp(dl)%mask3dBL(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz)) - allocate(diag_cs%dsamp(dl)%mask3dCuL(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz)) - allocate(diag_cs%dsamp(dl)%mask3dCvL(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId(dl)%isd:G%HId(dl)%ied,G%HId(dl)%jsd:G%HId(dl)%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dBL(G%HId(dl)%IsdB:G%HId(dl)%IedB,G%HId(dl)%JsdB:G%HId(dl)%JedB,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCuL(G%HId(dl)%IsdB:G%HId(dl)%IedB,G%HId(dl)%jsd:G%HId(dl)%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCvL(G%HId(dl)%isd:G%HId(dl)%ied,G%HId(dl)%JsdB:G%HId(dl)%JedB,1:nz)) do k=1,nz diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) enddo - allocate(diag_cs%dsamp(dl)%mask3dTi(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz+1)) - allocate(diag_cs%dsamp(dl)%mask3dBi(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) - allocate(diag_cs%dsamp(dl)%mask3dCui(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz+1)) - allocate(diag_cs%dsamp(dl)%mask3dCvi(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dTi(G%HId(dl)%isd:G%HId(dl)%ied,G%HId(dl)%jsd:G%HId(dl)%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dBi(G%HId(dl)%IsdB:G%HId(dl)%IedB,G%HId(dl)%JsdB:G%HId(dl)%JedB,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCui(G%HId(dl)%IsdB:G%HId(dl)%IedB,G%HId(dl)%jsd:G%HId(dl)%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCvi(G%HId(dl)%isd:G%HId(dl)%ied,G%HId(dl)%JsdB:G%HId(dl)%JedB,1:nz+1)) do k=1,nz+1 diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) @@ -4179,31 +4412,33 @@ 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 - integer, intent(in) :: dl !< Integer downsample level + integer, intent(in) :: fo1 !< The size of the original diag field in x on data domain including halos + integer, intent(in) :: fo2 !< The size of the original diag field in y on data domain including halos + integer, intent(in) :: dl !< Index of downsample level type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output integer, intent(out) :: isv !< i-start index for diagnostics integer, intent(out) :: iev !< i-end index for diagnostics 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, dlfac 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. + dlfac = diag_cs%diag_dsamp_levels(dl) !Actual downsampling factor for this level 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 + if (mod(diag_cs%ie-diag_cs%is+1, dlfac) /= 0 .OR. & + mod(diag_cs%je-diag_cs%js+1, dlfac) /= 0) then write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& - "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,& + "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dL=", & + dlfac,& " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) endif @@ -4212,18 +4447,20 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1 cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1 - isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec - jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec - f1 = fo1/dl - f2 = fo2/dl - !Correction for the symmetric case + !isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec + !jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec + + f1 = fo1/dlfac + f2 = fo2/dlfac + ! Correction for the symmetric case if (diag_cs%G%symmetric) then - f1 = f1 + mod(fo1,dl) - f2 = f2 + mod(fo2,dl) + f1 = f1 + mod(fo1,dlfac) + f2 = f2 + mod(fo2,dlfac) endif + + ! Find the range of indices in the downsampled 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 @@ -4231,7 +4468,7 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev elseif ( f1 == cszi + 1 ) then isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2 ! Symmetric computational domain else - write (mesg,*) " peculiar size ",f1," in i-direction\n"//& + write (mesg,*) " dl =",dl,",dL =",dlfac,",fo1 =",fo1," f1 =",f1," peculiar size for diag field in i-direction\n"//& "does not match one of ", cszi, cszi+1, dszi, dszi+1 call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) endif @@ -4244,40 +4481,39 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev elseif ( f2 == cszj + 1 ) then jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2 ! Symmetric computational domain else - write (mesg,*) " peculiar size ",f2," in j-direction\n"//& + write (mesg,*) " dl =",dl,",dL =",dlfac,",fo2 =",fo2," f2 =",f2," peculiar size for diag field in j-direction\n"//& "does not match one of ", cszj, cszj+1, dszj, dszj+1 call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) 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] real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post - integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: dl !< Index of Level of down sampling integer, intent(inout) :: isv !< i-start index for diagnostics integer, intent(inout) :: iev !< i-end index for diagnostics integer, intent(inout) :: jsv !< j-start index for diagnostics integer, intent(inout) :: jev !< j-end index for diagnostics real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [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 @@ -4285,40 +4521,38 @@ subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, else call MOM_error(FATAL, "downsample_diag_field_3d: Cannot downsample without a mask!!! ") endif - - call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, & - isv_o, jsv_o, isv, iev, jsv, jev) + call downsample_field(locfield, locfield_dsamp, diag_cs%diag_dsamp_levels(dl), diag%xyz_method, & + locmask, diag_cs, diag, isv_o, jsv_o, isv, iev, jsv, jev) 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] real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post - integer, intent(in) :: dl !< Level of down sampling + integer, intent(in) :: dl !< Index of Level of down sampling integer, intent(inout) :: isv !< i-start index for diagnostics integer, intent(inout) :: iev !< i-end index for diagnostics integer, intent(inout) :: jsv !< j-start index for diagnostics integer, intent(inout) :: jev !< j-end index for diagnostics real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [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,8 +4561,8 @@ subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, call MOM_error(FATAL, "downsample_diag_field_2d: Cannot downsample without a mask!!! ") endif - call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, & - isv_o,jsv_o,isv,iev,jsv,jev) + call downsample_field(locfield, locfield_dsamp, diag_cs%diag_dsamp_levels(dl), diag%xyz_method, & + locmask, diag_cs, diag, isv_o, jsv_o, isv, iev, jsv, jev) end subroutine downsample_diag_field_2d @@ -4337,7 +4571,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] @@ -4369,12 +4603,13 @@ end subroutine downsample_diag_field_2d !> This subroutine allocates and computes a down sampled 3d array given an input array !! The down sample method is based on the "cell_methods" for the diagnostics as explained !! in the above table -subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) +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] - integer, intent(in) :: dl !< Level of down sampling + 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] + real, dimension(:,:,:), pointer :: mask !< Mask for input field [nondim] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: isv_o !< Original i-start index @@ -4383,142 +4618,144 @@ 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, k, i_dn, j_dn, ks, ke, i0, j0, f1, f2, f_in1, f_in2 + integer :: ii, jj ! The index locations on the full grid that contribute to the averages. + integer :: i0_off, j0_off ! The starting point offsets between full array and reduced array + ! indices when i or j is 0. + real :: wt(dL,dL) ! 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 :: wtd_field(dL,dL) ! The weighted field to sum, 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 :: wt_1d(dL) ! 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 :: wtd_field_1d(dL) ! The weighted field to sum, 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 :: 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] + real :: h_face ! The thickness at a velocity face [H ~> m or kg m-2] real :: eps_vol ! A negligibly small volume or mass [H L2 ~> m3 or kg] real :: eps_area ! A negligibly small area [L2 ~> m2] real :: eps_face ! A negligibly small face area [H L ~> m2 or kg m-1] + logical :: naive ! If true, use naive rotatially variant sums to reproduct previous answers. ks = 1 ; ke = size(field_in,3) + + ! It would be better to use a max with eps_vol instead of adding it into the denominator. eps_face = 1.0e-20 * diag_cs%G%US%m_to_L * diag_cs%GV%m_to_H eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2 eps_vol = 1.0e-20 * diag_cs%G%US%m_to_L**2 * diag_cs%GV%m_to_H + naive = .not.diag_CS%symmetric_downsample_sums + ! 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,ks:ke)) ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) - f_in1 = size(field_in,1) - f_in2 = size(field_in,2) - f1 = f_in1/dl - f2 = f_in2/dl - !Correction for the symmetric case + f_in1 = size(field_in, 1) + f_in2 = size(field_in, 2) + f1 = f_in1 / dL + f2 = f_in2 / dL + ! Correction for the symmetric case if (diag_cs%G%symmetric) then - f1 = f1 + mod(f_in1,dl) - f2 = f2 + mod(f_in2,dl) + f1 = f1 + mod(f_in1, dL) + f2 = f2 + mod(f_in2, dL) endif - allocate(field_out(1:f1,1:f2,ks:ke)) + allocate(field_out(1:f1,1:f2,ks:ke), source=0.0) + + ! These are the starting point offsets between full array and reduced array indices when i or j is 0. + i0_off = (isv_o-1) - dL*isv_d + j0_off = (jsv_o-1) - dL*jsv_d - ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain - !### The averaging used here is not rotationally invariant. + ! Fill the down sampled field on the down sampled diagnostics (almost always compute) domain 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) - 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 !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 + do j_dn=1,dL ; do i_dn=1,dL + ! ii and jj are the index locations on the full grid that contribute to the averages. + jj = j_dn + (dL*j + j0_off) ; ii = i_dn + (dL*i + i0_off) + wt(i_dn,j_dn) = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k) + wtd_field(i_dn,j_dn) = field_in(ii,jj,k) * wt(i_dn,j_dn) 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) = square_sum(wtd_field(1:dL,1:dL), dL, naive) / & + (square_sum(wt(1:dL,1:dL), dL, naive) + 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) - ave = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - weight = mask(ii,jj,k) - ave = ave+field_in(ii,jj,k)*weight + do j_dn=1,dL ; do i_dn=1,dL + jj = j_dn + (dL*j + j0_off) ; ii = i_dn + (dL*i + i0_off) + wtd_field(i_dn,j_dn) = field_in(ii,jj,k) * mask(ii,jj,k) enddo ; enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) + field_out(i,j,k) = square_sum(wtd_field(1:dL,1:dL), dL, naive) ! This is a masked sum. 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 + do j_dn=1,dL ; do i_dn=1,dL + ! ii and jj are the index locations on the full grid that contribute to the averages. + jj = j_dn + (dL*j + j0_off) ; ii = i_dn + (dL*i + i0_off) + wt(i_dn,j_dn) = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) + wtd_field(i_dn,j_dn) = field_in(ii,jj,k) * wt(i_dn,j_dn) 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) = square_sum(wtd_field(1:dL,1:dL), dL, naive) / & + (square_sum(wt(1:dL,1:dL), dL, naive) + 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 - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - 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 + II = dL*I + I0_off + (dL-1) + do j_dn=1,dL + jj = j_dn + (dL*j + j0_off) + if (diag_cs%OBC_u(II,jj) == 0) then ! This is not an OBC face. + h_face = 0.5*(diag_cs%h(ii,jj,k) + diag_cs%h(ii+1,jj,k)) + elseif (diag_cs%OBC_u(II,jj) < 0) then ! This is a western OBC face. + h_face = diag_cs%h(ii+1,jj,k) + else ! (diag_cs%OBC_u(II,jj) > 0) ! This is an eastern OBC face. + h_face = diag_cs%h(ii,jj,k) + endif + wt_1d(j_dn) = mask(II,jj,k) * diag_cs%G%dyCu(II,jj) * h_face + wtd_field_1d(j_dn) = field_in(II,jj,k) * wt_1d(j_dn) 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) = sum_1d(wtd_field_1d(1:dL), dL) / & + (sum_1d(wt_1d(1:dL), dL) + 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) - ave = 0.0 - ii=i0 - do jj=j0,j0+dl-1 - weight = mask(ii,jj,k) - ave = ave+field_in(ii,jj,k)*weight + II = dL*I + I0_off + (dL-1) + do j_dn=1,dL + jj = j_dn + (dL*j + j0_off) + wtd_field_1d(j_dn) = field_in(II,jj,k) * mask(II,jj,k) enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) + field_out(I,j,k) = sum_1d(wtd_field_1d(1:dL), dL) ! This is a masked sum. enddo ; enddo ; enddo - 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) - ave = 0.0 - jj=j0 - do ii=i0,i0+dl-1 - weight = mask(ii,jj,k) - ave = ave+field_in(ii,jj,k)*weight + elseif (method == SPS) then ! e.g. vmo + do k=ks,ke ; do J=jsv_d,jev_d ; do i=isv_d,iev_d + JJ = dL*J + J0_off + (dL-1) + do i_dn=1,dL + ii = i_dn + (dL*i + i0_off) + wtd_field_1d(i_dn) = field_in(ii,JJ,k) * mask(ii,JJ,k) enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) + field_out(i,J,k) = sum_1d(wtd_field_1d(1:dL), dL) ! This is a masked sum. enddo ; enddo ; enddo elseif (method == MPM) then - 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 - jj=j0 - 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 + do k=ks,ke ; do J=jsv_d,jev_d ; do i=isv_d,iev_d + JJ = dL*J + J0_off + (dL-1) + do i_dn=1,dL + ii = i_dn + (dL*i + i0_off) + if (diag_cs%OBC_v(ii,JJ) == 0) then ! This is not an OBC face. + h_face = 0.5*(diag_cs%h(ii,jj,k) + diag_cs%h(ii,jj+1,k)) + elseif (diag_cs%OBC_v(ii,JJ) < 0) then ! This is a southern OBC face. + h_face = diag_cs%h(ii,jj+1,k) + else ! (diag_cs%OBC_v(ii,JJ) > 0) ! This is a northern OBC face. + h_face = diag_cs%h(ii,jj,k) + endif + wt_1d(i_dn) = mask(ii,JJ,k) * diag_cs%G%dxCv(ii,JJ) * h_face + wtd_field_1d(i_dn) = field_in(ii,JJ,k) * wt_1d(i_dn) enddo - field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo ; enddo - elseif (method == MSK) then !The input field is a mask, subsample - 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) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - ave = ave+field_in(ii,jj,k) - enddo ; enddo - if (ave > 0.0) field_out(i,j,k)=1.0 + field_out(i,J,k) = sum_1d(wtd_field_1d(1:dL), dL) / & + (sum_1d(wt_1d(1:dL), dL) + eps_face) ! Eps_face avoids division by 0. enddo ; enddo ; enddo else write (mesg,*) " unknown sampling method: ",method @@ -4533,10 +4770,10 @@ 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] + real, dimension(:,:), pointer :: mask !< Mask for input field [nondim] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: isv_o !< Original i-start index @@ -4545,26 +4782,41 @@ 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, i_dn, j_dn, i0, j0, f1, f2, f_in1, f_in2 + integer :: ii, jj ! The index locations on the full grid that contribute to the averages. + integer :: i0_off, j0_off ! The starting point offsets between full array and reduced array + ! indices when i or j is 0. + real :: wt(dL,dL) ! 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 :: wtd_field(dL,dL) ! The weighted field to sum, 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 :: wt_1d(dL) ! 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 :: wtd_field_1d(dL) ! The weighted field to sum, 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 :: ave ! The running sum of the average, in [A ~> a] or [A L2 ~> a m2] real :: weight ! The nondimensional or area-weighted weight for an input value [nondim] or [L2 ~> m2] real :: total_weight ! The sum of weights contributing to a point [nondim] or [L2 ~> m2] real :: eps_area ! A negligibly small area [L2 ~> m2] real :: eps_len ! A negligibly small horizontal length [L ~> m] + logical :: naive ! If true, use naive rotatially variant sums to reproduct previous answers. eps_len = 1.0e-20 * diag_cs%G%US%m_to_L eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2 + naive = .not.diag_CS%symmetric_downsample_sums + ! 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 - f2 = f_in2/dl + f1 = f_in1 / dL + f2 = f_in2 / dL ! Correction for the symmetric case if (diag_cs%G%symmetric) then f1 = f1 + mod(f_in1,dl) @@ -4572,94 +4824,70 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d endif allocate(field_out(1:f1,1:f2)) + ! These are the starting point offsets between full array and reduced array indices when i or j is 0. + i0_off = (isv_o-1) - dL*isv_d + j0_off = (jsv_o-1) - dL*jsv_d + if (method == MMP) then 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)*diag_cs%G%areaT(ii,jj) - total_weight = total_weight + weight - ave = ave+field_in(ii,jj)*weight + do j_dn=1,dL ; do i_dn=1,dL + ! ii and jj are the index locations on the full grid that contribute to the averages. + jj = j_dn + (dL*j + j0_off) ; ii = i_dn + (dL*i + i0_off) + wt(i_dn,j_dn) = mask(ii,jj) * diag_cs%G%areaT(ii,jj) + wtd_field(i_dn,j_dn) = field_in(ii,jj) * wt(i_dn,j_dn) 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) = square_sum(wtd_field(1:dL,1:dL), dL, naive) / & + (square_sum(wt(1:dL,1:dL), dL, naive) + 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 - i0 = isv_o+dl*(i-isv_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 + do j_dn=1,dL ; do i_dn=1,dL + jj = j_dn + (dL*j + j0_off) ; ii = i_dn + (dL*i + i0_off) + wtd_field(i_dn,j_dn) = field_in(ii,jj) * mask(ii,jj) enddo ; enddo - field_out(i,j) = ave !Masked Sum (total_weight=1) + field_out(i,j) = square_sum(wtd_field(1:dL,1:dL), dL, naive) ! This is a masked sum. enddo ; enddo elseif (method == PSP) then ! e.g., umo_2d - 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 - ii=i0 - do jj=j0,j0+dl-1 - weight = mask(ii,jj) - ave = ave+field_in(ii,jj)*weight + do j=jsv_d,jev_d ; do I=isv_d,iev_d + II = dL*I + i0_off + (dL-1) + do j_dn=1,dL + jj = j_dn + (dL*j + j0_off) + wtd_field_1d(j_dn) = field_in(II,jj) * mask(II,jj) enddo - field_out(i,j) = ave !Masked Sum (total_weight=1) + field_out(I,j) = sum_1d(wtd_field_1d(1:dL), dL) ! This is a masked sum. enddo ; enddo elseif (method == SPP) then ! e.g., vmo_2d - 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 - jj=j0 - do ii=i0,i0+dl-1 - weight = mask(ii,jj) - ave = ave+field_in(ii,jj)*weight + do J=jsv_d,jev_d ; do i=isv_d,iev_d + JJ = dL*J + J0_off + (dL-1) + do i_dn=1,dL + ii = i_dn + (dL*i + i0_off) + wtd_field_1d(i_dn) = field_in(ii,JJ) * mask(ii,JJ) enddo - field_out(i,j) = ave !Masked Sum (total_weight=1) + field_out(i,J) = sum_1d(wtd_field_1d(1:dL), dL) ! This is a masked sum. enddo ; enddo elseif (method == PMP) then - 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 - 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 + do j=jsv_d,jev_d ; do I=isv_d,iev_d + II = dL*I + I0_off + (dL-1) + do j_dn=1,dL + jj = j_dn + (dL*j + j0_off) + ! Should this weight include the total thickness interpolated to velocity points? + wt_1d(j_dn) = mask(II,jj) * diag_cs%G%dyCu(II,jj) + wtd_field_1d(j_dn) = field_in(II,jj) * wt_1d(j_dn) 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) = sum_1d(wtd_field_1d(1:dL), dL) / & + (sum_1d(wt_1d(1:dL), dL) + 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 - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - jj=j0 - do ii=i0,i0+dl-1 - weight = mask(ii,jj)* diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? - total_weight = total_weight +weight - ave = ave+field_in(ii,jj)*weight + do J=jsv_d,jev_d ; do i=isv_d,iev_d + JJ = dL*J + J0_off + (dL-1) + do i_dn=1,dL + ii = i_dn + (dL*i + i0_off) + ! Should this weight include the total thickness interpolated to velocity points? + wt_1d(i_dn) = mask(ii,JJ) * diag_cs%G%dxCv(ii,JJ) + wtd_field_1d(i_dn) = field_in(ii,JJ) * wt_1d(i_dn) enddo - field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo ; enddo - elseif (method == MSK) then !The input field is a mask, subsample - field_out(:,:) = 0.0 - 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 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - ave = ave+field_in(ii,jj) - enddo ; enddo - if (ave > 0.0) field_out(i,j)=1.0 + field_out(i,J) = sum_1d(wtd_field_1d(1:dL), dL) / & + (sum_1d(wt_1d(1:dL), dL) + Eps_len) ! Eps_len avoids division by 0. enddo ; enddo else write (mesg,*) " unknown sampling method: ",method @@ -4668,16 +4896,77 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d end subroutine downsample_field_2d -!> Allocate and compute the 2d down sampled mask +!> Do a rotationally symmetric sum of the elements of a 1-d array. +function sum_1d(field, sz) result(sum) + integer, intent(in) :: sz !< The size of the array to sum + real, intent(in) :: field(sz) !< 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, sz_2 + + if (sz == 2) then ! The order of arithmetic does not matter. + sum = field(1) + field(2) + elseif (sz == 3) then ! Use simpler code that has the same order of sums as the general case. + sum = field(2) + (field(1) + field(3)) + else + ! This is a copy of the general code from symmetric_sum_1d in MOM_array_transform + sz_2 = sz / 2 ! Note that for an odd number sz_2 is rounded down. + sum = 0.0 + if (2*sz_2 < sz) sum = field(sz_2+1) + ! Add pairs of values, working from the inside out. + do i=sz_2,1,-1 + sum = sum + (field(i) + field(sz+1-i)) + enddo + endif +end function sum_1d + +!> Return the sum of the elements of a square 2-d array, perhaps using a rotationally symmetric sum. +!! This could eventually wrap symmetric_sum, but for now it also can reproduce the previous answers. +function square_sum(field, sz, naive_sum) result(sum) + integer, intent(in) :: sz !< The size of the array along each axis + real, intent(in) :: field(sz, sz) !< The field to sum in arbitrary units [A ~> a] + logical, optional, intent(in) :: naive_sum !< If true, sum the elements in the order they appear in memory. + real :: sum !< The sum of the entries in field [A ~> a] + + ! Local variables + integer :: i, j + logical :: simple_sum + + simple_sum = .true. ; if (present(naive_sum)) simple_sum = naive_sum + + if (sz == 1) then + sum = field(1,1) + elseif (simple_sum) then + ! This non-rotationally symmetric sum is here to reproduce previous results. + sum = 0.0 + do j=1,sz ; do i=1,sz ; sum = sum + field(i,j) ; enddo ; enddo + elseif (sz == 2) then + ! This copy of code from symmetric_sum may facilitate inlining in a common case. + sum = (field(1,1) + field(2,2)) + (field(2,1) + field(1,2)) + elseif (sz == 3) then + ! This copy of code from symmetric_sum may facilitate inlining in a common case. + 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))) + else + sum = symmetric_sum(field(1:sz,1:sz)) + endif + +end function square_sum + + +!> Allocate and compute the 2d down sampled mask. !! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) -!! if at least one of the sub-cells are open, otherwise it's closed (0) -subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_o, & +!! if at least one of the sub-cells are open, otherwise it's closed (0), using the same points +!! that would appear in the downsampled sum, average or down-selection. +subroutine downsample_mask_2d(mask_in, mask_dsamp, dL, method, isc_o, jsc_o, isd_o, jsd_o, & isc_d, iec_d, jsc_d, jec_d, isd_d, ied_d, jsd_d, jed_d) integer, intent(in) :: isd_o !< Original data domain i-start index integer, intent(in) :: jsd_o !< Original data domain j-start index - real, dimension(isd_o:,jsd_o:), intent(in) :: field_in !< Original field to be down sampled in arbitrary units [A] - real, dimension(:,:), pointer :: field_out !< Down sampled field mask [nondim] - integer, intent(in) :: dl !< Level of down sampling + real, dimension(isd_o:,jsd_o:), intent(in) :: mask_in !< Original mask to be down sampled [nondim] + real, dimension(:,:), pointer :: mask_dsamp !< Down-sampled mask [nondim] + integer, intent(in) :: method !< Sampling method + integer, intent(in) :: dL !< Level of down sampling integer, intent(in) :: isc_o !< Original i-start index integer, intent(in) :: jsc_o !< Original j-start index integer, intent(in) :: isc_d !< Computational i-start index of down sampled data @@ -4688,33 +4977,80 @@ 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 - real :: tot_non_zero ! The sum of values in the down-scaled cell [A] + + ! Local variables + real :: tot_non_zero ! The sum of mask values in the down-scaled cell or face [nondim] + character(len=8) :: method_str + integer :: i, j, i_dn, j_dn + integer :: ii, jj ! The index locations on the full grid that contribute to the averages. + integer :: i0_off, j0_off ! The starting point offsets between full array and reduced array + ! indices when i or j is 0. + ! 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 - do j=jsc_d,jec_d ; do i=isc_d,iec_d - i0 = isc_o+dl*(i-isc_d) - j0 = jsc_o+dl*(j-jsc_d) - tot_non_zero = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - tot_non_zero = tot_non_zero + field_in(ii,jj) + allocate(mask_dsamp(isd_d:ied_d, jsd_d:jed_d), source=0.0) + + i0_off = ((isc_o-1) - dL*isc_d) + j0_off = ((jsc_o-1) - dL*jsc_d) + if ((method == MMM) .or. (method == MMP) .or. (method == MMS) .or. (method == SSS)) then + ! This applies at tracer points. + do j=jsc_d,jec_d ; do i=isc_d,iec_d + tot_non_zero = 0.0 + do j_dn=1,dL ; do i_dn=1,dL + ii = i_dn + (dL*i + i0_off) + jj = j_dn + (dL*j + j0_off) + tot_non_zero = tot_non_zero + abs(mask_in(ii,jj)) + enddo ; enddo + if (tot_non_zero > 0.0) mask_dsamp(i,j) = 1.0 enddo ; enddo - if (tot_non_zero > 0.0) field_out(i,j)=1.0 - enddo ; enddo + elseif ((method == PMM) .or. (method == PSP) .or. (method == PMP) .or. (method == PSS)) then + ! This applies at u-velocity points. + do j=jsc_d,jec_d ; do I=isc_d,iec_d + tot_non_zero = 0.0 + II = (dL*I + I0_off) + (dL-1) + do j_dn=1,dL + jj = j_dn + (dL*j + j0_off) + tot_non_zero = tot_non_zero + abs(mask_in(II,jj)) + enddo + if (tot_non_zero > 0.0) mask_dsamp(I,j) = 1.0 + enddo ; enddo + elseif ((method == MPM) .or. (method == SPP) .or. (method == MPP) .or. (method == SPS)) then + ! This applies at v-velocity points. + do J=jsc_d,jec_d ; do i=isc_d,iec_d + tot_non_zero = 0.0 + JJ = (dL*J + J0_off) + (dL-1) + do i_dn=1,dL + ii = i_dn + (dL*i + i0_off) + tot_non_zero = tot_non_zero + abs(mask_in(ii,JJ)) + enddo + if (tot_non_zero > 0.0) mask_dsamp(i,J) = 1.0 + enddo ; enddo + elseif ((method == PPP) .or. (method == PPM)) then + ! This applies at corner (vorticity) points. + do j=jsc_d,jec_d ; do I=isc_d,iec_d + II = (dL*I + I0_off) + (dL-1) + JJ = (dL*J + J0_off) + (dL-1) + if (abs(mask_in(II,JJ)) > 0.0) mask_dsamp(I,J) = 1.0 + enddo ; enddo + else + write(method_str, '(I0)') method + call MOM_error(FATAL, "downsample_mask_2d: unknown sampling method "//trim(method_str)) + endif + end subroutine downsample_mask_2d -!> Allocate and compute the 3d down sampled mask + +!> Allocate and compute the 3d down sampled mask. !! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) -!! if at least one of the sub-cells are open, otherwise it's closed (0) -subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_o, & +!! if at least one of the sub-cells are open, otherwise it's closed (0), using the same points +!! that would appear in the downsampled sum, average or down-selection. +subroutine downsample_mask_3d(mask_in, mask_dsamp, dL, method, isc_o, jsc_o, isd_o, jsd_o, & isc_d, iec_d, jsc_d, jec_d, isd_d, ied_d, jsd_d, jed_d) integer, intent(in) :: isd_o !< Original data domain i-start index integer, intent(in) :: jsd_o !< Original data domain j-start index - real, dimension(isd_o:,jsd_o:,:), intent(in) :: field_in !< Original field to be down sampled in arbitrary units [A] - real, dimension(:,:,:), pointer :: field_out !< down sampled field mask [nondim] - integer, intent(in) :: dl !< Level of down sampling + real, dimension(isd_o:,jsd_o:,:), intent(in) :: mask_in !< Original mask to be down sampled [nondim] + real, dimension(:,:,:), pointer :: mask_dsamp !< Down-sampled mask [nondim] + integer, intent(in) :: dL !< Level of down sampling + integer, intent(in) :: method !< Sampling method integer, intent(in) :: isc_o !< Original i-start index integer, intent(in) :: jsc_o !< Original j-start index integer, intent(in) :: isc_d !< Computational i-start index of down sampled data @@ -4725,24 +5061,69 @@ 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 - real :: tot_non_zero ! The sum of values in the down-scaled cell [A] + + ! Local variables + real :: tot_non_zero ! The sum of mask values in the down-scaled cell or face [nondim] + character(len=8) :: method_str + integer :: i, j, i_dn, j_dn, k, ks, ke + integer :: ii, jj ! The index locations on the full grid that contribute to the averages. + integer :: i0_off, j0_off ! The starting point offsets between full array and reduced array + ! indices when i or j is 0. + ! 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)) - field_out(:,:,:) = 0.0 - do k=ks,ke ; do j=jsc_d,jec_d ; do i=isc_d,iec_d - i0 = isc_o+dl*(i-isc_d) - j0 = jsc_o+dl*(j-jsc_d) - tot_non_zero = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - tot_non_zero = tot_non_zero + field_in(ii,jj,k) - enddo ; enddo - if (tot_non_zero > 0.0) field_out(i,j,k)=1.0 - enddo ; enddo ; enddo + ks = lbound(mask_in, 3) ; ke = ubound(mask_in, 3) + allocate(mask_dsamp(isd_d:ied_d, jsd_d:jed_d, ks:ke), source=0.0) + + i0_off = ((isc_o-1) - dL*isc_d) + j0_off = ((jsc_o-1) - dL*jsc_d) + if ((method == MMM) .or. (method == MMP) .or. (method == MMS) .or. (method == SSS)) then + ! This applies at tracer points. + do k=ks,ke ; do j=jsc_d,jec_d ; do i=isc_d,iec_d + tot_non_zero = 0.0 + do j_dn=1,dL ; do i_dn=1,dL + ii = i_dn + (dL*i + i0_off) + jj = j_dn + (dL*j + j0_off) + tot_non_zero = tot_non_zero + abs(mask_in(ii,jj,k)) + enddo ; enddo + if (tot_non_zero > 0.0) mask_dsamp(i,j,k) = 1.0 + enddo ; enddo ; enddo + elseif ((method == PMM) .or. (method == PSP) .or. (method == PMP) .or. (method == PSS)) then + ! This applies at u-velocity points. + do k=ks,ke ; do j=jsc_d,jec_d ; do I=isc_d,iec_d + tot_non_zero = 0.0 + II = (dL*I + I0_off) + (dL-1) + do j_dn=1,dL + jj = j_dn + (dL*j + j0_off) + tot_non_zero = tot_non_zero + abs(mask_in(II,jj,k)) + enddo + if (tot_non_zero > 0.0) mask_dsamp(I,j,k) = 1.0 + enddo ; enddo ; enddo + elseif ((method == MPM) .or. (method == SPP) .or. (method == MPP) .or. (method == SPS)) then + ! This applies at v-velocity points. + do k=ks,ke ; do J=jsc_d,jec_d ; do i=isc_d,iec_d + tot_non_zero = 0.0 + JJ = (dL*J + J0_off) + (dL-1) + do i_dn=1,dL + ii = i_dn + (dL*i + i0_off) + tot_non_zero = tot_non_zero + abs(mask_in(ii,JJ,k)) + enddo + if (tot_non_zero > 0.0) mask_dsamp(i,J,k) = 1.0 + enddo ; enddo ; enddo + elseif ((method == PPP) .or. (method == PPM)) then + ! This applies at corner (vorticity) points. + do k=ks,ke ; do j=jsc_d,jec_d ; do I=isc_d,iec_d + II = (dL*I + I0_off) + (dL-1) + JJ = (dL*J + J0_off) + (dL-1) + if (abs(mask_in(II,JJ,k)) > 0.0) mask_dsamp(I,J,k) = 1.0 + enddo ; enddo ; enddo + else + write(method_str, '(I0)') method + call MOM_error(FATAL, "downsample_mask_3d: unknown sampling method "//trim(method_str)) + endif + end subroutine downsample_mask_3d + !> 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) @@ -4759,4 +5140,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 c63e50ef9b..dc05fb1c48 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -378,7 +378,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe end subroutine diag_remap_update !> Remap diagnostic field to alternative vertical grid. -subroutine diag_remap_do_remap(remap_cs, G, GV, US, h, staggered_in_x, staggered_in_y, & +subroutine diag_remap_do_remap(remap_cs, G, GV, US, h, OBC_u, OBC_v, staggered_in_x, staggered_in_y, & mask, field, remapped_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -386,6 +386,14 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, US, h, staggered_in_x, staggered type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], !! depending on the value of remap_CS%Z_based_coord + integer, dimension(:,:), intent(in) :: OBC_u !< An array that indicates the presence and direction + !! of any open boundary conditions at u-points, + !! with a value of 0 for no OBC, 1 for an Eastern OBC + !! or -1 for a Western OBC + integer, dimension(:,:), intent(in) :: OBC_v !< An array that indicates the presence and direction + !! of any open boundary conditions at v-points, + !! with a value of 0 for no OBC, 1 for a Northern OBC + !! or -1 for a Southern OBC logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. @@ -403,17 +411,17 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, US, h, staggered_in_x, staggered jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB if (associated(mask)) then - call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, OBC_u, OBC_v, staggered_in_x, staggered_in_y, & field, remapped_field, mask(:,:,1)) else - call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, OBC_u, OBC_v, staggered_in_x, staggered_in_y, & field, remapped_field) endif end subroutine diag_remap_do_remap !> The internal routine to remap a diagnostic field to an alternative vertical grid. -subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & +subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, OBC_u, OBC_v, staggered_in_x, staggered_in_y, & field, remapped_field, mask) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -424,6 +432,16 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere real, dimension(G%isd:,G%jsd:,:), & intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], !! depending on the value of remap_CS%Z_based_coord + integer, dimension(G%IsdB:,G%jsd:), & + intent(in) :: OBC_u !< An array that indicates the presence and direction + !! of any open boundary conditions at u-points, + !! with a value of 0 for no OBC, 1 for an Eastern OBC + !! or -1 for a Western OBC + integer, dimension(G%isd:,G%JsdB:), & + intent(in) :: OBC_v !< An array that indicates the presence and direction + !! of any open boundary conditions at v-points, + !! with a value of 0 for no OBC, 1 for a Northern OBC + !! or -1 for a Southern OBC logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(isdf:,jsdf:,:), & @@ -447,15 +465,31 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere ! U-points if (present(mask)) then do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.) then - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + if (OBC_u(I,j) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5*(remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + elseif (OBC_u(I,j) < 0) then ! This is a western OBC face. + h_src(:) = h(i+1,j,:) + h_dest(:) = remap_cs%h(i+1,j,:) + else ! (OBC_u(I,j) > 0) ! This is a eastern OBC face. + h_src(:) = h(i,j,:) + h_dest(:) = remap_cs%h(i,j,:) + endif call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & nz_dest, h_dest(:), remapped_field(I,j,:)) endif ; enddo ; enddo else do j=G%jsc,G%jec ; do I=G%IscB,G%IecB - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + if (OBC_u(I,j) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5*(remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + elseif (OBC_u(I,j) < 0) then ! This is a western OBC face. + h_src(:) = h(i+1,j,:) + h_dest(:) = remap_cs%h(i+1,j,:) + else ! (OBC_u(I,j) > 0) ! This is a eastern OBC face. + h_src(:) = h(i,j,:) + h_dest(:) = remap_cs%h(i,j,:) + endif call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & nz_dest, h_dest(:), remapped_field(I,j,:)) enddo ; enddo @@ -464,15 +498,31 @@ subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggere ! V-points if (present(mask)) then do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(i,j) > 0.) then - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + if (OBC_v(i,J) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5*(remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + elseif (OBC_v(i,J) < 0) then ! This is a southern OBC face + h_src(:) = h(i,j+1,:) + h_dest(:) = remap_cs%h(i,j+1,:) + else ! (OBC_v(i,J) > 0) ! This is a northern OBC face + h_src(:) = h(i,j,:) + h_dest(:) = remap_cs%h(i,j,:) + endif call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & nz_dest, h_dest(:), remapped_field(i,J,:)) endif ; enddo ; enddo else do J=G%jscB,G%jecB ; do i=G%isc,G%iec - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + if (OBC_v(i,J) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5*(remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + elseif (OBC_v(i,J) < 0) then ! This is a southern OBC face + h_src(:) = h(i,j+1,:) + h_dest(:) = remap_cs%h(i,j+1,:) + else ! (OBC_v(i,J) > 0) ! This is a northern OBC face + h_src(:) = h(i,j,:) + h_dest(:) = remap_cs%h(i,j,:) + endif call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & nz_dest, h_dest(:), remapped_field(i,J,:)) enddo ; enddo @@ -543,12 +593,20 @@ subroutine diag_remap_calc_hmask(remap_cs, G, mask) end subroutine diag_remap_calc_hmask !> Vertically re-grid an already vertically-integrated diagnostic field to alternative vertical grid. -subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered_in_x, staggered_in_y, & - mask, field, reintegrated_field) +subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, OBC_u, OBC_v, & + staggered_in_x, staggered_in_y, mask, field, reintegrated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] or [Z ~> m] real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] or [Z ~> m] + integer, dimension(:,:), intent(in) :: OBC_u !< An array that indicates the presence and direction + !! of any open boundary conditions at u-points, + !! with a value of 0 for no OBC, 1 for an Eastern OBC + !! or -1 for a Western OBC + integer, dimension(:,:), intent(in) :: OBC_v !< An array that indicates the presence and direction + !! of any open boundary conditions at v-points, + !! with a value of 0 for no OBC, 1 for a Northern OBC + !! or -1 for a Southern OBC logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. Note that because this @@ -567,19 +625,19 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB if (associated(mask)) then - call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & - field, reintegrated_field, mask(:,:,1)) + call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, OBC_u, OBC_v, & + staggered_in_x, staggered_in_y, field, reintegrated_field, mask(:,:,1)) else - call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & - field, reintegrated_field) + call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, OBC_u, OBC_v, & + staggered_in_x, staggered_in_y, field, reintegrated_field) endif end subroutine vertically_reintegrate_diag_field !> The internal routine to vertically re-grid an already vertically-integrated diagnostic field to !! an alternative vertical grid. -subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & - field, reintegrated_field, mask) +subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, OBC_u, OBC_v, & + staggered_in_x, staggered_in_y, field, reintegrated_field, mask) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure integer, intent(in) :: isdf !< The starting i-index in memory for field @@ -588,6 +646,16 @@ subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, st intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] or [Z ~> m] real, dimension(G%isd:,G%jsd:,:), & intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] or [Z ~> m] + integer, dimension(G%IsdB:,G%jsd:), & + intent(in) :: OBC_u !< An array that indicates the presence and direction + !! of any open boundary conditions at u-points, + !! with a value of 0 for no OBC, 1 for an Eastern OBC + !! or -1 for a Western OBC + integer, dimension(G%isd:,G%JsdB:), & + intent(in) :: OBC_v !< An array that indicates the presence and direction + !! of any open boundary conditions at v-points, + !! with a value of 0 for no OBC, 1 for a Northern OBC + !! or -1 for a Southern OBC logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(isdf:,jsdf:,:), & @@ -611,15 +679,31 @@ subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, st ! U-points if (present(mask)) then do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.0) then - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i+1,j,:)) + if (OBC_u(I,j) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5*(h_target(i,j,:) + h_target(i+1,j,:)) + elseif (OBC_u(I,j) < 0) then ! This is a western OBC face + h_src(:) = h(i+1,j,:) + h_dest(:) = h_target(i+1,j,:) + else ! (OBC_u(I,j) > 0) ! This is an eastern OBC face + h_src(:) = h(i,j,:) + h_dest(:) = h_target(i,j,:) + endif call reintegrate_column(nz_src, h_src, field(I,j,:), & nz_dest, h_dest, reintegrated_field(I,j,:)) endif ; enddo ; enddo else do j=G%jsc,G%jec ; do I=G%IscB,G%IecB - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i+1,j,:)) + if (OBC_u(I,j) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5*(h_target(i,j,:) + h_target(i+1,j,:)) + elseif (OBC_u(I,j) < 0) then ! This is a western OBC face + h_src(:) = h(i+1,j,:) + h_dest(:) = h_target(i+1,j,:) + else ! (OBC_u(I,j) > 0) ! This is an eastern OBC face + h_src(:) = h(i,j,:) + h_dest(:) = h_target(i,j,:) + endif call reintegrate_column(nz_src, h_src, field(I,j,:), & nz_dest, h_dest, reintegrated_field(I,j,:)) enddo ; enddo @@ -628,15 +712,31 @@ subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, st ! V-points if (present(mask)) then do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(i,J) > 0.0) then - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i,j+1,:)) + if (OBC_v(i,J) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5*(h_target(i,j,:) + h_target(i,j+1,:)) + elseif (OBC_v(i,J) < 0) then ! This is a southern OBC face + h_src(:) = h(i,j+1,:) + h_dest(:) = h_target(i,j+1,:) + else ! (OBC_v(i,J) > 0) ! This is a northern OBC face + h_src(:) = h(i,j,:) + h_dest(:) = h_target(i,j,:) + endif call reintegrate_column(nz_src, h_src, field(i,J,:), & nz_dest, h_dest, reintegrated_field(i,J,:)) endif ; enddo ; enddo else do J=G%jscB,G%jecB ; do i=G%isc,G%iec - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i,j+1,:)) + if (OBC_v(i,J) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5*(h_target(i,j,:) + h_target(i,j+1,:)) + elseif (OBC_v(i,J) < 0) then ! This is a southern OBC face + h_src(:) = h(i,j+1,:) + h_dest(:) = h_target(i,j+1,:) + else ! (OBC_v(i,J) > 0) ! This is a northern OBC face + h_src(:) = h(i,j,:) + h_dest(:) = h_target(i,j,:) + endif call reintegrate_column(nz_src, h_src, field(i,J,:), & nz_dest, h_dest, reintegrated_field(i,J,:)) enddo ; enddo @@ -661,12 +761,20 @@ subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, st end subroutine vertically_reintegrate_field !> Vertically interpolate diagnostic field to alternative vertical grid. -subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, staggered_in_y, & +subroutine vertically_interpolate_diag_field(remap_cs, G, h, OBC_u, OBC_v, staggered_in_x, staggered_in_y, & mask, field, interpolated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], !! depending on the value of remap_cs%Z_based_coord + integer, dimension(:,:), intent(in) :: OBC_u !< An array that indicates the presence and direction + !! of any open boundary conditions at u-points, + !! with a value of 0 for no OBC, 1 for an Eastern OBC + !! or -1 for a Western OBC + integer, dimension(:,:), intent(in) :: OBC_v !< An array that indicates the presence and direction + !! of any open boundary conditions at v-points, + !! with a value of 0 for no OBC, 1 for a Northern OBC + !! or -1 for a Southern OBC logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. Note that because this @@ -685,18 +793,18 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB if (associated(mask)) then - call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, OBC_u, OBC_v, staggered_in_x, staggered_in_y, & field, interpolated_field, mask(:,:,1)) else - call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, OBC_u, OBC_v, staggered_in_x, staggered_in_y, & field, interpolated_field) endif end subroutine vertically_interpolate_diag_field !> Internal routine to vertically interpolate a diagnostic field to an alternative vertical grid. -subroutine vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & - field, interpolated_field, mask) +subroutine vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, OBC_u, OBC_v, & + staggered_in_x, staggered_in_y, field, interpolated_field, mask) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure integer, intent(in) :: isdf !< The starting i-index in memory for field @@ -704,6 +812,16 @@ subroutine vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in real, dimension(G%isd:,G%jsd:,:), & intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], !! depending on the value of remap_cs%Z_based_coord + integer, dimension(G%IsdB:,G%jsd:), & + intent(in) :: OBC_u !< An array that indicates the presence and direction + !! of any open boundary conditions at u-points, + !! with a value of 0 for no OBC, 1 for an Eastern OBC + !! or -1 for a Western OBC + integer, dimension(G%isd:,G%JsdB:), & + intent(in) :: OBC_v !< An array that indicates the presence and direction + !! of any open boundary conditions at v-points, + !! with a value of 0 for no OBC, 1 for a Northern OBC + !! or -1 for a Southern OBC logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(isdf:,jsdf:,:), & @@ -728,15 +846,31 @@ subroutine vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in ! U-points if (present(mask)) then do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.0) then - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + if (OBC_u(I,j) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5*(remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + elseif (OBC_u(I,j) < 0) then ! This is a western OBC face. + h_src(:) = h(i+1,j,:) + h_dest(:) = remap_cs%h(i+1,j,:) + else ! (OBC_u(I,j) > 0) ! This is a eastern OBC face. + h_src(:) = h(i,j,:) + h_dest(:) = remap_cs%h(i,j,:) + endif call interpolate_column(nz_src, h_src, field(I,j,:), & nz_dest, h_dest, interpolated_field(I,j,:), .true.) endif ; enddo ; enddo else do j=G%jsc,G%jec ; do I=G%IscB,G%IecB - h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + if (OBC_u(I,j) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5*(remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + elseif (OBC_u(I,j) < 0) then ! This is a western OBC face. + h_src(:) = h(i+1,j,:) + h_dest(:) = remap_cs%h(i+1,j,:) + else ! (OBC_u(I,j) > 0) ! This is a eastern OBC face. + h_src(:) = h(i,j,:) + h_dest(:) = remap_cs%h(i,j,:) + endif call interpolate_column(nz_src, h_src, field(I,j,:), & nz_dest, h_dest, interpolated_field(I,j,:), .true.) enddo ; enddo @@ -745,15 +879,31 @@ subroutine vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in ! V-points if (present(mask)) then do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(I,j) > 0.0) then - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + if (OBC_v(i,J) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5*(remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + elseif (OBC_v(i,J) < 0) then ! This is a southern OBC face + h_src(:) = h(i,j+1,:) + h_dest(:) = remap_cs%h(i,j+1,:) + else ! (OBC_v(i,J) > 0) ! This is a northern OBC face + h_src(:) = h(i,j,:) + h_dest(:) = remap_cs%h(i,j,:) + endif call interpolate_column(nz_src, h_src, field(i,J,:), & nz_dest, h_dest, interpolated_field(i,J,:), .true.) endif ; enddo ; enddo else do J=G%jscB,G%jecB ; do i=G%isc,G%iec - h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + if (OBC_v(i,J) == 0) then ! This is not an OBC face. + h_src(:) = 0.5*(h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5*(remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + elseif (OBC_v(i,J) < 0) then ! This is a southern OBC face + h_src(:) = h(i,j+1,:) + h_dest(:) = remap_cs%h(i,j+1,:) + else ! (OBC_v(i,J) > 0) ! This is a northern OBC face + h_src(:) = h(i,j,:) + h_dest(:) = remap_cs%h(i,j,:) + endif call interpolate_column(nz_src, h_src, field(i,J,:), & nz_dest, h_dest, interpolated_field(i,J,:), .true.) enddo ; enddo diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 859072c9d6..8335fb75af 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -789,9 +789,9 @@ function auto_determine_io_layout(idiv, jdiv, nio) result(best_io_layout) if (ratio_diff < min_ratio_diff) then min_ratio_diff = ratio_diff best_io_layout = [io_layout(1), io_layout(2)] - end if - end if - end do + endif + endif + enddo end function auto_determine_io_layout diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index edbf022fe7..d72d877b98 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -94,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]. @@ -109,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]. @@ -159,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 @@ -244,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) @@ -254,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) @@ -292,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) @@ -335,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) @@ -437,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) @@ -473,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 @@ -480,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 @@ -497,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 @@ -521,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) @@ -536,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_error_handler.F90 b/src/framework/MOM_error_handler.F90 index eb097b32f0..9bbf0fc3ab 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -49,6 +49,8 @@ module MOM_error_handler ! Also note that this is a module variable rather than contained in ! a type passed by argument (preferred for most data) for convenience ! and to reduce obfuscation of code +logical :: verbosity_set = .false. +!< True if the verbosity has already been set at run-time. integer :: callTreeIndentLevel = 0 !< The level of calling within the call tree @@ -205,14 +207,20 @@ subroutine loc_MOM_err(level, message) end subroutine loc_MOM_err !> This subroutine sets the level of verbosity filtering MOM error messages -subroutine MOM_set_verbosity(verb) +subroutine MOM_set_verbosity(verb, may_reset) integer, intent(in) :: verb !< A level of verbosity to set + logical, optional, intent(in) :: may_reset !< If true, set the verbosity even if it has been set + !! before, perhaps by another component like SIS2. character(len=80) :: msg - if (verb>0 .and. verb<10) then - verbosity=verb + if (verb>=0 .and. verb<10) then + if (.not.verbosity_set) verbosity = verb + if (present(may_reset)) then + if (may_reset) verbosity = verb + endif + verbosity_set = .true. else - write(msg(1:80),'("Attempt to set verbosity outside of range (0-9). verb=",I0)') verb - call MOM_error(FATAL,msg) + write(msg,'("Attempt to set verbosity outside of range (0-9). verb=",I0)') verb + call MOM_error(FATAL, msg) endif end subroutine MOM_set_verbosity diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 1504fc67d5..501629491a 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -571,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) @@ -1061,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 @@ -1102,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))//"'"//& @@ -1112,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 @@ -1164,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. @@ -1416,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) @@ -1452,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) @@ -1570,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) @@ -1605,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_hor_index.F90 b/src/framework/MOM_hor_index.F90 index efd8731d0d..2bc832e90a 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -57,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 4af288ae1d..12a0b60197 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -18,7 +18,7 @@ module MOM_horizontal_regridding use MOM_interpolate, only : time_interp_external use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_interp_infra, only : horiz_interp_type, horizontal_interp_init -use MOM_interp_infra, only : get_external_field_info +use MOM_interpolate, only : get_external_field_info use MOM_interp_infra, only : external_field use MOM_time_manager, only : time_type use MOM_io, only : axis_info, get_axis_info, get_var_axes_info, MOM_read_data @@ -212,13 +212,6 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, aout(i,j) = prev(i,j) fill_pts(i,j) = 0.0 endif ; enddo ; enddo - elseif (nfill == nfill_prev) then - call MOM_error(WARNING, & - 'Unable to fill missing points using either data at the same vertical level from a connected basin'//& - 'or using a point from a previous vertical level. Make sure that the original data has some valid'//& - 'data in all basins.', .true.) - write(mesg,*) 'nfill=',nfill - call MOM_error(WARNING, mesg, .true.) endif ! Determine the number of remaining points to fill globally. diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 074b00c3a8..1ef2618ab3 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -9,9 +9,13 @@ module MOM_interpolate use MOM_error_handler, only : MOM_error, FATAL use MOM_interp_infra, only : time_interp_extern, init_external_field=>init_extern_field use MOM_interp_infra, only : time_interp_external_init=>time_interp_extern_init -use MOM_interp_infra, only : horiz_interp_type, get_external_field_info +use MOM_interp_infra, only : horiz_interp_type +use MOM_interp_infra, only : get_external_field_info_infra => get_external_field_info use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_interp_infra, only : external_field +use MOM_io_infra, only : axistype +use MOM_io_infra, only : get_axis_size, get_axis_data +use MOM_io, only : axis_info, set_axis_info use MOM_time_manager, only : time_type, set_date, operator(+), operator(<), operator(>) implicit none ; private @@ -28,7 +32,8 @@ module MOM_interpolate type(time_type) :: m2d_offset !< add to model time to get data time end type forcing_timeseries_dataset -public :: time_interp_external, init_external_field, time_interp_external_init, get_external_field_info +public :: time_interp_external, init_external_field, time_interp_external_init +public :: get_external_field_info public :: horiz_interp_type, run_horiz_interp, build_horiz_interp_weights public :: external_field public :: forcing_timeseries_set_time_type_vars @@ -279,4 +284,46 @@ function map_model_time_to_forcing_time(Time, forcing_dataset) end function map_model_time_to_forcing_time + +subroutine get_external_field_info(field, size, axes, missing) + type(external_field), intent(in) :: field + !< Handle for time interpolated external field returned from a previous + !! call to init_external_field() + integer, optional, intent(inout) :: size(4) + !< Dimension sizes for the input data + type(axis_info), optional, intent(inout) :: axes(4) + !< Axis types for the input data + real, optional, intent(inout) :: missing + !< Missing value for the input data + + type(axistype) :: axes_infra(4) + ! Axis as represented in the infra + character(len=256) :: axis_name + ! Axis name + real, allocatable :: ax_data(:) + ! Axis points + + integer :: n + ! Axis index + integer :: ax_size + ! Axis size + + if (present(axes)) then + call get_external_field_info_infra(field, size=size, axes=axes_infra, & + missing=missing) + ! TODO: Most of these methods were written to expect four dimensions. + do n=1,4 + ! Convert axistype to axis_info + ax_size = get_axis_size(axes_infra(n)) + allocate(ax_data(ax_size)) + call get_axis_data(axes_infra(n), axis_name, ax_data) + call set_axis_info(axes(n), trim(axis_name), ax_data=ax_data) + deallocate(ax_data) + enddo + else + call get_external_field_info_infra(field, size=size, missing=missing) + endif +end subroutine get_external_field_info + + end module MOM_interpolate diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index a66e007a7b..778d68bdf3 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -3,7 +3,7 @@ ! SPDX-License-Identifier: Apache-2.0 !> A module with intrinsic functions that are used by MOM but are not supported -!! by some compilers. +!! by some compilers. module MOM_intrinsic_functions use iso_fortran_env, only : stdout => output_unit, stderr => error_unit @@ -117,42 +117,65 @@ end function cuberoot !> Rescale `a` to the range [0.125, 1) and compute its cube-root exponent. +!! +!! This function decomposes `a` into the form `s * x * 2**e` so that `x` is +!! in the desired range. This is accomplished by computing the integral cube +!! root of `e` (as a division) and applying the residual to `x`. 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 number to be rescaled for cube-root computation [A3] real, intent(out) :: x - !< The rescaled value of a in the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3] + !< The rescaled value of `a` in the range [0.125, 1) [B3] integer(kind=int64), intent(out) :: e_r - !< Cube root of the exponent of the rescaling of `a` + !< The integral component of the cube-root exponent of `a`. integer(kind=int64), intent(out) :: s_a - !< The sign bit of a + !< Sign bit of `a`. A nonzero value indicates negative sign. integer(kind=int64) :: xb - ! Floating point value of a, bit-packed as an integer + ! Floating point integer representation of `a` integer(kind=int64) :: e_a - ! Unscaled exponent of a + ! Exponent of `a` integer(kind=int64) :: e_x - ! Exponent of x - integer(kind=int64) :: e_div, e_mod - ! Quotient and remainder of e in e = 3*(e/3) + modulo(e,3). + ! Exponent of `x` ! Pack bits of a into xb and extract its exponent and sign. xb = transfer(a, 1_int64) s_a = ibits(xb, signbit, 1) e_a = ibits(xb, expbit, explen) - bias - ! Compute terms of exponent decomposition e = 3*(e/3) + modulo(e,3). - ! (Fortran division is round-to-zero, so we must emulate floor division.) - e_mod = modulo(e_a, 3_int64) - e_div = (e_a - e_mod)/3 - - ! Our scaling decomposes e_a into e = {3*(e/3) + 3} + {modulo(e,3) - 3}. - - ! The first term is a perfect cube, whose cube root is computed below. - e_r = e_div + 1 - - ! The second term ensures that x is shifted to [0.125, 1). - e_x = e_mod - 3 + ! The floating-point form of `a` with exponent `e` is + ! + ! a = s * (1 + m) * 2**e + ! + ! where (1+m) ∈ [1,2). We want to split 2**e so that (1+m) is rescaled to + ! the range [0.125, 1); that is, [2**-3, 2**0). + ! + ! First decompose the exponent `e` into quotient-remainder form: + ! + ! e = 3⌊e/3⌋ + modulo(e,3) + ! + ! Since modulo(e,3) ∈ {0,1,2}, the second term of the following expression is + ! in {-3,-2,-1}. + ! + ! e = 3 * (⌊e/3⌋ + 1) + (modulo(e,3) - 3). + ! + ! Here, (modulo(e,3) - 3) is in the range [2**-3, 1) and holds the + ! floating-point exponent of `x`. + ! + ! Fortran integer division is round-to-zero. To convert to floor division, + ! we use the sign() intrinsic to shift negative values downward. + ! + ! ⌊e/3⌋ = (e + sign(1,e) - 1) / 3 + ! + ! ⌊e/3⌋ + 1 reduces to the form below. This is what we call the integral + ! cube-root of `a` in the description above. + + e_r = (e_a + sign(1_int64, e_a) + 2) / 3 + + ! modulo() is not implemented on all systems, so compute the remainder as + ! r = n - 3*q. + + e_x = e_a - e_r * 3 ! Insert the new 11-bit exponent into xb and write to x and extend the ! bitcount to 12, so that the sign bit is zero and x is always positive. @@ -170,7 +193,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 a2632c7562..a425a7a759 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -3081,8 +3081,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.") diff --git a/src/framework/MOM_netcdf.F90 b/src/framework/MOM_netcdf.F90 index 66ec1e194c..a3cfcad113 100644 --- a/src/framework/MOM_netcdf.F90 +++ b/src/framework/MOM_netcdf.F90 @@ -801,7 +801,7 @@ subroutine check_netcdf_call(ncerr, header, message) character(len=:), allocatable :: errmsg ! Full error message, including netCDF message - if (ncerr /= nf90_noerr) then + if (ncerr /= NF90_NOERR) then errmsg = trim(header) // ": " // trim(message) // new_line('/') & // trim(nf90_strerror(ncerr)) call MOM_error(FATAL, errmsg) diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index e21bbcae61..9cd774cf88 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -232,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 @@ -261,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 @@ -292,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_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 10671c135d..d890104c23 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -19,6 +19,8 @@ module MOM_string_functions public extract_real public remove_spaces public slasher +public trim_trailing_commas +public ints_to_string contains @@ -216,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/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index bdde9ba6e4..a6d999f1cf 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -31,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 @@ -42,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 @@ -82,6 +82,9 @@ 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 +public initialize_ice_SMB +public update_ice_smb ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -129,9 +132,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 @@ -197,19 +200,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, & @@ -231,6 +235,10 @@ module MOM_ice_shelf id_Gr_t_area = -1, id_Gr_g_area = -1, id_Gr_f_area = -1 !>@} + type(external_field) :: smb_file + !< Handle for reading the time interpolated smb from a file + logical :: time_varying_smb + !< logical flag set true if reading time-varying smb type(external_field) :: mass_handle !< Handle for reading the time interpolated ice shelf mass from a file type(external_field) :: area_handle @@ -297,12 +305,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]. @@ -321,7 +330,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] @@ -330,34 +340,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.") @@ -368,7 +386,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 @@ -397,9 +415,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 @@ -457,7 +476,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 @@ -489,7 +512,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 @@ -505,11 +529,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 @@ -559,68 +584,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 @@ -691,7 +800,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 @@ -723,10 +832,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 @@ -735,7 +854,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)) @@ -743,7 +861,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)) @@ -754,8 +872,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 !!!!!!!!!!!!!!!!!!! @@ -763,11 +881,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 @@ -825,14 +947,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) @@ -859,10 +981,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) @@ -878,6 +1004,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 @@ -891,31 +1070,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 @@ -1141,7 +1320,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]. @@ -1218,15 +1397,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) @@ -1250,7 +1429,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 @@ -1380,10 +1559,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" @@ -1394,12 +1575,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, logical :: showCallTree logical :: read_TideAmp, debug logical :: global_indexing + 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=240) :: Tideamp_file ! Input file names character(len=80) :: tideamp_var ! Input file variable names real :: utide ! A tidal velocity [L T-1 ~> m s-1] real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting ! does not occur [Z ~> m] - real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data + real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for ice shelf input data [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: maskT ! Temporary array for the tracer points masks [nondim] type(surface), pointer :: sfc_state => NULL() type(vardesc) :: u_desc, v_desc @@ -1459,6 +1643,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. @@ -1480,6 +1670,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 @@ -1489,7 +1685,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 @@ -1635,7 +1831,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, & @@ -1689,11 +1885,16 @@ 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, "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_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=.not.enable_bugs) + 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) @@ -1807,8 +2008,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 @@ -1842,7 +2043,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) @@ -1888,8 +2090,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 @@ -2004,6 +2206,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) @@ -2359,6 +2563,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 @@ -2375,14 +2580,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) @@ -2461,12 +2665,31 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) end subroutine update_shelf_mass +!> Update the ice-shelf surface mass balance (SMB) field +subroutine update_ice_SMB(CS, G, SMB, Time) + type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to initialize_ice_shelf. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: SMB !< Ice surface mass balance parameter, often in [R Z T-1 ~> kg m-2 s-1] + type(time_type), intent(in) :: Time !< Current model time + + + if (CS%time_varying_smb) then + call time_interp_external(CS%smb_file, Time, SMB) + if (CS%debug) call hchksum(SMB, "update_ice_SMB", CS%Grid_in%HI, haloshift=0) + endif + + +end subroutine update_ice_SMB + + !> Save the ice shelf restart file subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_fluxes) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure type(ocean_grid_type), intent(in) :: G !< A pointer to an ocean grid control structure. real, optional, dimension(SZI_(G),SZJ_(G)), 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) @@ -2566,7 +2789,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 @@ -2576,7 +2799,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(:,:) @@ -2607,7 +2830,6 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) if (CS%smb_diag) dh_adott_sum(is:ie,js:je) = dh_adott_sum(is:ie,js:je) + & (ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je)) - remaining_time = remaining_time - time_step ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. @@ -2624,13 +2846,14 @@ 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) 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_shelf_sfc_mass_flux > 0) call post_data(CS%id_shelf_sfc_mass_flux, fluxes_in%shelf_sfc_mass_flux, CS%diag) call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Ifull_time_step, dh_adott, dh_adott*0.0) call disable_averaging(CS%diag) @@ -2684,7 +2907,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) @@ -2698,7 +2921,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) @@ -2707,7 +2930,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) @@ -2748,7 +2971,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) @@ -2762,7 +2985,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) @@ -2771,13 +2994,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 @@ -2812,7 +3035,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) @@ -2826,7 +3049,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) @@ -2835,13 +3058,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 @@ -2857,6 +3080,63 @@ subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh endif end subroutine process_and_post_scalar_data +!> Initialize ice surface mass balance field that is held constant over time +subroutine initialize_ice_SMB(CS, SMB, G, US, PF) + type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to initialize_ice_shelf. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: SMB !< Ice surface mass balance parameter, often in [R Z T-1 ~> kg m-2 s-1] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + real :: SMB_val ! Constant ice surface mass balance parameter, often in [R Z T-1 ~> kg m-2 s-1] + character(len=40) :: mdl = "initialize_ice_SMB" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, SMB_file + logical :: smb_file_has_time + + call get_param(PF, mdl, "ICE_SMB_CONFIG", config, & + "This specifies how the initial ice surface mass balance parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + default="CONSTANT") + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "SMB", SMB_val, & + "Surface mass balance.", units="kg m-2 s-1", default=0.0, scale=US%kg_m2s_to_RZ_T) + + SMB(:,:) = SMB_val + + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading SMB parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "ICE_SMB_FILE", SMB_file, & + "The file from which the ice surface mass balance is read.", & + default="ice_SMB.nc") + filename = trim(inputdir)//trim(SMB_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SMB_FILE", filename) + call get_param(PF, mdl, "ICE_SMB_VARNAME", varname, & + "The variable to use as surface mass balance.", & + default="SMB") + call get_param(PF, mdl, "ICE_SMB_TIME_VARYING", SMB_file_has_time, & + "The file from which the ice surface mass balance is read has a time axis.", & + default=.false.) + call log_param(PF, mdl, "ICE_SMB_TIME_VARYING", SMB_file_has_time) + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_SMV_from_file: Unable to open "//trim(filename)) + if (SMB_file_has_time) then + CS%smb_file = init_external_field(filename, varname, MOM_domain=G%Domain,correct_leap_year_inconsistency=.true.) + CS%time_varying_smb = .true. + else + call MOM_read_data(filename,trim(varname), SMB, G%Domain, scale=US%kg_m2s_to_RZ_T) + CS%time_varying_smb = .false. + endif + endif +end subroutine initialize_ice_SMB + !> \namespace mom_ice_shelf !! !! \section section_ICE_SHELF diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index fc728e5d14..7023a564b7 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -2,61 +2,108 @@ ! See the LICENSE file for licensing information. ! SPDX-License-Identifier: Apache-2.0 -!> Convenient wrappers to the FMS diag_manager interfaces with additional diagnostic capabilies. +!> 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 +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_checksums, only : chksum0, hchksum, uchksum, vchksum, Bchksum +use MOM_coms, only : PE_here +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_manager_infra, only : MOM_diag_manager_init +use MOM_diag_manager_infra, only : MOM_diag_axis_init, get_MOM_diag_axis_name +use MOM_diag_manager_infra, only : send_data_infra, MOM_diag_field_add_attribute, EAST, NORTH +use MOM_diag_manager_infra, only : register_diag_field_infra, register_static_field_infra +use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND +use MOM_diag_manager_infra, only : diag_send_complete_infra +use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : get_filename_appendix +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_string_functions, only : lowercase, uppercase, slasher, ints_to_string, trim_trailing_commas +use MOM_time_manager, only : time_type, get_time +use MOM_unit_scaling, only : unit_scale_type implicit none ; private public MOM_IS_diag_mediator_infrastructure_init -public set_IS_axes_info, post_IS_data, register_MOM_IS_diag_field, time_type -public register_MOM_IS_static_field -public safe_alloc_ptr, safe_alloc_alloc -public enable_averaging, disable_averaging, query_averaging_enabled -public enable_averages public MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end, set_IS_diag_mediator_grid +public set_IS_axes_info, MOM_diag_axis_init +public register_MOM_IS_diag_field, register_MOM_IS_static_field, register_MOM_IS_scalar_field +public post_IS_data, post_IS_data_0d, MOM_IS_diag_send_complete +public safe_alloc_ptr, safe_alloc_alloc, time_type +public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled public MOM_IS_diag_mediator_close_registration, get_diag_time_end -public MOM_diag_axis_init, register_static_field_infra -public register_MOM_IS_scalar_field, post_IS_data_0d +public define_axes_group, diag_masks_set +public diag_register_area_ids, found_in_diagtable -!> 2D/3D axes type to contain 1D axes handles and pointers to masks -type, public :: axesType +!> 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 + +!> 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 @@ -70,177 +117,327 @@ module MOM_IS_diag_mediator integer :: ied !< The end i-index of cell centers within the data domain integer :: jsd !< The start j-index of cell centers within the data domain integer :: jed !< The end j-index of cell centers within the data domain - real :: time_int !< The time interval 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 + +end subroutine define_axes_group -!> Set up the current grid for the diag mediator +!> 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, @@ -249,27 +446,35 @@ subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask) ! the output data size and assumes that halos are symmetric. isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je - if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then + cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1 + cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1 + if ( size(field,1) == dszi ) then isv = diag_cs%is ; iev = diag_cs%ie ; i_data = .true. ! Data domain - elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then + elseif ( size(field,1) == dszi + 1 ) then isv = diag_cs%is ; iev = diag_cs%ie+1 ; i_data = .true. ! Symmetric data domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then - isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ; i_data = .false. ! Computational domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then - isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ; i_data = .false. ! Symmetric computational domain + elseif ( size(field,1) == cszi ) then + isv = 1 ; iev = cszi ; i_data = .false. ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ; i_data = .false. ! Symmetric computational domain else - call MOM_error(FATAL,"post_MOM_IS_data_2d: peculiar size in i-direction of "//trim(diag%name)) + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_IS_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif - if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then + + if ( size(field,2) == dszj ) then jsv = diag_cs%js ; jev = diag_cs%je ; j_data = .true. ! Data domain - elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then + elseif ( size(field,2) == dszj + 1 ) then jsv = diag_cs%js ; jev = diag_cs%je+1 ; j_data = .true. ! Symmetric data domain - elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then - jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ; j_data = .false. ! Computational domain - elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then - jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ; j_data = .false. ! Symmetric computational domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ; j_data = .false. ! Computational domain + ! This was: elseif ( size(field,1) == cszj + 1 ) then + elseif ( size(field,2) == cszj + 1 ) then + jsv = 1 ; jev = cszj+1 ; j_data = .false. ! Symmetric computational domain else - call MOM_error(FATAL,"post_MOM_IS_data_2d: peculiar size in j-direction "//trim(diag%name)) + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_IS_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then @@ -289,106 +494,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 @@ -397,15 +572,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 @@ -426,11 +592,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 @@ -444,26 +618,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 @@ -479,188 +657,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 - if (is_root_pe() .and. diag_CS%doc_unit > 0) then - if (primary_id > 0) then - mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]' + ! 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 - mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]' + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count) endif - write(diag_CS%doc_unit, '(a)') trim(mesg) - if (present(long_name)) call describe_option("long_name", long_name, diag_CS) - if (present(units)) call describe_option("units", units, diag_CS) - if (present(standard_name)) & - call describe_option("standard_name", standard_name, diag_CS) - endif - - !Decide what mask to use based on the axes info - if (primary_id > 0) then - !2d masks - if (axes%rank == 2) then - diag%mask2d => null() ; diag%mask2d_comp => null() - if (axes%id == diag_cs%axesT1%id) then - diag%mask2d => diag_cs%mask2dT - diag%mask2d_comp => diag_cs%mask2dT_comp - elseif (axes%id == diag_cs%axesB1%id) then - diag%mask2d => diag_cs%mask2dBu - elseif (axes%id == diag_cs%axesCu1%id) then - diag%mask2d => diag_cs%mask2dCu - elseif (axes%id == diag_cs%axesCv1%id) then - diag%mask2d => diag_cs%mask2dCv - ! else - ! call SIS_error(FATAL, "SIS_diag_mediator:register_diag_field: " // & - ! "unknown axes for diagnostic variable "//trim(field_name)) + else + ! If interp_method is not provided and the field is not at an h-point then interp_method='none' + if (area_id>0) then + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method='none', tile_count=tile_count, area=area_id) + else + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method='none', tile_count=tile_count) + endif + endif + + register_diag_field_expand_axes = fms_id + +end function register_diag_field_expand_axes + +!> Create a diagnostic type and attached to list +subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) + type(diag_ctrl), pointer :: diag_cs !< Diagnostics mediator control structure + integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group + integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic + type(diag_type), pointer :: this_diag !< This diagnostic + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that + !! indicates axes for this field + character(len=*), intent(in) :: module_name !< Name of this module, usually + !! "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of diagnostic + + ! If the diagnostic is needed obtain a diag_mediator ID (if needed) + if (dm_id == -1) dm_id = get_new_diag_id(diag_cs) + ! Create a new diag_type to store links in + call alloc_diag_with_id(dm_id, diag_cs, this_diag) + call assert(associated(this_diag), 'add_diag_to_list: allocation failed for '//trim(field_name)) + ! Record FMS id, masks and conversion factor, in diag_type + this_diag%fms_diag_id = fms_id + this_diag%debug_str = trim(module_name)//"-"//trim(field_name) + this_diag%axes => axes + +end subroutine add_diag_to_list + + +!> Attaches "cell_methods" attribute to a variable based on defaults for axes_grp or optional arguments. +subroutine attach_cell_methods(id, axes, ostring, cell_methods, x_cell_method, y_cell_method) + integer, intent(in) :: id !< Handle to diagnostic + type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates + !! axes for this field + character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + ! Local variables + character(len=9) :: axis_name + logical :: x_mean, y_mean, x_sum, y_sum + + x_mean = .false. + y_mean = .false. + x_sum = .false. + y_sum = .false. + + ostring = '' + if (present(cell_methods)) then + if (present(x_cell_method) .or. present(y_cell_method)) then + call MOM_error(FATAL, "attach_cell_methods: " // & + 'Individual direction cell method was specified along with a "cell_methods" string.') + endif + if (len(trim(cell_methods))>0) then + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(cell_methods)) + ostring = trim(cell_methods) + endif + else + if (present(x_cell_method)) then + if (len(trim(x_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(x_cell_method) + if (trim(x_cell_method)=='mean') x_mean=.true. + if (trim(x_cell_method)=='sum') x_sum=.true. + endif + else + 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 + 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 - endif ! if (primary_id>-1) + if (x_mean .and. y_mean) then + call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:mean') + ostring = trim(adjustl(ostring))//' area:mean' + elseif (x_sum .and. y_sum) then + call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:sum') + ostring = trim(adjustl(ostring))//' area:sum' + endif + endif + ostring = adjustl(ostring) +end subroutine attach_cell_methods - 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) -!> 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, & +end function register_scalar_field_axes + +!> Registers a non-array scalar diagnostic, returning an integer handle +function register_scalar_field_CS(module_name, field_name, init_time, diag_cs, & long_name, units, missing_value, range, standard_name, & - do_not_log, err_msg, 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() - fms_id = register_static_field_infra(module_name, field_name, axes%handles, & - long_name=long_name, units=units, missing_value=MOM_missing_value, & - range=range, mask_variant=mask_variant, standard_name=standard_name, & - do_not_log=do_not_log, & - interp_method=interp_method, tile_count=tile_count) - if (fms_id > 0) then - primary_id = get_new_diag_id(diag_cs) - diag_cs%diags(primary_id)%fms_diag_id = fms_id + if (diag_cs%diag_as_chksum) then + fms_id = diag_cs%num_chksum_diags + 1 + diag_cs%num_chksum_diags = fms_id + else + fms_id = register_static_field_infra(module_name, field_name, axes%handles, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count, area=area) endif - register_static_field = 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_static_field: diag allocation failed') + diag%fms_diag_id = fms_id + diag%debug_str = trim(module_name)//"-"//trim(field_name) + if (present(conversion)) diag%conversion_factor = conversion + + if (diag_cs%diag_as_chksum) then + diag%axes => axes + else + if (present(x_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + trim(axis_name)//':'//trim(x_cell_method)) + endif + if (present(y_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + trim(axis_name)//':'//trim(y_cell_method)) + endif + if (present(area_cell_method)) then + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + 'area:'//trim(area_cell_method)) + endif + endif + endif + + if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then + ! Fallback values for strings set to "not provided" + posted_cmor_units = "not provided" + posted_cmor_standard_name = "not provided" + posted_cmor_long_name = "not provided" + + ! If attributes are present for MOM variable names, use them first for the register_static_field + ! call for CMOR verison of the variable + if (present(units)) posted_cmor_units = units + if (present(standard_name)) posted_cmor_standard_name = standard_name + if (present(long_name)) posted_cmor_long_name = long_name + + ! If specified in the call to register_static_field, override attributes with the CMOR versions + if (present(cmor_units)) posted_cmor_units = cmor_units + if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name + if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name + + fms_id = register_static_field_infra(module_name, cmor_field_name, axes%handles, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count, area=area) + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + if (dm_id == -1) then + dm_id = get_new_diag_id(diag_cs) + endif + call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) + cmor_diag%fms_diag_id = fms_id + cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_diag%conversion_factor = conversion + if (present(x_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) + endif + if (present(y_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) + endif + if (present(area_cell_method)) then + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', 'area:'//trim(area_cell_method)) + endif + endif + endif + + dimensions = "" + if (axes%is_h_point) dimensions = trim(dimensions)//" xh, yh," + if (axes%is_q_point) dimensions = trim(dimensions)//" xq, yq," + if (axes%is_u_point) dimensions = trim(dimensions)//" xq, yh," + if (axes%is_v_point) dimensions = trim(dimensions)//" xh, yq," + if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions) + + ! Document diagnostics in list of available diagnostics + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then + if (present(cmor_field_name)) then + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name, & + variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}", & + dimensions=dimensions) + else + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name, dimensions=dimensions) + endif + endif + + register_static_field = dm_id end function register_MOM_IS_static_field @@ -668,47 +1358,26 @@ end function register_MOM_IS_static_field subroutine describe_option(opt_name, value, diag_CS) character(len=*), intent(in) :: opt_name !< The name of the option character(len=*), intent(in) :: value !< The value of the option - type(diag_ctrl), intent(in) :: diag_CS !< Diagnostic being documented + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output ! Local variables - character(len=240) :: mesg + 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 @@ -717,26 +1386,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" @@ -748,15 +1449,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.") @@ -765,36 +1465,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 @@ -805,37 +1553,60 @@ subroutine diag_masks_set(G, missing_value, diag_cs) diag_cs%mask2dT_comp(i,j) = diag_cs%mask2dT(i,j) enddo ; enddo - diag_cs%missing_value = missing_value end subroutine diag_masks_set !> Prevent the registration of additional diagnostics, so that the creation of files can occur subroutine MOM_IS_diag_mediator_close_registration(diag_CS) - type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output - if (diag_CS%doc_unit > -1) then - close(diag_CS%doc_unit) ; diag_CS%doc_unit = -2 + if (diag_CS%available_diag_doc_unit > -1) then + close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -2 endif end subroutine MOM_IS_diag_mediator_close_registration !> Deallocate memory associated with the MOM_IS diag mediator subroutine MOM_IS_diag_mediator_end(diag_CS) - type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output - if (diag_CS%doc_unit > -1) then - close(diag_CS%doc_unit) ; diag_CS%doc_unit = -3 + ! Local variables + type(diag_type), pointer :: diag, next_diag + integer :: i + + if (diag_CS%available_diag_doc_unit > -1) then + close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -3 + endif + if (diag_CS%chksum_iounit > -1) then + close(diag_CS%chksum_iounit) ; diag_CS%chksum_iounit = -3 endif -end subroutine MOM_IS_diag_mediator_end + do i=1, diag_cs%next_free_diag_id - 1 + if (associated(diag_cs%diags(i)%next)) then + next_diag => diag_cs%diags(i)%next + do while (associated(next_diag)) + diag => next_diag + next_diag => diag%next + deallocate(diag) + enddo + endif + enddo -!> Allocate a new diagnostic id, noting that it may be necessary to expand the diagnostics array. -function get_new_diag_id(diag_cs) + deallocate(diag_cs%diags) - integer :: get_new_diag_id !< The returned ID for the new diagnostic - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + ! These points to arrays in the grid type, so they can not be deallocated here. + if (associated(diag_cs%mask2dT)) diag_cs%mask2dT => NULL() + if (associated(diag_cs%mask2dBu)) diag_cs%mask2dBu => NULL() + if (associated(diag_cs%mask2dCu)) diag_cs%mask2dCu => NULL() + if (associated(diag_cs%mask2dCv)) diag_cs%mask2dCv => NULL() + if (associated(diag_cs%mask2dT_comp)) deallocate(diag_cs%mask2dT_comp) + +end subroutine MOM_IS_diag_mediator_end +!> Returns a new diagnostic id, it may be necessary to expand the diagnostics array. +integer function get_new_diag_id(diag_cs) + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure ! Local variables type(diag_type), dimension(:), allocatable :: tmp integer :: i @@ -853,9 +1624,9 @@ function get_new_diag_id(diag_cs) diag_cs%diags(1:size(tmp)) = tmp(:) deallocate(tmp) - ! Initialise new part of the diag array. + ! Initialize new part of the diag array. do i=diag_cs%next_free_diag_id, size(diag_cs%diags) - diag_cs%diags(i)%in_use = .false. + call initialize_diag_type(diag_cs%diags(i)) enddo endif @@ -864,4 +1635,112 @@ function get_new_diag_id(diag_cs) end function get_new_diag_id +!> Initializes a diag_type (used after allocating new memory) +subroutine initialize_diag_type(diag) + type(diag_type), intent(inout) :: diag !< diag_type to be initialized + + diag%in_use = .false. + diag%fms_diag_id = -1 + diag%axes => null() + diag%next => null() + diag%conversion_factor = 0. + +end subroutine initialize_diag_type + +!> Make a new diagnostic. Either use memory which is in the array of 'primary' +!! diagnostics, or if that is in use, insert it to the list of secondary diags. +subroutine alloc_diag_with_id(diag_id, diag_cs, diag) + integer, intent(in ) :: diag_id !< id for the diagnostic + type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output + type(diag_type), pointer :: diag !< structure representing a diagnostic (inout) + + type(diag_type), pointer :: tmp => NULL() + + if (.not. diag_cs%diags(diag_id)%in_use) then + diag => diag_cs%diags(diag_id) + else + allocate(diag) + tmp => diag_cs%diags(diag_id)%next + diag_cs%diags(diag_id)%next => diag + diag%next => tmp + endif + diag%in_use = .true. + +end subroutine alloc_diag_with_id + +!> Log a diagnostic to the available diagnostics file. +subroutine log_available_diag(used, module_name, field_name, cell_methods_string, comment, & + diag_CS, long_name, units, standard_name, variants, dimensions) + logical, intent(in) :: used !< Whether this diagnostic was in the diag_table or not + character(len=*), intent(in) :: module_name !< Name of the diagnostic module + character(len=*), intent(in) :: field_name !< Name of this diagnostic field + character(len=*), intent(in) :: cell_methods_string !< The spatial component of the CF cell_methods attribute + character(len=*), intent(in) :: comment !< A comment to append after [Used|Unused] + type(diag_ctrl), intent(in) :: diag_CS !< The diagnotics control structure + character(len=*), optional, intent(in) :: dimensions !< Descriptor of the horizontal and vertical dimensions + character(len=*), optional, intent(in) :: long_name !< CF long name of diagnostic + character(len=*), optional, intent(in) :: units !< Units for diagnostic + character(len=*), optional, intent(in) :: standard_name !< CF standardized name of diagnostic + character(len=*), optional, intent(in) :: variants !< Alternate modules and variable names for + !! this diagnostic and derived diagnostics + ! Local variables + character(len=240) :: mesg + + if (used) then + mesg = '"'//trim(field_name)//'" [Used]' + else + mesg = '"'//trim(field_name)//'" [Unused]' + endif + if (len(trim((comment)))>0) then + write(diag_CS%available_diag_doc_unit, '(a,1x,"(",a,")")') trim(mesg),trim(comment) + else + write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) + endif + call describe_option("modules", module_name, diag_CS) + if (present(dimensions)) then ; if (len(trim(dimensions)) > 0) then + call describe_option("dimensions", dimensions, diag_CS) + endif ; endif + if (present(long_name)) call describe_option("long_name", long_name, diag_CS) + if (present(units)) call describe_option("units", units, diag_CS) + if (present(standard_name)) & + call describe_option("standard_name", standard_name, diag_CS) + if (len(trim((cell_methods_string)))>0) & + call describe_option("cell_methods", trim(cell_methods_string), diag_CS) + if (present(variants)) then ; if (len(trim(variants)) > 0) then + call describe_option("variants", variants, diag_CS) + endif ; endif +end subroutine log_available_diag + +!> Log the diagnostic chksum to the chksum diag file +subroutine log_chksum_diag(docunit, description, chksum) + integer, intent(in) :: docunit !< Handle of the log file + character(len=*), intent(in) :: description !< Name of the diagnostic module + integer, intent(in) :: chksum !< chksum of the diagnostic + + write(docunit, '(a,1x,i9.8)') description, chksum + flush(docunit) + +end subroutine log_chksum_diag + +!> Fakes a register of a diagnostic to find out if an obsolete +!! parameter appears in the diag_table. +logical function found_in_diagtable(diag, varName) + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + character(len=*), intent(in) :: varName !< The obsolete diagnostic name + ! Local + integer :: handle ! Integer handle returned from diag_manager + + ! We use register_static_field_fms() instead of register_static_field() so + ! that the diagnostic does not appear in the available diagnostics list. + handle = register_static_field_infra('ice_shelf_model', varName, diag%axesT1%handles) + + found_in_diagtable = (handle>0) + +end function found_in_diagtable + +!> Finishes the diag manager reduction methods as needed for the time_step +subroutine MOM_IS_diag_send_complete() + call diag_send_complete_infra() +end subroutine MOM_IS_diag_send_complete + end module MOM_IS_diag_mediator diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 9ad992bb97..87ade20ad3 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -13,12 +13,13 @@ 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_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_io, only : file_exists, slasher, MOM_read_data -use MOM_io, only : open_ASCII_file, get_filename_appendix +use MOM_io, only : open_ASCII_file, close_file, get_filename_appendix use MOM_io, only : APPEND_FILE, WRITEONLY_FILE use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_time_manager, only : time_type, get_time, set_time, time_type_to_real, operator(>) @@ -41,6 +42,11 @@ module MOM_ice_shelf_dynamics public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask, volume_above_floatation public masked_var_grounded +! SSA inner solver flags +integer, parameter :: INNER_CG = 1 !< Conjugate gradient (default) +integer, parameter :: INNER_MINRES = 2 !< MINRES +integer, parameter :: INNER_CR = 3 !< Conjugate residual + ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -94,6 +100,15 @@ 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(:,:) :: 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 @@ -108,12 +123,15 @@ module MOM_ice_shelf_dynamics !! the same as G%bathyT+Z_ref, when below sea-level. !! Sign convention: positive below sea-level, negative above. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area-integrated taub_beta field - !! (m2 Pa s m-1, or kg s-1) related to the nonlinear part - !! of "linearized" basal stress (Pa) [R Z L2 T-1 ~> kg s-1] - !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), !! units of [R L Z T-2 (s m-1)^(n_basal_fric) ~> Pa (s m-1)^(n_basal_fric)] + real, pointer, dimension(:,:) :: coef_prefactor => NULL() !< Pre-computed area*C_basal_friction*L_T_to_m_s for + !! basal friction quadrature evaluation [R L2 Z T-1 ~> kg s-1]. + real, pointer, dimension(:,:) :: fB_elem => NULL() !< Pre-computed element-level Coulomb fB parameter + !! [(T L-1)^CF_PostPeak]; 0 for Weertman. + !! Updated each outer iteration by calc_shelf_basal_prefactors. + real :: alpha_coulomb = 1.0 !< Coulomb prefactor (CF_PostPeak-1)^(CF_PostPeak-1)/CF_PostPeak^CF_PostPeak [nondim] + real :: coulomb_pp_n !< CF_PostPeak/n_basal_fric [nondim] real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av [Z ~> m]. real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. @@ -126,6 +144,10 @@ module MOM_ice_shelf_dynamics !! 4 quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, pointer, dimension(:,:,:) :: PhiC => NULL() !< The gradients of bilinear basis elements at 1 cell-centered !! quadrature point per cell [L-1 ~> m-1]. + real, pointer, dimension(:,:,:) :: Jac => NULL() !< Jacobian determinant |J_q| = a_q*d_q of the element + !! mapping at each of the 4 Gaussian quadrature points [L2 ~> m2]. + !! Equal to G%areaT only for rectangular elements; differs when + !! opposite cell edges have unequal lengths (non-rectangular quads). real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. @@ -155,6 +177,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 @@ -186,20 +211,42 @@ module MOM_ice_shelf_dynamics !! circulation or thermodynamics. It is used to estimate the !! gravitational driving force at the shelf front (until we think of !! a better way to do it, but any difference will be negligible). + real :: rhoi_rhow !< The density of ice divided by a typical water density [nondim] + real :: rhow_rhoi !< A typical water density divided by the density of ice [nondim] real :: thresh_float_col_depth !< The water column depth over which the shelf if considered to be floating logical :: moving_shelf_front !< Specify whether to advance shelf front (and calve). logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask. real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: T_shelf_missing !< An ice shelf temperature to use where there is no ice shelf [C ~> degC] - real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that + real :: cg_tolerance !< For Picard iterations, the tolerance in the CG solver, relative to initial residual, that !! determines when to stop the conjugate gradient iterations [nondim]. + real :: cg_newton_tolerance !< For inexact Newton iterations, the initial tolerance in the CG solver, relative to + !! initial residual, that determines when to stop the CG iterations [nondim]. + real :: cg_tol_current !< 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 + !! If set to <= 0, no Picard [nondim] + type(group_pass_type) :: pass_visc_and_newton !< Handle for Newton-and-viscosity-related group passes + type(group_pass_type) :: pass_newton !< Handle for Newton-related group passes + logical :: newton_adapt_cg_tol !< Use an adaptive CG tolerance during Newton iterations + real :: ew_gamma !< Gamma in Eisenstat-Walker adaptive Newton tolerance [nondim]. + real :: ew_alpha !< Alpha in Eisenstat-Walker adaptive Newton tolerance [nondim]. + integer :: ew_safety !< Safeguard Eisenstat-Walker using: + !!(0) no safeguard, (1) EW choice 2 threshold or (2) PETSc option 3 (Chacon 2008) + real :: ew_1_thres !< Threshold for Eisenstat-Walker version 1 [nondim] + real :: ew_eta_max !< Maximum allowed Eisenstat-Walker eta [nondim] 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 + integer :: nonlin_solve_err_mode !< 1: exit based on nonlin residual | F | / | F_0 | where | | is infty-norm !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm - !! 3: exit based on change of norm - + !! 3: exit based on change of solution norm 2*abs(|u|-|u_last|)/(|u|+|u_last|) where | | is L2-norm + !! 4: exit based on nonlin residual | F | / | F_0 | where | | is L2-norm + !! 5: exit based on relative residual | F | / | tau | where | | is L2-norm + logical :: ssa_add_rel_resid !< Nonlinear error in velocity solve will also depend on the + !! L2 residual norm relative to RHS norm + real :: rr_nonlinear_tolerance !< If ssa_add_rel_resid, the additional nonlin tolerance in the iterative + !! velocity solve used for the relative residual [nondim] ! for write_ice_shelf_energy type(time_type) :: energysavedays !< The interval between writing the energies !! and other integral quantities of the run. @@ -218,7 +265,8 @@ module MOM_ice_shelf_dynamics type(time_type) :: Start_time !< The start time of the simulation. ! Start_time is set in MOM_initialization.F90 integer :: prev_IS_energy_calls = 0 !< The number of times write_ice_shelf_energy has been called. - integer :: IS_fileenergy_ascii !< The unit number of the ascii version of the energy file. + integer :: IS_fileenergy_ascii = -1 + !< The unit number of the ascii version of the energy file. character(len=200) :: IS_energyfile !< The name of the ice sheet energy file with path. ! ids for outputting intermediate thickness in advection subroutine (debugging) @@ -226,6 +274,11 @@ 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 + integer :: inner_solver !< The inner linear solver: INNER_CG (1),INNER_MINRES (2), or INNER_CR (3) + logical :: cg_halo_shrink = .true. !< If true, CG uses halo-shrinking to defer pass_vector calls; + !! if false, uses fixed CG_action range with 1 pass_vector per iteration logical :: module_is_initialized = .false. !< True if this module has been initialized. !>@{ Diagnostic handles @@ -252,9 +305,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 @@ -340,7 +394,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) call get_param(param_file, mdl, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS", CS%visc_qps, & "Number of ice viscosity quadrature points. Either 1 (cell-centered) for 4", & - units="none", default=1) + units="none", default=4) if (CS%visc_qps/=1 .and. CS%visc_qps/=4) call MOM_error (FATAL, & "NUMBER OF ICE_VISCOSITY_QUADRATURE_POINTS must be 1 or 4") @@ -359,10 +413,15 @@ 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%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] - allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R Z L2 T-1 ~> kg s-1] allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10*US%Pa_to_RLZ_T2) ! Units of [R L Z T-2 (s m-1)^n_sliding ~> Pa (s m-1)^n_sliding] + allocate(CS%coef_prefactor(isd:ied,jsd:jed), source=0.0) + allocate(CS%fB_elem(isd:ied,jsd:jed), source=0.0) allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) allocate(CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0) @@ -376,6 +435,16 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0) allocate(CS%h_bdry_val(isd:ied,jsd:jed), source=0.0) + ! Create group pass handles + call create_group_pass(CS%pass_visc_and_newton, CS%ice_visc, G%domain) + call create_group_pass(CS%pass_visc_and_newton, CS%newton_str_sh, G%domain) + call create_group_pass(CS%pass_visc_and_newton, CS%newton_visc_factor, G%domain) + call create_group_pass(CS%pass_visc_and_newton, CS%newton_str_ux, CS%newton_str_vy, G%domain, TO_ALL, AGRID) + + call create_group_pass(CS%pass_newton, CS%newton_str_sh, G%domain) + call create_group_pass(CS%pass_newton, CS%newton_visc_factor, G%domain) + call create_group_pass(CS%pass_newton, CS%newton_str_ux, CS%newton_str_vy, G%domain, TO_ALL, AGRID) + ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & "ice sheet/shelf u-velocity", & @@ -440,10 +509,13 @@ 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. character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs + character(len=16) :: inner_solver_str ! The type of inner solver to use for the SSA Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -546,13 +618,72 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "CF_Max", CS%CF_Max, & "Coulomb friction maximum coefficient", & units="none", default=0.5, fail_if_missing=.false.) + ! Pre-compute Coulomb prefactor alpha = (q-1)^(q-1)/q^q for q=CF_PostPeak [nondim]. + ! Default is 1.0; only update when Coulomb is active and q /= 1. + ! Also store CS%coulomb_pp_n = CF_PostPeak/n_basal_fric [nondim] + if (CS%CoulombFriction) then + if (CS%CF_PostPeak /= 1.0) then + CS%alpha_coulomb = (CS%CF_PostPeak-1.0)**(CS%CF_PostPeak-1.0) / CS%CF_PostPeak**CS%CF_PostPeak + endif + CS%coulomb_pp_n = CS%CF_PostPeak/CS%n_basal_fric + endif call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) + + ! Precompute commonly-used density ratios + CS%rhoi_rhow=CS%density_ice / CS%density_ocean_avg + CS%rhow_rhoi=CS%density_ocean_avg / CS%density_ice + 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) + "For Picard iterations, the tolerance in CG solver, relative to initial residual", & + units="nondim", default=1.e-6) + call get_param(param_file, mdl, "NEWTON_CONJUGATE_GRADIENT_TOLERANCE", CS%cg_newton_tolerance, & + "For inexact Newton iterations, the initial tolerance in CG solver, relative to initial residual", & + units="nondim", default=CS%cg_tolerance) + CS%cg_tol_current = CS%cg_tolerance ! Can be tightened adaptively during inexact 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. If <=0, no Picard.",& + 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, "NEWTON_EW_GAMMA", CS%ew_gamma, & + "Gamma in Eisenstat-Walker adaptive Newton tolerance", units="nondim", default=0.9, & + do_not_log=(.not. CS%newton_adapt_cg_tol)) + call get_param(param_file, mdl, "NEWTON_EW_ALPHA", CS%ew_alpha, & + "Alpha in Eisenstat-Walker adaptive Newton tolerance", units="nondim", default=2.0, & + do_not_log=(.not. CS%newton_adapt_cg_tol)) + call get_param(param_file, mdl, "NEWTON_EW_SAFETY", CS%ew_safety, & + "Safeguard Eisenstat-Walker using (0) no safeguard, (1) EW choice 2 threshold "//& + "or (2) PETSc option 3 (Chacon 2008)", default=2, do_not_log=(.not. CS%newton_adapt_cg_tol)) + call get_param(param_file, mdl, "NEWTON_EW_1_THRESHOLD", CS%ew_1_thres, & + "Eisenstat-Walker version 1 threshold", & + units="nondim", default=0.1, do_not_log=(.not. CS%newton_adapt_cg_tol)) + call get_param(param_file, mdl, "NEWTON_EW_ETA_MAX", CS%ew_eta_max, & + "Maximum allowed Eisenstat-Walker eta (between 0 and 1)", & + units="nondim", default=0.9, do_not_log=(.not. CS%newton_adapt_cg_tol)) + if (CS%ew_eta_max<=0 .or. CS%ew_eta_max>= 1) & + call MOM_error(FATAL, "NEWTON_EW_ETA_MAX must be between 0 and 1.") + call get_param(param_file, mdl, "ICE_SHELF_INNER_SOLVER", inner_solver_str, & + "Choice of inner linear solver for the ice-shelf SSA velocity system. "//& + "Valid choices are CG (default), CR, and MINRES.", & + default="CG") + select case (trim(inner_solver_str)) + case ("CG") + CS%inner_solver = INNER_CG + case ("MINRES") + CS%inner_solver = INNER_MINRES + case ("CR") + CS%inner_solver = INNER_CR + end select + call get_param(param_file, mdl, "CG_HALO_SHRINK", CS%cg_halo_shrink, & + "If true, CG uses halo-shrinking to defer pass_vector calls. "//& + "If false, uses a fixed CG_action range with one pass_vector(D) per iteration, "//& + "which may reduce total communication for typical halo widths.", & + default=.true.) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & "max iteratiions in CG solver", default=2000) call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & @@ -561,8 +692,19 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="m", default=1.e-3, scale=US%m_to_Z) call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & "Choose whether nonlin error in vel solve is based on nonlinear "//& - "residual (1), relative change since last iteration (2), or change in norm (3)", default=3) - + "Linf norm residual (1), Linf norm relative change since last iteration (2), "//& + "change in solution L2 norm (3), L2 norm residual (4), L2 backward norm (5)", default=3) + if (CS%nonlin_solve_err_mode /= 5) then + call get_param(param_file, mdl, "SSA_ADD_REL_RESID", CS%ssa_add_rel_resid, & + "Nonlinear error in vel solve will also depend on "// & + "L2 residual norm relative to RHS norm.", default=.false.) + else + CS%ssa_add_rel_resid = .false. !Avoids redundantly calculating err_mode 5 twice + endif + call get_param(param_file, mdl, "ICE_RR_NONLINEAR_TOLERANCE", CS%rr_nonlinear_tolerance, & + "if ssa_add_rel_resid, the additional nonlin tolerance "//& + "in the iterative velocity solve for the residual norm relative to RHS norm", & + units="nondim", default=1.e-4) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & "Specify whether to advance shelf front (and calve).", & default=.false.) @@ -579,11 +721,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,9 +808,10 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif allocate(CS%Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + allocate(CS%Jac(1:4,isd:ied,jsd:jed), source=0.0) do j=G%jsd,G%jed ; do i=G%isd,G%ied - call bilinear_shape_fn_grid(G, i, j, CS%Phi(:,:,i,j)) - enddo; enddo + call bilinear_shape_fn_grid(G, i, j, CS%Phi(:,:,i,j), CS%Jac(:,i,j)) + enddo ; enddo if (CS%GL_regularize) then allocate(CS%Phisub(2,2,CS%n_sub_regularize,CS%n_sub_regularize,2,2), source=0.0) @@ -673,7 +823,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 @@ -686,7 +836,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%OD_av,G%domain, complete=.false.) call pass_var(CS%ground_frac, G%domain, complete=.false.) - call pass_var(CS%basal_traction, G%domain, complete=.false.) call pass_var(CS%AGlen_visc, G%domain, complete=.false.) call pass_var(CS%bed_elev, G%domain, complete=.false.) call pass_var(CS%C_basal_friction, G%domain, complete=.false.) @@ -822,11 +971,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') @@ -876,8 +1025,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ !IS_dynamics_post_data is called before update_ice_shelf if (CS%id_taudx_shelf>0 .or. CS%id_taudy_shelf>0) & call calc_shelf_driving_stress(CS, ISS, G, US, CS%taudx_shelf, CS%taudy_shelf, CS%OD_av) - if (CS%id_taub>0) & - call calc_shelf_taub(CS, ISS, G, US, CS%u_shelf, CS%v_shelf) if (CS%id_visc_shelf>0) & call calc_shelf_visc(CS, ISS, G, US, CS%u_shelf, CS%v_shelf) endif @@ -898,17 +1045,15 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) type(time_type), intent(in) :: Time !< The current model time integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi_rhow real :: OD ! Depth of open water below the ice shelf [Z ~> m] type(time_type) :: dummy_time ! - rhoi_rhow = CS%density_ice / CS%density_ocean_avg dummy_time = set_time(0,0) isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed do j=jsd,jed do i=isd,ied - OD = CS%bed_elev(i,j) - rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) + OD = CS%bed_elev(i,j) - CS%rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD @@ -1019,13 +1164,10 @@ subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere) real, dimension(SZI_(G),SZJ_(G)) :: vaf_cell !< cell-wise volume above floatation [Z L2 ~> m3] integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated integer :: is,ie,js,je,i,j - real :: rhoi_rhow, rhow_rhoi if (CS%GL_couple) & call MOM_error(FATAL, "MOM_ice_shelf_dyn, volume above floatation calculation assumes GL_couple=.FALSE..") - rhoi_rhow = CS%density_ice / CS%density_ocean_avg - rhow_rhoi = CS%density_ocean_avg / CS%density_ice is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec if (present(hemisphere)) then @@ -1036,29 +1178,29 @@ 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 vaf_cell(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) else !grounded if vaf_cell(i,j) > 0 - vaf_cell(i,j) = max(ISS%h_shelf(i,j) - rhow_rhoi * CS%bed_elev(i,j), 0.0) * ISS%area_shelf_h(i,j) + vaf_cell(i,j) = max(ISS%h_shelf(i,j) - CS%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 @@ -1069,10 +1211,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 @@ -1087,11 +1229,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) @@ -1124,8 +1267,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 @@ -1137,9 +1280,7 @@ subroutine IS_dynamics_post_data(time_step, Time, CS, ISS, G) call post_data(CS%id_visc_shelf, ice_visc, CS%diag) endif if (CS%id_taub > 0) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - basal_tr(i,j) = CS%basal_traction(i,j)*G%IareaT(i,j) - enddo ; enddo + call calc_shelf_taub(CS, ISS, G, basal_tr) call post_data(CS%id_taub, basal_tr, CS%diag) endif if (CS%id_u_mask > 0) call post_data(CS%id_u_mask, CS%umask, CS%diag) @@ -1201,6 +1342,8 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str integer :: start_of_day, num_days real :: reday ! Time in units given by CS%Timeunit, but often [days] + logical :: is_open + ! True if CS%fileenergy_ascii is open ! write_energy_time is the next integral multiple of energysavedays. if (present(time_step)) then @@ -1251,7 +1394,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)) @@ -1259,13 +1402,17 @@ 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) if (is_root_pe()) then ! Only the root PE actually writes anything. if (day > CS%Start_time) then - call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=APPEND_FILE) + is_open = .false. + if (CS%IS_fileenergy_ascii /= -1) & + inquire(unit=CS%IS_fileenergy_ascii, opened=is_open) + if (.not. is_open) & + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=APPEND_FILE) else call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=WRITEONLY_FILE) if (abs(CS%timeunit - 86400.0) < 1.0) then @@ -1395,23 +1542,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.) @@ -1449,15 +1596,22 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! If GL_regularize=true, indicates cells containing ! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Velocities used for convergence [L2 T-2 ~> m2 s-2] + logical :: converged ! Indicates nonlinear convergence + logical :: calc_Au_for_convergence ! Used for convergence criteria than need a CG_action character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter, nodefloat integer :: Isdq, Iedq, Jsdq, Jedq, isd, ied, jsd, jed integer :: Iscq, Iecq, Jscq, Jecq, isc, iec, jsc, jec real :: err_max, err_tempu, err_tempv, err_init ! Errors in [R L3 Z T-2 ~> kg m s-2] or [L T-1 ~> m s-1] + real :: norm_tau, err_rr ! Errors in [R L3 Z T-2 ~> kg m s-2] for relative residual + real :: ew_resid = 0.0 ! L2 norm of stress residual ||A(u)u - tau|| for Eisenstat-Walker [kg m s-2] + real :: ew_prev_resid = 0.0 ! Previous ew_resid; 0.0 flags first Newton call [kg m s-2] + real :: ew_eta = 0.0 ! Current EW inner tolerance [nondim] + real :: ew_eta_prev = 0.0 ! Previous EW inner tolerance for Chacon 2008 sharp-decrease safeguard [nondim] + real :: ew_stol ! Temporary safeguard tolerance [nondim] real :: max_vel ! The maximum velocity magnitude [L T-1 ~> m s-1] real :: tempu, tempv ! Temporary variables with velocity magnitudes [L T-1 ~> m s-1] real :: Norm, PrevNorm ! Velocities used to assess convergence [L T-1 ~> m s-1] - real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec @@ -1465,7 +1619,22 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - rhoi_rhow = CS%density_ice / CS%density_ocean_avg + + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. + ! Includes the edge of the tile is at the western/southern bdry (if symmetric) + if (CS%nonlin_solve_err_mode >= 3 .or. CS%ssa_add_rel_resid) then + if ((isc+G%idg_offset==G%isg) .and. (.not. CS%reentrant_x)) then + Is_sum = Iscq + (1-Isdq) ; Iscq_sv = Iscq + else + Is_sum = isc + (1-Isdq) ; Iscq_sv = isc + endif + if ((jsc+G%jdg_offset==G%jsg) .and. (.not. CS%reentrant_y)) then + Js_sum = Jscq + (1-Jsdq) ; Jscq_sv = Jscq + else + Js_sum = jsc + (1-Jsdq) ; Jscq_sv = jsc + endif + Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) + endif taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 Au(:,:) = 0.0 ; Av(:,:) = 0.0 @@ -1476,22 +1645,25 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (.not. CS%GL_couple) then do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) > 0) then + if (CS%rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) > 0) then CS%ground_frac(i,j) = 1.0 CS%OD_av(i,j) =0.0 endif enddo ; enddo endif + ! Warning: This turns off Picard entirely and may not converge. + if (CS%newton_after_tolerance<=0.0) CS%doing_newton=.true. + + ! Calculate RHS call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) + ! This is to determine which cells contain the grounding line, the criterion being that the cell ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by ! assuming topography is cellwise constant and H is bilinear in a cell; floating where ! rho_i/rho_w * H_node - D is negative - ! need to make this conditional on GL interp - if (CS%GL_regularize) then call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf) @@ -1501,7 +1673,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i do l=0,1 ; do k=0,1 if ((ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j)==3) .and. & - (rhoi_rhow * H_node(i-1+k,j-1+l) - CS%bed_elev(i,j) <= 0)) then + (CS%rhoi_rhow * H_node(i-1+k,j-1+l) - CS%bed_elev(i,j) <= 0)) then nodefloat = nodefloat + 1 endif enddo ; enddo @@ -1512,35 +1684,30 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo ; enddo call pass_var(CS%float_cond, G%Domain, complete=.false.) - call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.true.) endif - call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain, complete=.true.) + ! Calculate basal drag constants and initial velocity + call calc_shelf_basal_prefactors(CS, ISS, G, US) call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) - - ! This makes sure basal stress is only applied when it is supposed to be - if (CS%GL_regularize) then - do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (CS%ground_frac(i,j)/=1.0) CS%basal_traction(i,j) = 0.0 - enddo ; enddo + if (CS%doing_newton) then + ! halo pass for ice_visc, newton_str_sh, newton_visc_factor, newton_str_x + call do_group_pass(CS%pass_visc_and_newton, G%domain) else - do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - enddo ; enddo + call pass_var(CS%ice_visc, G%domain, complete=.true.) endif - if (CS%nonlin_solve_err_mode == 1) then - + ! Calculate err_init, the denominator for some convergence criteria + if (CS%nonlin_solve_err_mode == 1 .or. CS%nonlin_solve_err_mode == 4) then Au(:,:) = 0.0 ; Av(:,:) = 0.0 - 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) - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + CS%ice_visc, CS%float_cond, CS%bed_elev, u_shlf, v_shlf, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, CS%rhoi_rhow, use_newton_in=.false.) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) ! TODO: is this needed? + endif + if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then @@ -1552,38 +1719,57 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (err_tempv >= err_init) err_init = err_tempv endif enddo ; enddo - call max_across_PEs(err_init) + elseif (CS%nonlin_solve_err_mode == 3) then Normvec(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) Normvec(I,J) = (u_shlf(I,J)**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2) + enddo ; enddo + Norm = sqrt( reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, unscale=US%L_T_to_m_s**2 ) ) - ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. - ! Includes the edge of the tile is at the western/southern bdry (if symmetric) - if ((isc+G%idg_offset==G%isg) .and. (.not. CS%reentrant_x)) then - Is_sum = Iscq + (1-Isdq) ; Iscq_sv = Iscq - else - Is_sum = isc + (1-Isdq) ; Iscq_sv = isc - endif - if ((jsc+G%jdg_offset==G%jsg) .and. (.not. CS%reentrant_y)) then - Js_sum = Jscq + (1-Jsdq) ; Jscq_sv = Jscq - else - Js_sum = jsc + (1-Jsdq) ; Jscq_sv = jsc - endif - Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) + elseif (CS%nonlin_solve_err_mode == 4) then + Normvec(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) Normvec(I,J) = ((Au(I,J) - taudx(I,J))**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + ((Av(I,J) - taudy(I,J))**2) + enddo ; enddo + err_init = sqrt(reproducing_sum(Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, & + unscale=((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2)) + endif + if (CS%nonlin_solve_err_mode == 5 .or. CS%ssa_add_rel_resid) then + Normvec(:,:) = 0.0 do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq - if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)**2 - if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)**2 + if (CS%umask(I,J) == 1) Normvec(I,J) = (taudx(I,J)**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (taudy(I,J)**2) enddo ; enddo - Norm = sqrt( reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, unscale=US%L_T_to_m_s**2 ) ) + if (CS%nonlin_solve_err_mode == 5) then + err_init = sqrt(reproducing_sum(Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, & + unscale=((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2)) + else + norm_tau = sqrt(reproducing_sum(Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, & + unscale=((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2)) + endif endif u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) + if (CS%doing_newton) then + CS%cg_tol_current = CS%cg_newton_tolerance + else + CS%cg_tol_current = CS%cg_tolerance + endif + ew_prev_resid = 0.0 + converged = .false. + calc_Au_for_convergence = (CS%nonlin_solve_err_mode == 1 .or. CS%nonlin_solve_err_mode == 4 .or. & + CS%nonlin_solve_err_mode == 5 .or. CS%ssa_add_rel_resid) !! begin loop do iter=1,50 + ! The linear solve call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, CS%float_cond, & ISS%hmask, conv_flag, iters, time, CS%Phi, CS%Phisub) @@ -1595,48 +1781,58 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" call MOM_mesg(mesg, 5) - call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain, complete=.true.) + ! Update viscosity call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) - ! makes sure basal stress is only applied when it is supposed to be - if (CS%GL_regularize) then - do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (CS%ground_frac(i,j)/=1.0) CS%basal_traction(i,j) = 0.0 - enddo ; enddo + if (CS%doing_newton) then + ! halo pass for ice_visc, newton_str_sh, newton_visc_factor, newton_str_x + call do_group_pass(CS%pass_visc_and_newton, G%domain) else - do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - enddo ; enddo + call pass_var(CS%ice_visc, G%domain, complete=.true.) endif - if (CS%nonlin_solve_err_mode == 1) then - + ! Calculate convergence norms + if (calc_Au_for_convergence) then Au(:,:) = 0 ; Av(:,:) = 0 + 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, u_shlf, v_shlf, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, CS%rhoi_rhow, use_newton_in=.false.) - 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) + if (CS%nonlin_solve_err_mode == 1) then + err_max = 0 - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) == 1) then + err_tempu = ABS(Au(I,J) - taudx(I,J)) + if (err_tempu >= err_max) err_max = err_tempu + endif + if (CS%vmask(I,J) == 1) then + err_tempv = ABS(Av(I,J) - taudy(I,J)) + if (err_tempv >= err_max) err_max = err_tempv + endif + enddo ; enddo - err_max = 0 + call max_across_PEs(err_max) + endif - do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB - if (CS%umask(I,J) == 1) then - err_tempu = ABS(Au(I,J) - taudx(I,J)) - if (err_tempu >= err_max) err_max = err_tempu - endif - if (CS%vmask(I,J) == 1) then - err_tempv = ABS(Av(I,J) - taudy(I,J)) - if (err_tempv >= err_max) err_max = err_tempv + if (CS%nonlin_solve_err_mode == 4 .or. CS%nonlin_solve_err_mode == 5 .or. CS%ssa_add_rel_resid) then + Normvec(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) Normvec(I,J) = ((Au(I,J) - taudx(I,J))**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + ((Av(I,J) - taudy(I,J))**2) + enddo ; enddo + if (CS%nonlin_solve_err_mode == 4 .or. CS%nonlin_solve_err_mode == 5) then + err_max = sqrt(reproducing_sum(Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, & + unscale=((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2)) + if (CS%ssa_add_rel_resid) err_rr = err_max + elseif (CS%ssa_add_rel_resid) then + err_rr = sqrt(reproducing_sum(Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, & + unscale=((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2)) endif - enddo ; enddo - - call max_across_PEs(err_max) + endif + endif - elseif (CS%nonlin_solve_err_mode == 2) then + if (CS%nonlin_solve_err_mode == 2) then err_max=0. ; max_vel = 0 ; tempu = 0 ; tempv = 0 ; err_tempu = 0 do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB @@ -1665,34 +1861,133 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i elseif (CS%nonlin_solve_err_mode == 3) then PrevNorm = Norm ; Norm = 0.0 ; Normvec=0.0 do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq - if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)**2 - if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)**2 - enddo; enddo + if (CS%umask(I,J) == 1) Normvec(I,J) = (u_shlf(I,J)**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2) + enddo ; enddo Norm = sqrt( reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, unscale=US%L_T_to_m_s**2 ) ) err_max = 2.*abs(Norm-PrevNorm) ; err_init = Norm+PrevNorm endif - write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init - call MOM_mesg(mesg, 5) - + !Test convergence if (err_max <= CS%nonlinear_tolerance * err_init) then - exit + if (CS%ssa_add_rel_resid) then + if (err_rr <= CS%rr_nonlinear_tolerance * norm_tau) converged = .true. + else + converged = .true. + endif endif + if (converged) then + exit + else + write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init + call MOM_mesg(mesg, 5) + + if (CS%ssa_add_rel_resid) then + write(mesg,*) "ice_shelf_solve_outer: nonlinear relative stress residual = ", err_rr/norm_tau + call MOM_mesg(mesg, 5) + endif + + ! Activate Newton + if (err_max <= CS%newton_after_tolerance * err_init .and. .not. CS%doing_newton) then + CS%doing_newton = .true. + write(mesg,*) "ice_shelf_solve_outer: switching to Newton iterations at iter = ", iter + call MOM_mesg(mesg, 7) + ! halo pass for newton_str_sh, newton_visc_factor, newton_str_x + call do_group_pass(CS%pass_newton, G%domain) + CS%cg_tol_current = CS%cg_newton_tolerance + endif + + ! Inexact Newton: Adapt inner solver tolerance to prevent oversolving + ! Based on Eisenstat-Walker Choice II (Eisenstat & Walker 1994): η_k = γ*(||F_k||/||F_{k-1}||)^α + ! with γ=0.9, α=2 as default. Uses the L2 norm of the nonlinear stress residual ||Au - tau||_2, + ! consistent with the inner solver's convergence check (sv3dsums(3)). + ! The first Newton step uses the standard cg_tolerance. + if (CS%doing_newton .and. CS%newton_adapt_cg_tol) then + !calculate residual needed for EW; some convergence criteria already did this + if (CS%nonlin_solve_err_mode >= 4) then + ew_resid=err_max + elseif (CS%ssa_add_rel_resid) then + ew_resid=err_rr + else + if (.not. calc_Au_for_convergence) then + Au(:,:) = 0 ; Av(:,:) = 0 + 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, u_shlf, v_shlf, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, CS%rhoi_rhow, use_newton_in=.false.) + endif + Normvec(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) Normvec(I,J) = ((Au(I,J) - taudx(I,J))**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + ((Av(I,J) - taudy(I,J))**2) + enddo ; enddo + ew_resid = sqrt(reproducing_sum(Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, & + unscale=((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2)) + endif + + if (ew_prev_resid == 0.0) then + ! First Newton iteration: seed residuals; use initial newton cg_tolerance this step + ew_prev_resid = ew_resid + CS%cg_tol_current = CS%cg_newton_tolerance + ew_eta_prev = CS%cg_tol_current + else + ! Safeguarding and oversolving adjustments: + ! Eisenstat-Walker Choice II safeguard base formula + ew_eta = CS%ew_gamma * (ew_resid / ew_prev_resid)**CS%ew_alpha + ew_stol = CS%ew_gamma * ew_eta_prev**CS%ew_alpha + !Safeguards to sharp decrease/oversolving: + if (CS%ew_safety==1) then + ! Eisenstat-Walker Choice II safeguard: + write(mesg,*) "ice_shelf_solve_outer: ew_stol = ", ew_stol + call MOM_mesg(mesg, 8) + if (ew_stol > CS%ew_1_thres) ew_eta = max(ew_eta, ew_stol) + elseif (CS%ew_safety==2) then + ! PETSc choice 3 safeguard (e,g, Chacon 2008, J. Phys: Conf. Ser. 125 012041): + ! Avoid steep decreases in ew_eta + ew_eta = min(CS%cg_newton_tolerance, max(ew_eta, ew_stol)) + ! Avoid oversolving in last Newton iters: + ! The original is technically only applicable for nonlin_solve_err_mode=4: + ! ew_stol = CS%ew_gamma * ew_resid_first * CS%nonlinear_tolerance / ew_resid + ! Here, adapt for all nonlin_solve_err_modes: + ew_stol = CS%ew_gamma * err_init * CS%nonlinear_tolerance / err_max + if (CS%ssa_add_rel_resid) then + ew_stol = min(ew_stol, CS%ew_gamma * norm_tau * CS%rr_nonlinear_tolerance / err_rr) + endif + ew_eta = min(CS%cg_newton_tolerance, max(ew_eta, ew_stol)) + write(mesg,*) "ice_shelf_solve_outer: ew_stol = ", ew_stol + call MOM_mesg(mesg, 8) + endif + ew_eta = min(ew_eta,CS%ew_eta_max) + CS%cg_tol_current = ew_eta + ew_eta_prev = ew_eta + ew_prev_resid = ew_resid + write(mesg,*) "ice_shelf_solve_outer: New inner tolerance = ", CS%cg_tol_current + call MOM_mesg(mesg, 8) + endif + endif + endif enddo + CS%doing_newton = .false. + CS%cg_tol_current = CS%cg_tolerance write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init call MOM_mesg(mesg) + if (CS%ssa_add_rel_resid) then + write(mesg,*) "ice_shelf_solve_outer: nonlinear relative residual = ", err_rr/norm_tau + call MOM_mesg(mesg, 5) + endif write(mesg,*) "ice_shelf_solve_outer: exiting nonlinear solve after ",iter," iterations" call MOM_mesg(mesg) end subroutine ice_shelf_solve_outer +!> Unified inner linear solver for ice shelf velocity. +!! Performs shared setup (RHS, preconditioner, initial matrix-vector product), +!! dispatches to the selected Krylov method, and applies boundary conditions. subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, & hmask, conv_flag, iters, time, Phi, Phisub) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe - !! the ice-shelf state + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & @@ -1704,68 +1999,43 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: H_node !< The ice shelf thickness at nodal (corner) - !! points [Z ~> m]. + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing - !! the grounding line (float_cond=1) or not (float_cond=0) + !! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf + !! partly or fully covered by an ice-shelf integer, intent(out) :: conv_flag !< A flag indicating whether (1) or not (0) the - !! iterations have converged to the specified tolerance + !! iterations have converged to the specified tolerance integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations [nondim] -! one linear solve (nonlinear iteration) of the solution for velocity - -! in this subroutine: -! RHS = taud -! diagonal of matrix is found (for Jacobi precondition) -! CG iteration is carried out for max. iterations or until convergence - -! assumed - u, v, taud, visc, basal_traction are valid on the halo - - real, dimension(SZDIB_(G),SZDJB_(G)) :: & - Ru, Rv, & ! Residuals in the stress calculations [R L3 Z T-2 ~> m kg s-2] - Ru_old, Rv_old, & ! Previous values of Ru and Rv [R L3 Z T-2 ~> m kg s-2] - Zu, Zv, & ! Contributions to velocity changes [L T-1 ~> m s-1] - Zu_old, Zv_old, & ! Previous values of Zu and Zv [L T-1 ~> m s-1] - DIAGu, DIAGv, & ! Diagonals with units like Ru/Zu [R L2 Z T-1 ~> kg s-1] - RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] - 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 - real :: alpha_k ! A scaling factor for iterative corrections [nondim] - real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] - ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] - real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals - ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] - real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] - integer :: iter, i, j, isd, ied, jsd, jed, isc, iec, jsc, jec, is, js, ie, je + !! locations for finite element calculations [nondim] + + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] + Au, Av, & ! Matrix-vector product A*x [R L3 Z T-2 ~> kg m s-2] + DIAGu, DIAGv, & ! Diagonals [R L2 Z T-1 ~> kg s-1] + IDIAGu, IDIAGv ! Reciprocal diagonals [R-1 L-2 Z-1 T ~> kg-1 s] + real :: resid_scale ! A scaling factor for redimensionalizing the global residuals + ! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1] integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. - integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq, nx_halo, ny_halo - integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec + integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec arrays + integer :: I, J + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq + integer :: isc, iec, jsc, jec Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB - ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - rhoi_rhow = CS%density_ice / CS%density_ocean_avg - - Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 - Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 ; RHSu(:,:) = 0 ; RHSv(:,:) = 0 - Du(:,:) = 0 ; Dv(:,:) = 0 - dot_p1 = 0 + ! Initialize shared arrays + Au(:,:) = 0 ; Av(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. ! Includes the edge of the tile is at the western/southern bdry (if symmetric) @@ -1782,175 +2052,767 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) RHSu(:,:) = taudx(:,:) ; RHSv(:,:) = taudy(:,:) - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) - call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & - hmask, rhoi_rhow, Phi, Phisub, DIAGu, DIAGv) - + call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, u_shlf, v_shlf, & + hmask, CS%rhoi_rhow, Phi, Phisub, DIAGu, DIAGv) call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE, complete=.false.) 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) - + H_node, CS%ice_visc, float_cond, CS%bed_elev, u_shlf, v_shlf, & + G, US, isc-1, iec+1, jsc-1, jec+1, CS%rhoi_rhow, use_newton_in=.false.) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) - Ru(:,:) = (RHSu(:,:) - Au(:,:)) ; Rv(:,:) = (RHSv(:,:) - Av(:,:)) + ! Precompute reciprocal diagonal + IDIAGu(:,:) = 0.0 ; IDIAGv(:,:) = 0.0 + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J)==1 .AND. DIAGu(I,J)/=0) IDIAGu(I,J) = 1.0 / DIAGu(I,J) + if (CS%vmask(I,J)==1 .AND. DIAGv(I,J)/=0) IDIAGv(I,J) = 1.0 / DIAGv(I,J) + enddo ; enddo + resid_scale = US%s_to_T*(US%RZL2_to_kg*US%L_T_to_m_s**2) + + ! Dispatch to selected solver + select case (CS%inner_solver) + case (INNER_CG) + call ice_shelf_solve_inner_CG(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + CS%rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + case (INNER_MINRES) + call ice_shelf_solve_inner_MINRES(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + CS%rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + case (INNER_CR) + call ice_shelf_solve_inner_CR(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + CS%rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + end select + + ! Shared teardown: Apply boundary conditions + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 3) then + u_shlf(I,J) = CS%u_bdry_val(I,J) + elseif (CS%umask(I,J) == 0) then + u_shlf(I,J) = 0 + endif + + if (CS%vmask(I,J) == 3) then + v_shlf(I,J) = CS%v_bdry_val(I,J) + elseif (CS%vmask(I,J) == 0) then + v_shlf(I,J) = 0 + endif + enddo ; enddo + + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) + + if (conv_flag == 0) then + iters = CS%cg_max_iterations + endif + +end subroutine ice_shelf_solve_inner + +!> CG (Conjugate Gradient) inner Krylov solve for ice shelf velocity. +subroutine ice_shelf_solve_inner_CG(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< Grounding line indicator [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< Ice shelf coverage mask + real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim] + real, intent(in) :: resid_scale !< Scaling for inner products + !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1] + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Subgridscale quadrature weights [nondim] + integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not + integer, intent(out) :: iters !< The number of iterations used + integer, intent(in) :: Is_sum !< Starting i-index for global sums + integer, intent(in) :: Js_sum !< Starting j-index for global sums + integer, intent(in) :: Ie_sum !< Ending i-index for global sums + integer, intent(in) :: Je_sum !< Ending j-index for global sums + integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays + integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays + + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + Ru, Rv, & ! Residuals [R L3 Z T-2 ~> m kg s-2] + Zu, Zv, & ! Preconditioned residuals [L T-1 ~> m s-1] + Du, Dv ! Search directions [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: sum_vec ! Pointwise D·A products for the alpha_k global sum + ! [kg m2 s-3] + real, dimension(SZDIB_(G),SZDJB_(G),2) :: sum_vec_3d ! Array used for various residuals + ! sum_vec_3d(:,:,1) [kg m2 s-3] + ! sum_vec_3d(:,:,2) [kg2 m2 s-4] + real :: beta_k ! Ratio of residuals used to update search direction [nondim] + real :: resid0tol2 ! Convergence tolerance times the initial residual [m2 kg2 s-4] + real :: sv3dsum ! An unused variable returned when taking global sum of residuals [various] + real :: sv3dsums(2) ! The index-wise global sums of sum_vec_3d + ! sv3dsums(1) [kg m2 s-3] + ! sv3dsums(2) [kg2 m2 s-4] + real :: alpha_k ! A scaling factor for iterative corrections [nondim] + real :: rho_old ! The preconditioned residual inner product Z·R from the previous CG + ! iteration, scaled by resid_scale [kg m2 s-3] + real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals + ! [T4 kg2 m2 R-2 Z-2 L-6 s-4 ~> 1] + integer :: cg_halo ! Number of halo vertices to include during a CG iteration + integer :: max_cg_halo ! Maximum possible number of halo vertices to include in the CG iterations + integer :: iter, i, j, isc, iec, jsc, jec, is, js, ie, je, is2, ie2, js2, je2 + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq, nx_halo, ny_halo + + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB + ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 - sum_vec(:,:) = 0.0 + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Zu(:,:) = 0 ; Zv(:,:) = 0 ; Du(:,:) = 0 ; Dv(:,:) = 0 + + Ru(:,:) = (RHSu(:,:) - Au(:,:)) ; Rv(:,:) = (RHSv(:,:) - Av(:,:)) + + ! current velocities used in CG_action for basal drag + u_curr(:,:) = u_shlf(:,:) ; v_curr(:,:) = v_shlf(:,:) + + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1) Zu(I,J) = Ru(I,J) * IDIAGu(I,J) + if (CS%vmask(I,J) == 1) Zv(I,J) = Rv(I,J) * IDIAGv(I,J) + Du(I,J) = Zu(I,J) + Dv(I,J) = Zv(I,J) + enddo ; enddo + + ! Compute rho_old = Z·R and resid0tol2 before the CG loop + sum_vec_3d(:,:,:) = 0.0 do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq - if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 - if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 + if (CS%umask(I,J) == 1) then + sum_vec_3d(I,J,1) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_3d(I,J,2) = resid2_scale * Ru(I,J)**2 + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid2_scale * Rv(I,J)**2 + endif enddo ; enddo - !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 ) + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) + + rho_old = sv3dsums(1) + !resid0 = sqrt(sv3dsums(2)) + resid0tol2 = CS%cg_tol_current**2 * sv3dsums(2) + + if (G%symmetric) then + max_cg_halo=min(nx_halo,ny_halo) + else + max_cg_halo=min(nx_halo,ny_halo)-1 + endif + cg_halo = max_cg_halo + conv_flag = 0 + + if (CS%cg_halo_shrink) then + is = isc - cg_halo ; ie = Iecq + cg_halo + js = jsc - cg_halo ; je = Jecq + cg_halo + is2 = is ; ie2 = ie-1 + js2 = js ; je2 = je-1 + else + is = isc - 1 ; ie = iec + 1 + js = jsc - 1 ; je = jec + 1 + is2 = Iscq ; ie2 = Iecq + js2 = Jscq ; je2 = Jecq + endif + + !!!!!!!!!!!!!!!!!! + !! !! + !! MAIN CG LOOP !! + !! !! + !!!!!!!!!!!!!!!!!! + + do iter = 1,CS%cg_max_iterations + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(CS, Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, u_curr, v_curr, & + G, US, is, ie, js, je, rhoi_rhow) + + sum_vec(:,:) = 0.0 + + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) sum_vec(I,J) = resid_scale * (Du(I,J) * Au(I,J)) + if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Dv(I,J) * Av(I,J)) + enddo ; enddo + + sv3dsum = reproducing_sum( sum_vec(:,:), Is_sum, Ie_sum, Js_sum, Je_sum ) + + if (sv3dsum == 0.0) then + iters = iter + conv_flag = 1 + exit + endif + + alpha_k = rho_old / sv3dsum + + do J=js2,je2 ; do I=is2,ie2 + if (CS%umask(I,J) == 1) then + u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) + Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) + Zu(I,J) = Ru(I,J) * IDIAGu(I,J) + endif + if (CS%vmask(I,J) == 1) then + v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) + Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) + Zv(I,J) = Rv(I,J) * IDIAGv(I,J) + endif + enddo ; enddo + + ! beta_k = (Z \dot R) / (Z_prev \dot R_prev) + 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_3d(I,J,1) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_3d(I,J,2) = resid2_scale * Ru(I,J)**2 + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid2_scale * Rv(I,J)**2 + endif + enddo ; enddo + + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) + + beta_k = sv3dsums(1) / rho_old + + if (sv3dsums(2) <= resid0tol2) then + iters = iter + conv_flag = 1 + exit + endif + + do J=js2,je2 ; do I=is2,ie2 + if (CS%umask(I,J) == 1) Du(I,J) = Zu(I,J) + beta_k * Du(I,J) + if (CS%vmask(I,J) == 1) Dv(I,J) = Zv(I,J) + beta_k * Dv(I,J) + enddo ; enddo + + rho_old = sv3dsums(1) + + if (CS%cg_halo_shrink) then + cg_halo = cg_halo - 1 + if (cg_halo == 0) then + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(Zu, Zv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.true.) + cg_halo = max_cg_halo + endif + is = isc - cg_halo ; ie = Iecq + cg_halo + js = jsc - cg_halo ; je = Jecq + cg_halo + is2 = is ; ie2 = ie-1 + js2 = js ; je2 = je-1 + else + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) + endif + + enddo ! end of CG loop + +end subroutine ice_shelf_solve_inner_CG + +!> MINRES inner Krylov solve for ice shelf velocity. +subroutine ice_shelf_solve_inner_MINRES(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< Grounding line indicator [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< Ice shelf coverage mask + real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim] + real, intent(in) :: resid_scale !< Scaling for inner products + !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1] + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Subgridscale quadrature weights [nondim] + integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not + integer, intent(out) :: iters !< The number of iterations used + integer, intent(in) :: Is_sum !< Starting i-index for global sums + integer, intent(in) :: Js_sum !< Starting j-index for global sums + integer, intent(in) :: Ie_sum !< Ending i-index for global sums + integer, intent(in) :: Je_sum !< Ending j-index for global sums + integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays + integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays + + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + V_old_u, V_old_v, V_curr_u, V_curr_v, V_new_u, V_new_v, & ! Lanczos basis vectors [R L3 Z T-2 ~> m kg s-2] + Z_curr_u, Z_curr_v, Z_new_u, Z_new_v, & ! Preconditioned Lanczos vectors [L T-1 ~> m s-1] + W_old_u, W_old_v, W_curr_u, W_curr_v, W_new_u, W_new_v, & ! MINRES search directions [L T-1 ~> m s-1] + Qu, Qv ! A * Z_curr [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: sum_vec_3d ! Pointwise products for global sums + ! [kg m2 s-3] before normalization; + ! [nondim] inside loop (after Lanczos normalization) + real :: alpha ! Lanczos diagonal element (Rayleigh quotient) [nondim] + real :: beta1 ! Current Lanczos off-diagonal coefficient; + ! initial value [kg^1/2 m s^-3/2], then [nondim] after iter 1 + real :: beta2 ! Next Lanczos off-diagonal coefficient [nondim] + real :: eta ! MINRES residual norm estimate [kg^1/2 m s^-3/2] + real :: eta_curr ! Effective step magnitude for current iteration [kg^1/2 m s^-3/2] + real :: c0, s0, c1, s1, c2, s2 ! Givens rotation cosines and sines [nondim] + real :: d0, d1, d2 ! Tridiagonal QR factorization coefficients [nondim] + real :: resid0tol ! Convergence tolerance (CS%cg_tol_newton * beta1) [kg^1/2 m s^-3/2] + real :: current_norm ! Current MINRES residual norm estimate [kg^1/2 m s^-3/2] + real :: sv3dsum ! Global reproducing sum of sum_vec_3d; + ! [kg m2 s-3] before normalization, [nondim] inside loop + real :: Ibeta1 ! Reciprocal of initial beta1 [kg^-1/2 m-1 s^3/2] + real :: Ibeta2 ! Reciprocal of beta2 [nondim] + real :: Id1 ! Reciprocal of d1 [nondim] + integer :: iter, i, j, isc, iec, jsc, jec + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq + + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + ! Initialize MINRES-specific arrays + V_old_u(:,:) = 0 ; V_old_v(:,:) = 0 ; V_curr_u(:,:) = 0 ; V_curr_v(:,:) = 0 + Z_curr_u(:,:) = 0 ; Z_curr_v(:,:) = 0 + W_old_u(:,:) = 0 ; W_old_v(:,:) = 0 ; W_curr_u(:,:) = 0 ; W_curr_v(:,:) = 0 + Qu(:,:) = 0 ; Qv(:,:) = 0 + + ! Initial Residual + V_curr_u(:,:) = (RHSu(:,:) - Au(:,:)) ; V_curr_v(:,:) = (RHSv(:,:) - Av(:,:)) + + ! current velocities used in CG_action for basal drag + u_curr(:,:) = u_shlf(:,:) ; v_curr(:,:) = v_shlf(:,:) + + do J=Jscq,Jecq ; do I=Iscq,Iecq + if (CS%umask(I,J) == 1) Z_curr_u(I,J) = V_curr_u(I,J) * IDIAGu(I,J) + if (CS%vmask(I,J) == 1) Z_curr_v(I,J) = V_curr_v(I,J) * IDIAGv(I,J) + enddo ; enddo + + sum_vec_3d(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) sum_vec_3d(I,J) = resid_scale * (V_curr_u(I,J) * Z_curr_u(I,J)) + if (CS%vmask(I,J) == 1) sum_vec_3d(I,J) = sum_vec_3d(I,J) + resid_scale * (V_curr_v(I,J) * Z_curr_v(I,J)) + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:), Is_sum, Ie_sum, Js_sum, Je_sum ) + + beta1 = sqrt(abs(sv3dsum)) + + if (beta1 == 0.0) then + conv_flag = 1 + iters = 0 + return + endif + + Ibeta1 = 1.0/beta1 + + ! Normalize initial Lanczos vectors + do J=Jscq,Jecq ; do I=Iscq,Iecq + if (CS%umask(I,J) == 1) then + V_curr_u(I,J) = V_curr_u(I,J) * Ibeta1 + Z_curr_u(I,J) = Z_curr_u(I,J) * Ibeta1 + endif + if (CS%vmask(I,J) == 1) then + V_curr_v(I,J) = V_curr_v(I,J) * Ibeta1 + Z_curr_v(I,J) = Z_curr_v(I,J) * Ibeta1 + endif + enddo ; enddo + + ! Sync Z_curr prior to entering the loop + call pass_vector(Z_curr_u, Z_curr_v, G%domain, TO_ALL, BGRID_NE) + + eta = beta1 + resid0tol = CS%cg_tol_current * beta1 + conv_flag = 0 + + c0 = 1.0 ; s0 = 0.0 ; c1 = 1.0 ; s1 = 0.0 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! !! + !! MAIN MINRES LANCZOS LOOP !! + !! !! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do iter = 1, CS%cg_max_iterations + + ! --- STEP 1: Matrix Vector Product --- + Qu(:,:) = 0 ; Qv(:,:) = 0 + call CG_action(CS, Qu, Qv, Z_curr_u, Z_curr_v, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, u_curr, v_curr, & + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + ! --- STEP 2: alpha = q dot z_curr --- + sum_vec_3d(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) sum_vec_3d(I,J) = resid_scale * (Qu(I,J) * Z_curr_u(I,J)) + if (CS%vmask(I,J) == 1) sum_vec_3d(I,J) = sum_vec_3d(I,J) + resid_scale * (Qv(I,J) * Z_curr_v(I,J)) + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:), Is_sum, Ie_sum, Js_sum, Je_sum ) + alpha = sv3dsum + + ! --- FUSED STEPS 3 & 4: Update V_new and Precondition to Z_new --- + do J=Jscq,Jecq ; do I=Iscq,Iecq + if (CS%umask(I,J) == 1) then + V_new_u(I,J) = Qu(I,J) - alpha * V_curr_u(I,J) - beta1 * V_old_u(I,J) + Z_new_u(I,J) = V_new_u(I,J) * IDIAGu(I,J) + endif + if (CS%vmask(I,J) == 1) then + V_new_v(I,J) = Qv(I,J) - alpha * V_curr_v(I,J) - beta1 * V_old_v(I,J) + Z_new_v(I,J) = V_new_v(I,J) * IDIAGv(I,J) + endif + enddo ; enddo + + ! --- STEP 5: beta2 = sqrt(v_new dot z_new) --- + sum_vec_3d(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) sum_vec_3d(I,J) = resid_scale * (V_new_u(I,J) * Z_new_u(I,J)) + if (CS%vmask(I,J) == 1) sum_vec_3d(I,J) = sum_vec_3d(I,J) + resid_scale * (V_new_v(I,J) * Z_new_v(I,J)) + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:), Is_sum, Ie_sum, Js_sum, Je_sum ) + beta2 = sqrt(abs(sv3dsum)) + + ! --- STEP 6: Apply Givens Rotations --- + d0 = c1 * alpha - c0 * s1 * beta1 + d1 = sqrt(d0**2 + beta2**2) + + if (d1 == 0.0) then + iters = iter + conv_flag = 1 + exit + endif - do J=Jsdq,Jedq ; do I=Isdq,Iedq - if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J) - if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) Zv(I,J) = Rv(I,J) / DIAGv(I,J) - enddo ; enddo + Id1 = 1.0 / d1 + if (beta2 > 0) Ibeta2 = 1.0 / beta2 + + d2 = s1 * alpha + c0 * c1 * beta1 + c2 = d0 * Id1 + s2 = beta2 * Id1 + + eta_curr = c2 * eta + eta = -s2 * eta + current_norm = abs(eta) + + ! --- FUSED STEPS 7 & 9: Update u/v, Check Convergence, and Shift Vectors --- + do J=Jscq,Jecq ; do I=Iscq,Iecq + if (CS%umask(I,J) == 1) then + W_new_u(I,J) = (Z_curr_u(I,J) - (d2 * W_curr_u(I,J) + beta1 * s0 * W_old_u(I,J))) * Id1 + u_shlf(I,J) = u_shlf(I,J) + eta_curr * W_new_u(I,J) + if (beta2 > 0.0) then + V_old_u(I,J) = V_curr_u(I,J) + V_curr_u(I,J) = V_new_u(I,J) * Ibeta2 + Z_curr_u(I,J) = Z_new_u(I,J) * Ibeta2 + W_old_u(I,J) = W_curr_u(I,J) + W_curr_u(I,J) = W_new_u(I,J) + endif + endif + if (CS%vmask(I,J) == 1) then + W_new_v(I,J) = (Z_curr_v(I,J) - (d2 * W_curr_v(I,J) + beta1 * s0 * W_old_v(I,J))) * Id1 + v_shlf(I,J) = v_shlf(I,J) + eta_curr * W_new_v(I,J) + if (beta2 > 0.0) then + V_old_v(I,J) = V_curr_v(I,J) + V_curr_v(I,J) = V_new_v(I,J) * Ibeta2 + Z_curr_v(I,J) = Z_new_v(I,J) * Ibeta2 + W_old_v(I,J) = W_curr_v(I,J) + W_curr_v(I,J) = W_new_v(I,J) + endif + endif + enddo ; enddo - Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) + ! --- STEP 8: Check Convergence --- + if (current_norm <= resid0tol .or. beta2 == 0.0) then + iters = iter + conv_flag = 1 + exit + endif - if (G%symmetric) then - max_cg_halo=min(nx_halo,ny_halo) - else - max_cg_halo=min(nx_halo,ny_halo)-1 - endif - cg_halo = max_cg_halo - conv_flag = 0 + ! Sync Z_curr for the next iteration's CG_action + call pass_vector(Z_curr_u, Z_curr_v, G%domain, TO_ALL, BGRID_NE) - !!!!!!!!!!!!!!!!!! - !! !! - !! MAIN CG LOOP !! - !! !! - !!!!!!!!!!!!!!!!!! + beta1 = beta2 + c0 = c1 ; c1 = c2 + s0 = s1 ; s1 = s2 - ! initially, c-grid data is valid up to 3 halo nodes out + enddo ! end of MINRES loop - do iter = 1,CS%cg_max_iterations +end subroutine ice_shelf_solve_inner_MINRES - ! we can never assume that any arrays are legit more than 3 vertices past - ! the computational domain - this is their state in the initial iteration +!> CR (Conjugate Residual) inner Krylov solve for ice shelf velocity. +subroutine ice_shelf_solve_inner_CR(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< Grounding line indicator [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< Ice shelf coverage mask + real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim] + real, intent(in) :: resid_scale !< Scaling for inner products + !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1] + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Subgridscale quadrature weights [nondim] + integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not + integer, intent(out) :: iters !< The number of iterations used + integer, intent(in) :: Is_sum !< Starting i-index for global sums + integer, intent(in) :: Js_sum !< Starting j-index for global sums + integer, intent(in) :: Ie_sum !< Ending i-index for global sums + integer, intent(in) :: Je_sum !< Ending j-index for global sums + integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays + integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays + + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + Ru, Rv, & ! Residuals (r) [R L3 Z T-2 ~> m kg s-2] + Zu, Zv, & ! Preconditioned residuals (z = M^-1 r) [L T-1 ~> m s-1] + Du, Dv, & ! Search directions (p) [L T-1 ~> m s-1] + Qu, Qv ! A * p [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G),2) :: sum_vec_3d ! Pointwise products for global sums. + ! sum_vec_3d(:,:,1): r^2 [kg2 m2 s-4] or z·q [kg m2 s-3] (context-dependent) + ! sum_vec_3d(:,:,2): z·w or q·(M^-1 q) [kg m2 s-3] + real :: alpha ! Step length [nondim] + real :: beta ! Direction update coefficient [nondim] + real :: r_norm_sq ! Squared residual norm [kg2 m2 s-4] + real :: z_w_sum ! Inner product (z_k, A z_k); beta denominator [kg m2 s-3] + real :: z_w_sum_new ! Inner product (z_{k+1}, A z_{k+1}); beta numerator [kg m2 s-3] + real :: z_q_sum ! Inner product (z_k, A p_k); alpha numerator [kg m2 s-3] + real :: q_s_sum ! Inner product (A p_k, M^-1 A p_k); alpha denom [kg m2 s-3] + real :: resid0tol2 ! Convergence threshold: tol^2 * ||r_0||^2 [kg2 m2 s-4] + real :: sv3dsum ! Unused scalar return from reproducing_sum [various] + real :: sv3dsums(2) ! Component sums from reproducing_sum + ! sv3dsums(1): r^2 or z·q [kg2 m2 s-4 or kg m2 s-3] (context-dependent) + ! sv3dsums(2): z·w or q·M^-1 q [kg m2 s-3] + real :: resid2_scale ! Scaling for squared-stress inner products [T4 kg2 m2 R-2 Z-2 L-6 s-4 ~> 1] + integer :: iter, i, j, isc, iec, jsc, jec + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq - is = isc - cg_halo ; ie = Iecq + cg_halo - js = jsc - cg_halo ; je = Jecq + cg_halo + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - Au(:,:) = 0 ; Av(:,:) = 0 + resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 - call CG_action(CS, Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & - G, US, is, ie, js, je, rhoi_rhow) + ! Initialize CR-specific arrays + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Zu(:,:) = 0 ; Zv(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 ; Qu(:,:) = 0 ; Qv(:,:) = 0 - ! Au, Av valid region moves in by 1 + ! r_0 = b - A*x_0 + Ru(:,:) = (RHSu(:,:) - Au(:,:)) ; Rv(:,:) = (RHSv(:,:) - Av(:,:)) - call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE) + ! current velocities used in CG_action for basal drag + u_curr(:,:) = u_shlf(:,:) ; v_curr(:,:) = v_shlf(:,:) - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + ! z_0 = M^-1 r_0 + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1) Zu(I,J) = Ru(I,J) * IDIAGu(I,J) + if (CS%vmask(I,J) == 1) Zv(I,J) = Rv(I,J) * IDIAGv(I,J) + enddo ; enddo - 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)) - 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)) - Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) - endif - enddo ; enddo + ! p_0 = z_0 + Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) - 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 ) + ! Compute A * z_0 + Au(:,:) = 0 ; Av(:,:) = 0 + call CG_action(CS, Au, Av, Zu, Zv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, u_curr, v_curr, & + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - do J=js,je-1 ; do I=is,ie-1 - if (CS%umask(I,J) == 1) then - u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) - Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) - if (DIAGu(I,J)/=0) Zu(I,J) = Ru(I,J) / DIAGu(I,J) - endif - if (CS%vmask(I,J) == 1) then - v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) - 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 + ! q_0 = A * p_0 + Qu(:,:) = Au(:,:) ; Qv(:,:) = Av(:,:) + ! Initial Norms + sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) then + sum_vec_3d(I,J,1) = resid2_scale * Ru(I,J)**2 + sum_vec_3d(I,J,2) = resid_scale * (Zu(I,J) * Au(I,J)) + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid2_scale * Rv(I,J)**2 + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid_scale * (Zv(I,J) * Av(I,J)) + endif + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) - ! R,u,v,Z valid region moves in by 1 + r_norm_sq = sv3dsums(1) + z_w_sum = sv3dsums(2) - ! beta_k = (Z \dot R) / (Zold \dot Rold) - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 ; sum_vec_3(:,:) = 0.0 + resid0tol2 = CS%cg_tol_current**2 * r_norm_sq + conv_flag = 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 - 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 - endif - enddo ; enddo + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! !! + !! MAIN CONJUGATE RESIDUAL LOOP !! + !! !! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - 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 ) + do iter = 1, CS%cg_max_iterations - 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) - if (CS%vmask(I,J) == 1) Dv(I,J) = Zv(I,J) + beta_k * Dv(I,J) + ! --- STEP 1: alpha = (z_k, q_k) / (q_k, M^-1 q_k) --- + sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) then + sum_vec_3d(I,J,1) = resid_scale * (Zu(I,J) * Qu(I,J)) + ! Order matters to prevent float overflow: Q * (Q * IDiag) + sum_vec_3d(I,J,2) = resid_scale * (Qu(I,J) * (Qu(I,J) * IDIAGu(I,J))) + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid_scale * (Zv(I,J) * Qv(I,J)) + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid_scale * (Qv(I,J) * (Qv(I,J) * IDIAGv(I,J))) + endif enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) - ! D valid region moves in by 1 + z_q_sum = sv3dsums(1) + q_s_sum = sv3dsums(2) - 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 (q_s_sum == 0.0) then iters = iter conv_flag = 1 exit endif + alpha = z_q_sum / q_s_sum + + ! --- STEP 2: Update x, r, and z (Fused over Full Domain) --- + ! Zu halos are populated here since the loop covers Jsdq..Jedq; no pass_vector needed. + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1) then + u_shlf(I,J) = u_shlf(I,J) + alpha * Du(I,J) + Ru(I,J) = Ru(I,J) - alpha * Qu(I,J) + Zu(I,J) = Ru(I,J) * IDIAGu(I,J) + endif + if (CS%vmask(I,J) == 1) then + v_shlf(I,J) = v_shlf(I,J) + alpha * Dv(I,J) + Rv(I,J) = Rv(I,J) - alpha * Qv(I,J) + Zv(I,J) = Rv(I,J) * IDIAGv(I,J) + endif + enddo ; enddo - cg_halo = cg_halo - 1 + ! --- STEP 3: w_{k+1} = A z_{k+1} --- + Au(:,:) = 0 ; Av(:,:) = 0 + call CG_action(CS, Au, Av, Zu, Zv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, u_curr, v_curr, & + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - if (cg_halo == 0) then - ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.false.) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.true.) - cg_halo = max_cg_halo - endif + ! --- STEP 4: beta and convergence check --- + sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) then + sum_vec_3d(I,J,1) = resid2_scale * Ru(I,J)**2 + sum_vec_3d(I,J,2) = resid_scale * (Zu(I,J) * Au(I,J)) + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid2_scale * Rv(I,J)**2 + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid_scale * (Zv(I,J) * Av(I,J)) + endif + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) - enddo ! end of CG loop + r_norm_sq = sv3dsums(1) + z_w_sum_new = sv3dsums(2) - do J=Jsdq,Jedq ; do I=Isdq,Iedq - if (CS%umask(I,J) == 3) then - u_shlf(I,J) = CS%u_bdry_val(I,J) - elseif (CS%umask(I,J) == 0) then - u_shlf(I,J) = 0 - endif + if (r_norm_sq <= resid0tol2 .or. z_w_sum==0.0) then + iters = iter + conv_flag = 1 + exit + endif - if (CS%vmask(I,J) == 3) then - v_shlf(I,J) = CS%v_bdry_val(I,J) - elseif (CS%vmask(I,J) == 0) then - v_shlf(I,J) = 0 - endif - enddo ; enddo + beta = z_w_sum_new / z_w_sum + z_w_sum = z_w_sum_new + + ! --- STEP 5: Update p and q --- + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1) then + Du(I,J) = Zu(I,J) + beta * Du(I,J) + Qu(I,J) = Au(I,J) + beta * Qu(I,J) + endif + if (CS%vmask(I,J) == 1) then + Dv(I,J) = Zv(I,J) + beta * Dv(I,J) + Qv(I,J) = Av(I,J) + beta * Qv(I,J) + endif + enddo ; enddo - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - if (conv_flag == 0) then - iters = CS%cg_max_iterations - endif + enddo ! end of CR loop -end subroutine ice_shelf_solve_inner +end subroutine ice_shelf_solve_inner_CR subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after_uflux, uh_ice) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure @@ -2404,14 +3266,14 @@ 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 :: rho, rhow ! Ice and ocean densities [R ~> kg m-3] + 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,126 +3284,105 @@ 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 rho = CS%density_ice rhow = CS%density_ocean_avg grav = CS%g_Earth - rhoi_rhow = rho/rhow ! 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 (CS%rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) <= 0) then + S(i,j) = (1 - CS%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 - 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) + ! 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 - 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)) @@ -2551,9 +3392,10 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) !Stress (Neumann) boundary conditions if (CS%ground_frac(i,j) == 1) then - neumann_val = ((.5 * grav) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2 - rhow * CS%bed_elev(i,j)**2)) + neumann_val = ((.5 * grav) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2 - & + rhow * max(0.0, CS%bed_elev(i,j))**2)) else - neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2)) + neumann_val = (.5 * grav) * ((1-CS%rhoi_rhow) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2)) endif if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (CS%reentrant_x .OR. (i+i_off /= gisc)))) then @@ -2566,42 +3408,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%dyCu(I-1,j) * neumann_val + taudx(I-1,J) = taudx(I-1,J) - .5 * G%dyCu(I-1,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%dyCu(I,j) * neumann_val + taudx(I,J) = taudx(I,J) + .5 * G%dyCu(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%dxCv(i,J-1) * neumann_val + taudy(I,J-1) = taudy(I,J-1) - .5 * G%dxCv(i,J-1) * 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%dxCv(i,J) * neumann_val + taudy(I,J) = taudy(I,J) + .5 * G%dxCv(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, u_curr, v_curr, 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. @@ -2635,14 +3481,17 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not + intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points !! relative to sea-level [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear - !! part of the "linearized" basal stress [R Z L2 T-1 ~> kg s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional @@ -2651,6 +3500,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, @@ -2672,12 +3522,25 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, ! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear 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 :: uq, vq ! Interpolated direction-vector δu at quadrature point [L T-1 ~> m s-1] + real :: strx_n, stry_n, strsh_n, dstrain_n ! Newton viscosity correction variables [T-1 ~> s-1], [T-2 ~> s-2] + real :: u_curr_qp, v_curr_qp ! Current iterate u^k at quadrature point [L T-1 ~> m s-1] + real :: unorm2_qp ! Regularized squared speed of u^k at quadrature point [L2 T-2 ~> m2 s-2] + real :: basal_coef_qp ! Picard basal friction coefficient at quadrature point [R L2 Z T-1 ~> kg s-1] + real :: drag_newt_qp ! Newton basal drag coefficient at quadrature point [R Z T-1 ~> kg m-2 s-1] + real :: inner_dot_qp ! u^k_qp · δu_qp inner product for Newton basal drag [L2 T-2 ~> m2 s-2] + real :: coef_prefactor_e ! Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1] + real :: eps_vel2_e ! Velocity regularization squared for current element [L2 T-2 ~> m2 s-2] + real :: min_trac_e ! min_basal_traction * areaT for current element [R L2 Z T-1 ~> kg s-1] + real :: fB_e ! Pre-computed Coulomb fB for element; 0 for Weertman [(T L-1)^CF_PostPeak] + real :: jac_wt ! Per-quadrature-point metric correction |J_q|/areaT [nondim] integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt, qp, qpv logical :: visc_qp4 + logical :: use_newton ! Whether to apply Newton tangent stiffness corrections + logical :: do_newton_visc ! Whether to apply viscosity-related Newton tangent stiffness corrections real, dimension(2) :: xquad ! Nondimensional quadrature ratios [nondim] - real, dimension(2,2) :: Ucell, Vcell, Usub, Vsub ! Velocities at the nodal points around the cell [L T-1 ~> m s-1] - real, dimension(2,2) :: Hcell ! Ice shelf thickness at notal (corner) points [Z ~> m] + real, dimension(2,2) :: Usub, Vsub ! Subgrid nodal contributions to basal traction [R L3 Z T-2 ~> kg m s-2] + real, dimension(2,2) :: Hcell ! Ice shelf thickness at nodal (corner) points [Z ~> m] real, dimension(2,2,4) :: uret_qp, vret_qp ! Temporary arrays in [R Z L3 T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G),4) :: uret_b, vret_b ! Temporary arrays in [R Z L3 T-2 ~> kg m s-2] @@ -2690,12 +3553,23 @@ 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 + + ! Pre-computed element-level basal friction quantities (updated each outer Newton iteration + ! by calc_shelf_basal_prefactors; avoids O(N_cg) recomputation of expensive prefactors). + coef_prefactor_e = CS%coef_prefactor(i,j) + eps_vel2_e = CS%eps_glen_min**2 * ((G%dxT(i,j)**2) + (G%dyT(i,j)**2)) + min_trac_e = CS%min_basal_traction * G%areaT(i,j) + fB_e = CS%fB_elem(i,j) ! 0 for Weertman; non-zero for Coulomb do iq=1,2 ; do jq=1,2 @@ -2733,21 +3607,80 @@ 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 + + ! Basal friction and Newton Jacobian evaluated at this quadrature point (fully grounded cells only). + ! Evaluating at quadrature points rather than cell-averaged ensures the Newton correction is the + ! exact Jacobian of the Picard residual, enabling quadratic convergence for all friction exponents. + if (float_cond(i,j) == 0 .and. CS%ground_frac(i,j)>0) then + u_curr_qp = ((u_curr(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (u_curr(I,J) * (xquad(iq) * xquad(jq)))) + & + ((u_curr(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (u_curr(I-1,J) * (xquad(3-iq) * xquad(jq)))) + v_curr_qp = ((v_curr(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (v_curr(I,J) * (xquad(iq) * xquad(jq)))) + & + ((v_curr(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (v_curr(I-1,J) * (xquad(3-iq) * xquad(jq)))) + unorm2_qp = ((u_curr_qp**2) + (v_curr_qp**2)) + eps_vel2_e + call compute_basal_coef(unorm2_qp, coef_prefactor_e, min_trac_e, fB_e, & + CS%n_basal_fric, CS%CoulombFriction, CS%CF_PostPeak, US%L_T_to_m_s, use_newton, & + basal_coef_qp, drag_newt_qp) + ! Apply ground fraction scaling (replaces external scaling of basal_traction) + basal_coef_qp = basal_coef_qp * CS%ground_frac(i,j) + if (use_newton) then + drag_newt_qp = drag_newt_qp * CS%ground_frac(i,j) + ! Inner product u^k_qp . delta_u_qp for the Newton correction. + inner_dot_qp = (u_curr_qp * uq) + (v_curr_qp * vq) + endif + endif + + ! Ratio |J_q|/areaT corrects the uniform-area weight baked into ice_visc for + ! non-rectangular elements where opposite cell edges have unequal lengths. + jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) + do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi - if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = jac_wt * ice_visc(i,j,qpv) * & (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & ((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) - if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = jac_wt * ice_visc(i,j,qpv) * & (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & ((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) - if (float_cond(i,j) == 0) then + ! Newton viscosity tangent stiffness: (dη/dε_e^2) * (g·δε) * (g·φ_m). + if (do_newton_visc) then + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_visc_factor(i,j,qpv) * dstrain_n * & + (((2.*strx_n + stry_n) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + (strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_visc_factor(i,j,qpv) * dstrain_n * & + ((strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((2.*stry_n + strx_n) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) + endif + + if (float_cond(i,j) == 0 .and. CS%ground_frac(i,j)>0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & - ((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))) + ! Picard basal drag: C*|u^k|^(m-1) * δu evaluated at quadrature point, weighted by φ_m + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & + (jac_wt * (basal_coef_qp * uq) * (xquad(ilq) * xquad(jlq))) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & + (jac_wt * (basal_coef_qp * vq) * (xquad(ilq) * xquad(jlq))) + ! Newton basal drag: pointwise Jacobian of the Picard residual. + ! Tangent stiffness = basal_coef_qp*I + drag_newt_qp * u^k_qp ⊗ u^k_qp + if (use_newton) then + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & + jac_wt * drag_newt_qp * u_curr_qp * inner_dot_qp * (xquad(ilq) * xquad(jlq)) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & + jac_wt * drag_newt_qp * v_curr_qp * inner_dot_qp * (xquad(ilq) * xquad(jlq)) + endif endif enddo ; enddo enddo ; enddo @@ -2769,103 +3702,225 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, vret_b(I ,J ,1) = 0.25*((vret_qp(2,2,1)+vret_qp(2,2,4))+(vret_qp(2,2,2)+vret_qp(2,2,3))) if (float_cond(i,j) == 1) then - Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) + ! Subgrid grounding-line: evaluate basal friction at each grounded sub-quadrature point. + ! Picard and Newton Jacobian are both computed inside CG_action_subgrid_basal. Hcell(:,:) = H_node(I-1:I,J-1:J) - - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, & - bathyT(i,j), dens_ratio, Usub, Vsub) - - if (umask(I-1,J-1) == 1) uret_b(I-1,J-1,4) = uret_b(I-1,J-1,4) + (Usub(1,1) * basal_trac(i,j)) - if (umask(I-1,J ) == 1) uret_b(I-1,J ,2) = uret_b(I-1,J ,2) + (Usub(1,2) * basal_trac(i,j)) - if (umask(I ,J-1) == 1) uret_b(I ,J-1,3) = uret_b(I ,J-1,3) + (Usub(2,1) * basal_trac(i,j)) - if (umask(I ,J ) == 1) uret_b(I ,J ,1) = uret_b(I ,J ,1) + (Usub(2,2) * basal_trac(i,j)) - - if (vmask(I-1,J-1) == 1) vret_b(I-1,J-1,4) = vret_b(I-1,J-1,4) + (Vsub(1,1) * basal_trac(i,j)) - if (vmask(I-1,J ) == 1) vret_b(I-1,J ,2) = vret_b(I-1,J ,2) + (Vsub(1,2) * basal_trac(i,j)) - if (vmask(I ,J-1) == 1) vret_b(I ,J-1,3) = vret_b(I ,J-1,3) + (Vsub(2,1) * basal_trac(i,j)) - if (vmask(I ,J ) == 1) vret_b(I ,J ,1) = vret_b(I ,J ,1) + (Vsub(2,2) * basal_trac(i,j)) + call CG_action_subgrid_basal(CS, G, US, Phisub, Hcell, & + u_curr(I-1:I,J-1:J), v_curr(I-1:I,J-1:J), & + u_shlf(I-1:I,J-1:J), v_shlf(I-1:I,J-1:J), & + bathyT(i,j), dens_ratio, i, j, fB_e, use_newton, Usub, Vsub, & + G%dxCv(i,j-1), G%dxCv(i,j), G%dyCu(i-1,j), G%dyCu(i,j), G%IareaT(i,j)) + if (umask(I-1,J-1) == 1) uret_b(I-1,J-1,4) = uret_b(I-1,J-1,4) + Usub(1,1) + if (umask(I-1,J ) == 1) uret_b(I-1,J ,2) = uret_b(I-1,J ,2) + Usub(1,2) + if (umask(I ,J-1) == 1) uret_b(I ,J-1,3) = uret_b(I ,J-1,3) + Usub(2,1) + if (umask(I ,J ) == 1) uret_b(I ,J ,1) = uret_b(I ,J ,1) + Usub(2,2) + if (vmask(I-1,J-1) == 1) vret_b(I-1,J-1,4) = vret_b(I-1,J-1,4) + Vsub(1,1) + if (vmask(I-1,J ) == 1) vret_b(I-1,J ,2) = vret_b(I-1,J ,2) + Vsub(1,2) + if (vmask(I ,J-1) == 1) vret_b(I ,J-1,3) = vret_b(I ,J-1,3) + Vsub(2,1) + if (vmask(I ,J ) == 1) vret_b(I ,J ,1) = vret_b(I ,J ,1) + Vsub(2,2) 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 -subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, Vcontr) - real, dimension(:,:,:,:,:,:), & - intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations [nondim] - real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. - real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] - real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] - real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points - !! relative to sea-level [Z ~> m]. - real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater [nondim] - real, dimension(2,2), intent(out) :: Ucontr !< The areal average of u-velocities where the ice shelf - !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. - real, dimension(2,2), intent(out) :: Vcontr !< The areal average of v-velocities where the ice shelf - !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. - - real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: Ucontr_sub, Vcontr_sub ! The contributions to Ucontr and Vcontr - !! at each sub-cell - real, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: uloc_arr !The local sub-cell u-velocity [L T-1 ~> m s-1] - real, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: vloc_arr !The local sub-cell v-velocity [L T-1 ~> m s-1] - real, dimension(2,2) :: Ucontr_q, Vcontr_q !Contributions to a node from each quadrature point in a sub-grid cell - real :: subarea ! The fractional sub-cell area [nondim] - real :: hloc ! The local sub-cell ice thickness [Z ~> m] +!> Compute subgrid grounding-line basal traction nodal contributions for a CG action. +!! Evaluates basal friction (Picard and Newton Jacobian) at each grounded sub-quadrature point. +!! The sub-qp flotation test accounts for partial grounding; no external ground_frac scaling needed. +subroutine CG_action_subgrid_basal(CS, G, US, Phisub, H, U_curr, V_curr, U_delta, V_delta, & + bathyT, dens_ratio, i_elem, j_elem, fB_e, use_newton, Ucontr, Vcontr, & + dxCv_S, dxCv_N, dyCu_W, dyCu_E, IareaT) + type(ice_shelf_dyn_CS), intent(in) :: CS !< Ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure + type(unit_scale_type), intent(in) :: US !< Unit conversion factors + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Sub-grid quadrature weights [nondim] + real, dimension(2,2), intent(in) :: H !< Ice thickness at element corners [Z ~> m] + real, dimension(2,2), intent(in) :: U_curr !< Frozen u^k at element corners [L T-1 ~> m s-1] + real, dimension(2,2), intent(in) :: V_curr !< Frozen v^k at element corners [L T-1 ~> m s-1] + real, dimension(2,2), intent(in) :: U_delta !< Search direction δu at element corners [L T-1 ~> m s-1] + real, dimension(2,2), intent(in) :: V_delta !< Search direction δv at element corners [L T-1 ~> m s-1] + real, intent(in) :: bathyT !< Ocean bathymetry depth at tracer point [Z ~> m] + real, intent(in) :: dens_ratio !< Ice density / water density [nondim] + integer, intent(in) :: i_elem !< Tracer-grid i-index of the element + integer, intent(in) :: j_elem !< Tracer-grid j-index of the element + real, intent(in) :: fB_e !< Element Coulomb parameter fB; 0 for Weertman [(T L-1)^CF_PostPeak] + logical, intent(in) :: use_newton !< If true, include Newton basal drag correction + real, dimension(2,2), intent(out) :: Ucontr !< Nodal u-contributions with friction applied [R L3 Z T-2 ~> kg m s-2] + real, dimension(2,2), intent(out) :: Vcontr !< Nodal v-contributions with friction applied [R L3 Z T-2 ~> kg m s-2] + real, intent(in) :: dxCv_S !< The cell width at the southern (v-point) edge [L ~> m] + real, intent(in) :: dxCv_N !< The cell width at the northern (v-point) edge [L ~> m] + real, intent(in) :: dyCu_W !< The cell height at the western (u-point) edge [L ~> m] + real, intent(in) :: dyCu_E !< The cell height at the eastern (u-point) edge [L ~> m] + real, intent(in) :: IareaT !< The inverse of the cell area at the tracer point [L-2 ~> m-2] + + real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: Ucontr_sub, Vcontr_sub ! The contributions to Ucontr and Vcontr + !! at each sub-cell + real, dimension(2,2,2,2) :: U_qp_nd, V_qp_nd ! Per-qp nodal contributions (qx,qy,m,n) + ! accumulated then pair-summed for rotation invariance + real :: hloc ! Local sub-cell ice thickness [Z ~> m] + real :: u_curr_loc ! Frozen u^k interpolated to sub-qp [L T-1 ~> m s-1] + real :: v_curr_loc ! Frozen v^k interpolated to sub-qp [L T-1 ~> m s-1] + real :: u_delta_loc ! Search direction δu interpolated to sub-qp [L T-1 ~> m s-1] + real :: v_delta_loc ! Search direction δv interpolated to sub-qp [L T-1 ~> m s-1] + real :: unorm2_loc ! Regularized |u^k|^2 at sub-qp [L2 T-2 ~> m2 s-2] + real :: basal_coef_loc ! Picard friction coefficient at sub-qp [R L2 Z T-1 ~> kg s-1] + real :: drag_newt_loc ! Newton drag coefficient at sub-qp [R Z T ~> kg m-2 s] + real :: inner_dot_loc ! u^k · δu inner product at sub-qp [L2 T-2 ~> m2 s-2] + real :: phi_mn ! Basis function value at sub-qp [nondim] + real :: contrib ! Quadrature weight contribution [nondim] + real :: coef_prefactor ! Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1] + real :: min_trac_area ! Minimum area-integrated traction floor [R L2 Z T-1 ~> kg s-1] + real :: eps_vel2 ! Velocity regularization squared [L2 T-2 ~> m2 s-2] + real :: jac_sub_wt ! Per-sub-cell-QP metric correction |J_sub|/areaT [nondim] + real :: a, d ! Interpolated cell-edge spacings at the sub-cell QP [L ~> m] + real :: subarea ! Fractional sub-cell area [nondim] integer :: nsub, i, j, qx, qy, m, n - nsub = size(Phisub,3) - subarea = 1.0 / (nsub**2) + nsub = size(Phisub, 3) + subarea = 1.0 / real(nsub)**2 - uloc_arr(:,:,:,:) = 0.0; vloc_arr(:,:,:,:)=0.0 + coef_prefactor = CS%coef_prefactor(i_elem,j_elem) + min_trac_area = CS%min_basal_traction * G%areaT(i_elem,j_elem) + eps_vel2 = CS%eps_glen_min**2 * ((G%dxT(i_elem,j_elem)**2) + (G%dyT(i_elem,j_elem)**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 - uloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * U(1,1)) + (Phisub(qx,qy,i,j,2,2) * U(2,2))) + & - ((Phisub(qx,qy,i,j,1,2) * U(1,2)) + (Phisub(qx,qy,i,j,2,1) * U(2,1)))) - vloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * V(1,1)) + (Phisub(qx,qy,i,j,2,2) * V(2,2))) + & - ((Phisub(qx,qy,i,j,1,2) * V(1,2)) + (Phisub(qx,qy,i,j,2,1) * V(2,1)))) - endif - enddo; enddo ; enddo ; enddo + Ucontr_sub(:,:,:,:) = 0.0 ; Vcontr_sub(:,:,:,:) = 0.0 - do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub + do j=1,nsub ; do i=1,nsub + U_qp_nd(:,:,:,:) = 0.0 ; V_qp_nd(:,:,:,:) = 0.0 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 + 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 ! grounded sub-qp + u_curr_loc = (((Phisub(qx,qy,i,j,1,1)*U_curr(1,1)) + (Phisub(qx,qy,i,j,2,2)*U_curr(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*U_curr(1,2)) + (Phisub(qx,qy,i,j,2,1)*U_curr(2,1)))) + v_curr_loc = (((Phisub(qx,qy,i,j,1,1)*V_curr(1,1)) + (Phisub(qx,qy,i,j,2,2)*V_curr(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*V_curr(1,2)) + (Phisub(qx,qy,i,j,2,1)*V_curr(2,1)))) + u_delta_loc = (((Phisub(qx,qy,i,j,1,1)*U_delta(1,1)) + (Phisub(qx,qy,i,j,2,2)*U_delta(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*U_delta(1,2)) + (Phisub(qx,qy,i,j,2,1)*U_delta(2,1)))) + v_delta_loc = (((Phisub(qx,qy,i,j,1,1)*V_delta(1,1)) + (Phisub(qx,qy,i,j,2,2)*V_delta(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*V_delta(1,2)) + (Phisub(qx,qy,i,j,2,1)*V_delta(2,1)))) + + unorm2_loc = ((u_curr_loc**2) + (v_curr_loc**2)) + eps_vel2 + call compute_basal_coef(unorm2_loc, coef_prefactor, min_trac_area, fB_e, & + CS%n_basal_fric, CS%CoulombFriction, CS%CF_PostPeak, US%L_T_to_m_s, use_newton, & + basal_coef_loc, drag_newt_loc) + inner_dot_loc = (u_curr_loc * u_delta_loc) + (v_curr_loc * v_delta_loc) + + ! Interpolate cell-edge metrics to the sub-cell QP using the bilinear shape function values + ! from bilinear_shape_functions_subgrid. Marginal sums of Phisub give the interpolation + ! weights: sum over k=1 nodes gives (1-y); k=2 gives y; l=1 gives (1-x); l=2 gives x. + ! This is analogous to jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) in the regular routines. + a = (dxCv_S * (Phisub(qx,qy,i,j,1,1) + Phisub(qx,qy,i,j,2,1))) + & ! (1-y) * dxCv_S + (dxCv_N * (Phisub(qx,qy,i,j,1,2) + Phisub(qx,qy,i,j,2,2))) ! + y * dxCv_N + d = (dyCu_W * (Phisub(qx,qy,i,j,1,1) + Phisub(qx,qy,i,j,1,2))) + & ! (1-x) * dyCu_W + (dyCu_E * (Phisub(qx,qy,i,j,2,1) + Phisub(qx,qy,i,j,2,2))) ! + x * dyCu_E + jac_sub_wt = 0.25 * subarea * (a * d) * IareaT + + do n=1,2 ; do m=1,2 + phi_mn = Phisub(qx,qy,i,j,m,n) + contrib = jac_sub_wt * phi_mn + ! Picard: friction matrix applied to search direction δu + U_qp_nd(qx,qy,m,n) = contrib * (basal_coef_loc * u_delta_loc) + V_qp_nd(qx,qy,m,n) = contrib * (basal_coef_loc * v_delta_loc) + ! Newton: Jacobian d(tau_b_i)/d(u_j) = basal_coef*I + drag_newt*u^k_i*u^k_j + if (use_newton) then + U_qp_nd(qx,qy,m,n) = U_qp_nd(qx,qy,m,n) + (contrib * (drag_newt_loc * u_curr_loc * inner_dot_loc)) + V_qp_nd(qx,qy,m,n) = V_qp_nd(qx,qy,m,n) + (contrib * (drag_newt_loc * v_curr_loc * inner_dot_loc)) + endif + enddo ; enddo + endif + 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 + do n=1,2 ; do m=1,2 + Ucontr_sub(i,j,m,n) = (U_qp_nd(1,1,m,n) + U_qp_nd(2,2,m,n)) + & + (U_qp_nd(1,2,m,n) + U_qp_nd(2,1,m,n)) + Vcontr_sub(i,j,m,n) = (V_qp_nd(1,1,m,n) + V_qp_nd(2,2,m,n)) + & + (V_qp_nd(1,2,m,n) + V_qp_nd(2,1,m,n)) + enddo ; enddo + enddo ; enddo - !sum up the sub-cell contributions to each node do n=1,2 ; do m=1,2 - call sum_square_matrix(Ucontr(m,n),Ucontr_sub(:,:,m,n),nsub) - call sum_square_matrix(Vcontr(m,n),Vcontr_sub(:,:,m,n),nsub) + call sum_square_matrix(Ucontr(m,n), Ucontr_sub(:,:,m,n), nsub) + call sum_square_matrix(Vcontr(m,n), Vcontr_sub(:,:,m,n), nsub) enddo ; enddo end subroutine CG_action_subgrid_basal +!> Compute the Picard basal friction coefficient and Newton drag coefficient at a +!! single quadrature point. Encapsulates the 3-path dispatch (linear Weertman / nonlinear +!! Weertman / Coulomb) so that CG_action, matrix_diagonal, and their subgrid equivalents +!! remain readable. The ground_frac scaling is NOT applied here; callers do it after the call. +subroutine compute_basal_coef(unorm2_qp, coef_prefactor, min_trac_area, fB_e, & + n_basal_fric, CoulombFriction, CF_PostPeak, L_T_to_m_s, use_newton, & + basal_coef, drag_newt) + real, intent(in) :: unorm2_qp !< Regularized |u^k|^2 > 0 at quadrature point [L2 T-2 ~> m2 s-2] + real, intent(in) :: coef_prefactor !< Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1] + real, intent(in) :: min_trac_area !< Pre-computed min_basal_traction * areaT floor [R L2 Z T-1 ~> kg s-1] + real, intent(in) :: fB_e !< Element-level Coulomb fB; 0 for Weertman [(T L-1)^CF_PostPeak] + real, intent(in) :: n_basal_fric !< Friction sliding exponent m [nondim] + logical, intent(in) :: CoulombFriction !< True if using Coulomb friction + real, intent(in) :: CF_PostPeak !< Coulomb post-peak exponent q [nondim] + real, intent(in) :: L_T_to_m_s !< Unit conversion factor from internal [L T-1] to [m s-1] + logical, intent(in) :: use_newton !< If true, evaluate drag_newt; otherwise set to 0 + real, intent(out) :: basal_coef !< Picard friction coefficient at quadrature point [R L2 Z T-1 ~> kg s-1] + real, intent(out) :: drag_newt !< Newton drag coefficient [R Z T ~> kg m-2 s]; 0 without Newton + + real :: unorm ! |u^k| at quadrature point in physical units [m s-1] + real :: raw_coef ! Pre-floor friction coefficient [R L2 Z T-1 ~> kg s-1] + real :: fBuq ! fB_e * |u^k|^q [nondim] + + if (n_basal_fric == 1.0 .and. .not. CoulombFriction) then + ! Linear Weertman: coef is independent of |u|; sqrt and Newton correction not needed + basal_coef = max(coef_prefactor, min_trac_area) + drag_newt = 0.0 + elseif (CoulombFriction) then + ! Schoof/Gagliardini Coulomb friction + unorm = L_T_to_m_s * sqrt(unorm2_qp) + fBuq = fB_e * unorm**CF_PostPeak + raw_coef = coef_prefactor * (unorm**(n_basal_fric-1.0)) / (1.0 + fBuq)**n_basal_fric + if (raw_coef < min_trac_area) then + basal_coef = min_trac_area ; drag_newt = 0.0 + else + basal_coef = raw_coef + if (use_newton) then + drag_newt = (1.0/unorm2_qp) * raw_coef * & + ((n_basal_fric-1.0) - n_basal_fric * CF_PostPeak * fBuq / (1.0 + fBuq)) + else + drag_newt = 0.0 + endif + endif + else + ! Nonlinear Weertman (m > 1) + unorm = L_T_to_m_s * sqrt(unorm2_qp) + raw_coef = coef_prefactor * (unorm**(n_basal_fric-1.0)) + if (raw_coef < min_trac_area) then + basal_coef = min_trac_area ; drag_newt = 0.0 + else + basal_coef = raw_coef + if (use_newton) then + drag_newt = (n_basal_fric-1.0) / unorm2_qp * raw_coef + else + drag_newt = 0.0 + endif + endif + endif + +end subroutine compute_basal_coef !! Returns the sum of the elements in a square matrix. This sum is bitwise identical even if the matrices are rotated. subroutine sum_square_matrix(sum_out, mat_in, n) integer, intent(in) :: n !< The length and width of each matrix in mat_in real, dimension(n,n), intent(in) :: mat_in !< The n x n matrix whose elements will be summed real, intent(out) :: sum_out !< The sum of the elements of matrix mat_in - integer :: s0,e0,s1,e1 + 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 returns the diagonal entries of the matrix for a Jacobi preconditioning -subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, hmask, dens_ratio, & - Phi, Phisub, u_diagonal, v_diagonal) +subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, u_curr, v_curr, & + hmask, dens_ratio, Phi, Phisub, u_diagonal, v_diagonal) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. @@ -2911,9 +3966,12 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear - !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: u_curr !< Frozen current iterate u^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: v_curr !< Frozen current iterate v^k, used to evaluate basal friction + !! at quadrature points [L T-1 ~> m s-1] real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -2935,11 +3993,23 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ! returns the diagonal entries of the matrix for a Jacobi preconditioning real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] - real :: uq, vq + real :: jac_wt ! Per-quadrature-point metric correction |J_q|/areaT [nondim] + real :: strx_n, stry_n, strsh_n ! Newton viscosity strain rates [T-1 ~> s-1] + real :: dstrain_diag_u, dstrain_diag_v ! Newton viscosity diagonal correction factors [T-1 L-1 ~> s-1 m-1] + real :: phi_m_sq ! Squared basis function value at quadrature point [nondim] + real :: u_curr_qp, v_curr_qp ! Current iterate u^k at quadrature point [L T-1 ~> m s-1] + real :: unorm2_qp ! Regularized squared speed of u^k at quadrature point [L2 T-2 ~> m2 s-2] + real :: basal_coef_qp ! Picard basal friction coefficient at quadrature point [R L2 Z T-1 ~> kg s-1] + real :: drag_newt_qp ! Newton basal drag coefficient at quadrature point [R Z T-1 ~> kg m-2 s-1] + real :: coef_prefactor_e ! Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1] + real :: eps_vel2_e ! Velocity regularization squared for current element [L2 T-2 ~> m2 s-2] + real :: min_trac_e ! min_basal_traction * areaT for current element [R L2 Z T-1 ~> kg s-1] + real :: fB_e ! Pre-computed Coulomb fB for element; 0 for Weertman [(T L-1)^CF_PostPeak] real, dimension(2) :: xquad - real, dimension(2,2) :: Hcell, sub_ground + real, dimension(2,2) :: Hcell, u_diag_sub, v_diag_sub ! Subgrid diagonal contributions [R L2 Z T-1 ~> kg s-1] 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 +4024,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 +4034,53 @@ 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 + + ! Pre-computed element-level basal friction quantities (updated each outer iteration). + coef_prefactor_e = CS%coef_prefactor(i,j) + eps_vel2_e = CS%eps_glen_min**2 * ((G%dxT(i,j)**2) + (G%dyT(i,j)**2)) + min_trac_e = CS%min_basal_traction * G%areaT(i,j) + fB_e = CS%fB_elem(i,j) ! 0 for Weertman; non-zero for Coulomb 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 + ! Ratio |J_q|/areaT corrects the uniform-area weight baked into ice_visc for + ! non-rectangular elements where opposite cell edges have unequal lengths. + jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) + + ! 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 + + ! Basal friction coefficients at this quadrature point (fully grounded cells only) + if (float_cond(i,j) == 0 .and. CS%ground_frac(i,j)>0) then + u_curr_qp = ((u_curr(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (u_curr(I,J) * (xquad(iq) * xquad(jq)))) + & + ((u_curr(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (u_curr(I-1,J) * (xquad(3-iq) * xquad(jq)))) + v_curr_qp = ((v_curr(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (v_curr(I,J) * (xquad(iq) * xquad(jq)))) + & + ((v_curr(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (v_curr(I-1,J) * (xquad(3-iq) * xquad(jq)))) + unorm2_qp = ((u_curr_qp**2) + (v_curr_qp**2)) + eps_vel2_e + call compute_basal_coef(unorm2_qp, coef_prefactor_e, min_trac_e, fB_e, & + CS%n_basal_fric, CS%CoulombFriction, CS%CF_PostPeak, US%L_T_to_m_s, .true., & + basal_coef_qp, drag_newt_qp) + basal_coef_qp = basal_coef_qp * CS%ground_frac(i,j) + drag_newt_qp = drag_newt_qp * CS%ground_frac(i,j) + 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 @@ -2981,14 +4089,24 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, vx = 0. vy = 0. - u_diag_qp(iphi,jphi,qp) = & + u_diag_qp(iphi,jphi,qp) = jac_wt * & ice_visc(i,j,qpv) * (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & ((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) - if (float_cond(i,j) == 0) then - uq = xquad(ilq) * xquad(jlq) + ! 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) + & - (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)) + jac_wt * CS%newton_visc_factor(i,j,qpv) * dstrain_diag_u**2 + endif + + if (float_cond(i,j) == 0 .and. CS%ground_frac(i,j)>0) then + ! Picard diagonal: basal_coef_qp * phi_m^2; Newton diagonal adds drag_newt_qp * u^k_qp^2 * phi_m^2. + u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + jac_wt * basal_coef_qp * phi_m_sq + if (CS%doing_newton) & + u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + jac_wt * drag_newt_qp * u_curr_qp**2 * phi_m_sq endif endif @@ -2999,14 +4117,22 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ux = 0. uy = 0. - v_diag_qp(iphi,jphi,qp) = & + v_diag_qp(iphi,jphi,qp) = jac_wt * & ice_visc(i,j,qpv) * (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & ((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) - if (float_cond(i,j) == 0) then - vq = xquad(ilq) * xquad(jlq) + ! 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) + & - (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)) + jac_wt * CS%newton_visc_factor(i,j,qpv) * dstrain_diag_v**2 + endif + + if (float_cond(i,j) == 0 .and. CS%ground_frac(i,j)>0) then + v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + jac_wt * basal_coef_qp * phi_m_sq + if (CS%doing_newton) & + v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + jac_wt * drag_newt_qp * v_curr_qp**2 * phi_m_sq endif endif enddo ; enddo @@ -3029,18 +4155,23 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, v_diag_b(I ,J ,1) = 0.25*((v_diag_qp(2,2,1)+v_diag_qp(2,2,4))+(v_diag_qp(2,2,2)+v_diag_qp(2,2,3))) if (float_cond(i,j) == 1) then - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal(Phisub, Hcell, CS%bed_elev(i,j), dens_ratio, sub_ground) - - if (CS%umask(I-1,J-1) == 1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + (sub_ground(1,1) * basal_trac(i,j)) - if (CS%umask(I-1,J ) == 1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j)) - if (CS%umask(I ,J-1) == 1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j)) - if (CS%umask(I ,J ) == 1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j)) - - if (CS%vmask(I-1,J-1) == 1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + (sub_ground(1,1) * basal_trac(i,j)) - if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j)) - if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j)) - if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j)) + ! Subgrid grounding-line: evaluate basal friction diagonal at each grounded sub-quadrature point. + ! Returns separate u_diag_sub and v_diag_sub (differ in Newton term: u^2 vs v^2). + ! The sub-qp flotation test handles grounding fraction; no external ground_frac scaling needed. + Hcell(:,:) = H_node(I-1:I,J-1:J) + call CG_diagonal_subgrid_basal(CS, G, US, Phisub, Hcell, & + u_curr(I-1:I,J-1:J), v_curr(I-1:I,J-1:J), & + CS%bed_elev(i,j), dens_ratio, i, j, fB_e, u_diag_sub, v_diag_sub, & + G%dxCv(i,j-1), G%dxCv(i,j), G%dyCu(i-1,j), G%dyCu(i,j), G%IareaT(i,j)) + + if (CS%umask(I-1,J-1)==1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + u_diag_sub(1,1) + if (CS%umask(I-1,J )==1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + u_diag_sub(1,2) + if (CS%umask(I ,J-1)==1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + u_diag_sub(2,1) + if (CS%umask(I ,J )==1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + u_diag_sub(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) + v_diag_sub(1,1) + if (CS%vmask(I-1,J )==1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + v_diag_sub(1,2) + if (CS%vmask(I ,J-1)==1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + v_diag_sub(2,1) + if (CS%vmask(I ,J )==1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + v_diag_sub(2,2) endif endif ; enddo ; enddo @@ -3051,48 +4182,113 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, end subroutine matrix_diagonal -subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd) - real, dimension(:,:,:,:,:,:), & - intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations [nondim] - real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) - !! points [Z ~> m]. - real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. - real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater [nondim] - real, dimension(2,2), intent(out) :: f_grnd !< The weighted fraction of the sub-cell where the ice shelf - !! is grounded [nondim] - - real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: f_grnd_sub ! The contributions to nodal f_grnd - !! from each sub-cell - integer, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: grnd_stat !0 at floating quad points, 1 at grounded - real, dimension(2,2) :: f_grnd_q !Contributions to a node from each quadrature point in a sub-grid cell - real :: subarea ! The fractional sub-cell area [nondim] - real :: hloc ! The local sub-region thickness [Z ~> m] +!> Compute subgrid grounding-line basal traction contributions for the preconditioner diagonal. +!! Evaluates friction at each grounded sub-quadrature point. Returns separate u and v diagonals +!! because the Newton term uses u^2 for the u-block and v^2 for the v-block. +!! The sub-qp flotation test handles partial grounding; no external ground_frac scaling needed. +subroutine CG_diagonal_subgrid_basal(CS, G, US, Phisub, H_node, U_curr, V_curr, & + bathyT, dens_ratio, i_elem, j_elem, fB_e, u_diag, v_diag, & + dxCv_S, dxCv_N, dyCu_W, dyCu_E, IareaT) + type(ice_shelf_dyn_CS), intent(in) :: CS !< Ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure + type(unit_scale_type), intent(in) :: US !< Unit conversion factors + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Sub-grid quadrature weights [nondim] + real, dimension(2,2), intent(in) :: H_node !< Ice thickness at element corners [Z ~> m] + real, dimension(2,2), intent(in) :: U_curr !< Frozen u^k at element corners [L T-1 ~> m s-1] + real, dimension(2,2), intent(in) :: V_curr !< Frozen v^k at element corners [L T-1 ~> m s-1] + real, intent(in) :: bathyT !< Ocean bathymetry depth at tracer point [Z ~> m] + real, intent(in) :: dens_ratio !< Ice density / water density [nondim] + integer, intent(in) :: i_elem !< Tracer-grid i-index of the element + integer, intent(in) :: j_elem !< Tracer-grid j-index of the element + real, intent(in) :: fB_e !< Element Coulomb parameter fB; 0 for Weertman [(T L-1)^CF_PostPeak] + real, dimension(2,2), intent(out) :: u_diag !< Nodal u-diagonal entries [R L2 Z T-1 ~> kg s-1] + real, dimension(2,2), intent(out) :: v_diag !< Nodal v-diagonal entries [R L2 Z T-1 ~> kg s-1] + real, intent(in) :: dxCv_S !< The cell width at the southern (v-point) edge [L ~> m] + real, intent(in) :: dxCv_N !< The cell width at the northern (v-point) edge [L ~> m] + real, intent(in) :: dyCu_W !< The cell height at the western (u-point) edge [L ~> m] + real, intent(in) :: dyCu_E !< The cell height at the eastern (u-point) edge [L ~> m] + real, intent(in) :: IareaT !< The inverse of the cell area at the tracer point [L-2 ~> m-2] + + real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: u_diag_sub, v_diag_sub + real, dimension(2,2,2,2) :: u_diag_qp_nd, v_diag_qp_nd ! Per-qp nodal diagonal entries (qx,qy,m,n), + ! pair-summed for rotation invariance + real :: hloc ! Local sub-cell ice thickness [Z ~> m] + real :: u_curr_loc ! Frozen u^k interpolated to sub-qp [L T-1 ~> m s-1] + real :: v_curr_loc ! Frozen v^k interpolated to sub-qp [L T-1 ~> m s-1] + real :: unorm2_loc ! Regularized |u^k|^2 at sub-qp [L2 T-2 ~> m2 s-2] + real :: basal_coef_loc ! Picard friction coefficient at sub-qp [R L2 Z T-1 ~> kg s-1] + real :: drag_newt_loc ! Newton drag coefficient at sub-qp [R Z T ~> kg m-2 s] + real :: phi_mn_sq ! Squared basis function value at sub-qp [nondim] + real :: contrib ! Quadrature weight contribution [nondim] + real :: coef_prefactor ! Pre-computed area * C_basal_friction * L_T_to_m_s [R L2 Z T-1 ~> kg s-1] + real :: min_trac_area ! Minimum area-integrated traction floor [R L2 Z T-1 ~> kg s-1] + real :: eps_vel2 ! Velocity regularization squared [L2 T-2 ~> m2 s-2] + real :: jac_sub_wt ! Per-sub-cell-QP metric correction |J_sub|/areaT [nondim] + real :: a, d ! Interpolated cell-edge spacings at the sub-cell QP [L ~> m] + real :: subarea ! Fractional sub-cell area [nondim] integer :: nsub, i, j, qx, qy, m, n - nsub = size(Phisub,3) - subarea = 1.0 / (nsub**2) + nsub = size(Phisub, 3) + subarea = 1.0 / real(nsub)**2 + + coef_prefactor = CS%coef_prefactor(i_elem,j_elem) + min_trac_area = CS%min_basal_traction * G%areaT(i_elem,j_elem) + eps_vel2 = CS%eps_glen_min**2 * ((G%dxT(i_elem,j_elem)**2) + (G%dyT(i_elem,j_elem)**2)) - grnd_stat(:,:,:,:)=0 + u_diag_sub(:,:,:,:) = 0.0 ; v_diag_sub(:,:,:,:) = 0.0 - do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 - hloc = ((Phisub(qx,qy,i,j,1,1)*H_node(1,1)) + (Phisub(qx,qy,i,j,2,2)*H_node(2,2))) + & - ((Phisub(qx,qy,i,j,1,2)*H_node(1,2)) + (Phisub(qx,qy,i,j,2,1)*H_node(2,1))) - if (dens_ratio * hloc - bathyT > 0) grnd_stat(qx,qy,i,j) = 1 - enddo; enddo ; enddo ; enddo + do j=1,nsub ; do i=1,nsub + ! Zero the 4-qp per-node buffer so ungrounded qp contribute exactly 0. + u_diag_qp_nd(:,:,:,:) = 0.0 ; v_diag_qp_nd(:,:,:,:) = 0.0 + 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) then ! grounded sub-qp + u_curr_loc = (((Phisub(qx,qy,i,j,1,1)*U_curr(1,1)) + (Phisub(qx,qy,i,j,2,2)*U_curr(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*U_curr(1,2)) + (Phisub(qx,qy,i,j,2,1)*U_curr(2,1)))) + v_curr_loc = (((Phisub(qx,qy,i,j,1,1)*V_curr(1,1)) + (Phisub(qx,qy,i,j,2,2)*V_curr(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*V_curr(1,2)) + (Phisub(qx,qy,i,j,2,1)*V_curr(2,1)))) + + unorm2_loc = ((u_curr_loc**2) + (v_curr_loc**2)) + eps_vel2 + call compute_basal_coef(unorm2_loc, coef_prefactor, min_trac_area, fB_e, & + CS%n_basal_fric, CS%CoulombFriction, CS%CF_PostPeak, US%L_T_to_m_s, .true., & + basal_coef_loc, drag_newt_loc) + ! Interpolate cell-edge metrics to the sub-cell QP using the bilinear shape function values + ! from bilinear_shape_functions_subgrid. Marginal sums of Phisub give the interpolation + ! weights: sum over k=1 nodes gives (1-y); k=2 gives y; l=1 gives (1-x); l=2 gives x. + ! This is analogous to jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) in the regular routines. + a = (dxCv_S * (Phisub(qx,qy,i,j,1,1) + Phisub(qx,qy,i,j,2,1))) + & ! (1-y) * dxCv_S + (dxCv_N * (Phisub(qx,qy,i,j,1,2) + Phisub(qx,qy,i,j,2,2))) ! + y * dxCv_N + d = (dyCu_W * (Phisub(qx,qy,i,j,1,1) + Phisub(qx,qy,i,j,1,2))) + & ! (1-x) * dyCu_W + (dyCu_E * (Phisub(qx,qy,i,j,2,1) + Phisub(qx,qy,i,j,2,2))) ! + x * dyCu_E + jac_sub_wt = 0.25 * subarea * (a * d) * IareaT + + do n=1,2 ; do m=1,2 + phi_mn_sq = Phisub(qx,qy,i,j,m,n)**2 + contrib = jac_sub_wt * phi_mn_sq + ! Picard diagonal + Newton diagonal (u_curr^2 for u-block, v_curr^2 for v-block) + if (CS%doing_newton) then + u_diag_qp_nd(qx,qy,m,n) = contrib * (basal_coef_loc + drag_newt_loc * u_curr_loc**2) + v_diag_qp_nd(qx,qy,m,n) = contrib * (basal_coef_loc + drag_newt_loc * v_curr_loc**2) + else + u_diag_qp_nd(qx,qy,m,n) = contrib * basal_coef_loc + v_diag_qp_nd(qx,qy,m,n) = contrib * basal_coef_loc + endif + enddo ; enddo + endif + 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 - f_grnd_q(qx,qy) = grnd_stat(qx,qy,i,j) * Phisub(qx,qy,i,j,m,n)**2 + do n=1,2 ; do m=1,2 + u_diag_sub(i,j,m,n) = (u_diag_qp_nd(1,1,m,n) + u_diag_qp_nd(2,2,m,n)) + & + (u_diag_qp_nd(1,2,m,n) + u_diag_qp_nd(2,1,m,n)) + v_diag_sub(i,j,m,n) = (v_diag_qp_nd(1,1,m,n) + v_diag_qp_nd(2,2,m,n)) + & + (v_diag_qp_nd(1,2,m,n) + v_diag_qp_nd(2,1,m,n)) enddo ; enddo - !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell - f_grnd_sub(i,j,m,n) = (subarea * 0.25) * ((f_grnd_q(1,1) + f_grnd_q(2,2)) + (f_grnd_q(1,2)+f_grnd_q(2,1))) - enddo ; enddo ; enddo ; enddo + enddo ; enddo - !sum up the sub-cell contributions to each node do n=1,2 ; do m=1,2 - call sum_square_matrix(f_grnd(m,n),f_grnd_sub(:,:,m,n),nsub) + call sum_square_matrix(u_diag(m,n), u_diag_sub(:,:,m,n), nsub) + call sum_square_matrix(v_diag(m,n), v_diag_sub(:,:,m,n), nsub) enddo ; enddo end subroutine CG_diagonal_subgrid_basal @@ -3122,14 +4318,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 +4333,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 +4407,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 +4420,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 @@ -3254,6 +4450,8 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) real :: Visc_coef, n_g real :: ux, uy, vx, vy real :: eps_min ! Velocity shears [T-1 ~> s-1] + real :: In_g ! inverse of Glen's exponent [nondim] + real :: eps_e2_exp ! (1.-n_g)/(2.*n_g) [nondim] logical :: model_qp1, model_qp4 isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -3262,7 +4460,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 +4472,9 @@ 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 + In_g=1./n_g + eps_e2_exp=(1.-n_g)/(2.*n_g) do j=jsc,jec ; do i=isc,iec @@ -3289,11 +4489,11 @@ 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) + Visc_coef = (CS%AGlen_visc(i,j))**(-In_g) ! Units of Aglen_visc [Pa-(n_g) s-1] ux = ((u_shlf(I-1,J-1) * CS%PhiC(1,i,j)) + & @@ -3318,12 +4518,23 @@ 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(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%s_to_T**2 * (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**(eps_e2_exp) * & (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) * 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) = ((In_g - 1.) / & + (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2)) * & + CS%ice_visc(i,j,1) + endif elseif (model_qp4) then !calculate viscosity at 4 quadrature points per cell - - Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) + Visc_coef = (CS%AGlen_visc(i,j))**(-In_g) do iq=1,2 ; do jq=1,2 @@ -3349,87 +4560,114 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) CS%ice_visc(i,j,2*(jq-1)+iq) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & max(0.5 * Visc_coef * & - (US%s_to_T**2*(((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & + (US%s_to_T**2*(((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**(eps_e2_exp) * & (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) = ((In_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 end subroutine calc_shelf_visc +!> Pre-compute element-level basal friction prefactors for quadrature-point evaluation. +subroutine calc_shelf_basal_prefactors(CS, ISS, G, US) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< Ice shelf dynamics control structure + type(ice_shelf_state), intent(in) :: ISS !< Ice shelf state (hmask, h_shelf) + type(ocean_grid_type), intent(in) :: G !< The grid structure + type(unit_scale_type), intent(in) :: US !< Unit conversion factors -!> Update basal shear -subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe - !! the ice-shelf state - type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + integer :: i, j, isd, ied, jsd, jed + real :: Hf ! Floatation thickness [Z ~> m] + real :: fN ! Effective pressure for Coulomb friction [R Z L T-2 ~> Pa] -! also this subroutine updates the nonlinear part of the basal traction + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed -! this may be subject to change later... to make it "hybrid" + do j = jsd, jed ; do i = isd, ied + CS%coef_prefactor(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * US%L_T_to_m_s + if (CS%CoulombFriction .and. (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3)) then + Hf = max(CS%rhow_rhoi * 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) + CS%fB_elem(i,j) = CS%alpha_coulomb * & + (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%coulomb_pp_n) + else + CS%fB_elem(i,j) = 0.0 + endif + enddo ; enddo - integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq - integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js - real :: umid, vmid ! Velocities [L T-1 ~> m s-1] - real :: eps_min ! A minimal strain rate used in the Glens flow law expression [T-1 ~> s-1] - real :: unorm ! The magnitude of the velocity in mks units for use with fractional powers [m s-1] - real :: alpha ! Coulomb coefficient [nondim] - real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m] - real :: fN ! Effective pressure (ice pressure - ocean pressure) for Coulomb friction [R Z L T-2 ~> Pa] - real :: fB !for Coulomb Friction [(T L-1)^CS%CF_PostPeak ~> (s m-1)^CS%CF_PostPeak] +end subroutine calc_shelf_basal_prefactors - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - 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 +!> Compute area-averaged basal shear stress [R L T-1 ~> Pa s m-1] and return it in basal_tr. +!! Uses CS%u_shelf and CS%v_shelf for velocities and G%US for unit conversions. +subroutine calc_shelf_taub(CS, ISS, G, basal_tr) + type(ice_shelf_dyn_CS), intent(in) :: CS !< Ice shelf dynamics control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: basal_tr !< Area-averaged basal traction [R L T-1 ~> Pa s m-1] + + integer :: i, j + real :: umid, vmid ! Cell-center velocity averages [L T-1 ~> m s-1] + real :: eps_min ! Minimal strain rate [T-1 ~> s-1] + real :: unorm ! Velocity magnitude in mks units [m s-1] + real :: alpha ! Coulomb coefficient [nondim] + real :: Hf ! Floatation thickness for Coulomb friction [Z ~> m] + real :: fN ! Effective pressure for Coulomb friction [R Z L T-2 ~> Pa] + real :: fB ! Coulomb friction factor [(T L-1)^CS%CF_PostPeak] + real :: fBuq ! fB * unorm^CF_PostPeak [nondim] + real :: unorm_code2 ! Squared velocity magnitude in code units [L2 T-2 ~> m2 s-2] + real :: basal_trac ! Area-integrated traction coefficient [R Z L2 T-1 ~> kg s-1] eps_min = CS%eps_glen_min if (CS%CoulombFriction) then - if (CS%CF_PostPeak/=1.0) THEN - alpha = (CS%CF_PostPeak-1.0)**(CS%CF_PostPeak-1.0) / CS%CF_PostPeak**CS%CF_PostPeak ![nondim] + if (CS%CF_PostPeak /= 1.0) then + alpha = CS%alpha_coulomb else alpha = 1.0 endif endif - do j=jsd+1,jed - do i=isd+1,ied - 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)) ) - - !Coulomb friction (Schoof 2005, Gagliardini et al 2007) - if (CS%CoulombFriction) then - !Effective pressure - Hf = max((CS%density_ocean_avg/CS%density_ice) * CS%bed_elev(i,j), 0.0) - fN = max((US%L_to_Z*(CS%density_ice * CS%g_Earth) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) - Hf)), CS%CF_MinN) - fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) - - CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * & - (unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric))) * & - US%L_T_to_m_s ! Restore the scaling after the fractional power law. - else - !linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric /= 1) - CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * & - US%L_T_to_m_s ! Rescale after the fractional power law. - endif + basal_tr(:,:) = 0.0 - CS%basal_traction(i,j)=max(CS%basal_traction(i,j), CS%min_basal_traction * G%areaT(i,j)) + 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 + umid = ((CS%u_shelf(I,J) + CS%u_shelf(I-1,J-1)) + (CS%u_shelf(I,J-1) + CS%u_shelf(I-1,J))) * 0.25 + vmid = ((CS%v_shelf(I,J) + CS%v_shelf(I-1,J-1)) + (CS%v_shelf(I,J-1) + CS%v_shelf(I-1,J))) * 0.25 + unorm_code2 = ((umid**2) + (vmid**2)) + (eps_min**2 * ((G%dxT(i,j)**2) + (G%dyT(i,j)**2))) + unorm = G%US%L_T_to_m_s * sqrt(unorm_code2) + + !Coulomb friction (Schoof 2005, Gagliardini et al 2007) + if (CS%CoulombFriction) then + !Effective pressure + Hf = max(CS%rhow_rhoi * CS%bed_elev(i,j), 0.0) + fN = max((G%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%coulomb_pp_n) + fBuq = fB * unorm**CS%CF_PostPeak + basal_trac = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * & + (unorm**(CS%n_basal_fric-1.0) / (1.0 + fBuq)**(CS%n_basal_fric))) * & + G%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) + basal_trac = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * & + G%US%L_T_to_m_s ! Rescale after the fractional power law. endif - enddo - enddo + + basal_trac = max(basal_trac, CS%min_basal_traction * G%areaT(i,j)) + basal_tr(i,j) = basal_trac * G%IareaT(i,j) * CS%ground_frac(i,j) + endif + enddo ; enddo end subroutine calc_shelf_taub @@ -3464,7 +4702,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.) @@ -3480,14 +4718,13 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) intent(in) :: h_shelf !< the thickness of the ice shelf [Z ~> m]. integer :: i, j, isd, ied, jsd, jed - real :: rhoi_rhow, OD + real :: OD - rhoi_rhow = CS%density_ice / CS%density_ocean_avg isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed do j=jsd,jed do i=isd,ied - OD = CS%bed_elev(i,j) - rhoi_rhow * max(h_shelf(i,j),CS%min_h_shelf) + OD = CS%bed_elev(i,j) - CS%rhoi_rhow * max(h_shelf(i,j),CS%min_h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD @@ -3512,32 +4749,31 @@ subroutine change_in_draft(CS, G, h_shelf0, h_shelf1, ddraft) intent(inout) :: ddraft !< the change in shelf draft thickness real :: b0,b1 integer :: i, j, isc, iec, jsc, jec - real :: rhoi_rhow, OD + real :: OD - rhoi_rhow = CS%density_ice / CS%density_ocean_avg isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ddraft = 0.0 do j=jsc,jec do i=isc,iec - b0=0.0; b1=0.0 + 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) + OD = CS%bed_elev(i,j) - CS%rhoi_rhow * h_shelf0(i,j) if (OD >= 0) then !floating - b0 = rhoi_rhow * h_shelf0(i,j) + b0 = CS%rhoi_rhow * h_shelf0(i,j) else b0 = CS%bed_elev(i,j) endif endif if (h_shelf1(i,j)>0.0) then - OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf1(i,j) + OD = CS%bed_elev(i,j) - CS%rhoi_rhow * h_shelf1(i,j) if (OD >= 0) then !floating - b1 = rhoi_rhow * h_shelf1(i,j) + b1 = CS%rhoi_rhow * h_shelf1(i,j) else b1 = CS%bed_elev(i,j) endif @@ -3619,12 +4855,14 @@ end subroutine bilinear_shape_functions !> This subroutine calculates the gradients of bilinear basis elements that are centered at the !! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at !! points of gaussian quadrature. -subroutine bilinear_shape_fn_grid(G, i, j, Phi) +subroutine bilinear_shape_fn_grid(G, i, j, Phi, Jac) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. integer, intent(in) :: i !< The i-index in the grid to work on. integer, intent(in) :: j !< The j-index in the grid to work on. real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, dimension(4), optional, intent(out) :: Jac !< Jacobian determinant |J_q| = a_q*d_q at each + !! Gaussian quadrature point [L2 ~> m2]. ! This subroutine calculates the gradients of bilinear basis elements that ! that are centered at the vertices of the cell. The values are calculated at @@ -3638,6 +4876,10 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) ! This should be a one-off; once per nonlinear solve? once per lifetime? real, dimension(4) :: xquad, yquad ! [nondim] + ! Mirror lookups: xquad_m(qp) == 1 - xquad(qp), yquad_m(qp) == 1 - yquad(qp) mathematically, + ! but each mirror entry is the stored value at the x- or y-mirrored quadrature point. This + ! ensures rotation-paired QPs read bit-identical operand values. + real, dimension(4) :: xquad_m, yquad_m ! Mirrors of xquad, yquad [nondim] real :: a, d ! Interpolated grid spacings [L ~> m] real :: xexp, yexp ! [nondim] integer :: node, qpoint, xnode, ynode @@ -3645,31 +4887,33 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) + ! x-mirror swaps qp 1<->2 and 3<->4; y-mirror swaps 1<->3 and 2<->4 + xquad_m(1) = xquad(2) ; xquad_m(2) = xquad(1) ; xquad_m(3) = xquad(4) ; xquad_m(4) = xquad(3) + yquad_m(1) = yquad(3) ; yquad_m(2) = yquad(4) ; yquad_m(3) = yquad(1) ; yquad_m(4) = yquad(2) + do qpoint=1,4 if (J>1) then - a = (G%dxCv(i,J-1) * (1-yquad(qpoint))) + (G%dxCv(i,J) * yquad(qpoint)) ! d(x)/d(x*) + a = (G%dxCv(i,J-1) * yquad_m(qpoint)) + (G%dxCv(i,J) * yquad(qpoint)) ! d(x)/d(x*) else a = G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) endif if (I>1) then - d = (G%dyCu(I-1,j) * (1-xquad(qpoint))) + (G%dyCu(I,j) * xquad(qpoint)) ! d(y)/d(y*) + d = (G%dyCu(I-1,j) * xquad_m(qpoint)) + (G%dyCu(I,j) * xquad(qpoint)) ! d(y)/d(y*) else d = G%dyCu(I,j) !* xquad(qpoint) endif -! a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) -! d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) do node=1,4 xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) if (ynode == 1) then - yexp = 1-yquad(qpoint) + yexp = yquad_m(qpoint) else yexp = yquad(qpoint) endif if (1 == xnode) then - xexp = 1-xquad(qpoint) + xexp = xquad_m(qpoint) else xexp = xquad(qpoint) endif @@ -3678,6 +4922,7 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) Phi(2*node,qpoint) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d) enddo + if (present(Jac)) Jac(qpoint) = a * d enddo end subroutine bilinear_shape_fn_grid @@ -3757,21 +5002,27 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) ! 1 - 2 integer :: i, j, qx, qy - real,dimension(2) :: xquad - real :: x0, y0, x, y, fracx + real,dimension(2) :: xquad ! [nondim] + real :: fracx ! The fractional sub-cell area in reference space [nondim] + ! Mirror-symmetric per-direction node weights: a_left == 1-x_global, a_right == x_global + ! mathematically, but constructed so that a_right(qx,i) is computed by exactly the same + ! operand sequence as a_left(3-qx, nsub+1-i). This guarantees bit-exact rotation symmetry. + real, dimension(2,nsub) :: a_left, a_right ! [nondim] xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) fracx = 1.0/real(nsub) + do i=1,nsub ; do qx=1,2 + a_left (qx,i) = (real(nsub-i) + xquad(3-qx)) * fracx + a_right(qx,i) = (real(i-1) + xquad(qx)) * fracx + enddo ; enddo + do j=1,nsub ; do i=1,nsub - x0 = (i-1) * fracx ; y0 = (j-1) * fracx do qy=1,2 ; do qx=1,2 - x = x0 + fracx*xquad(qx) - y = y0 + fracx*xquad(qy) - Phisub(qx,qy,i,j,1,1) = (1.0-x) * (1.0-y) - Phisub(qx,qy,i,j,1,2) = (1.0-x) * y - Phisub(qx,qy,i,j,2,1) = x * (1.0-y) - Phisub(qx,qy,i,j,2,2) = x * y + Phisub(qx,qy,i,j,1,1) = a_left (qx,i) * a_left (qy,j) + Phisub(qx,qy,i,j,1,2) = a_left (qx,i) * a_right(qy,j) + Phisub(qx,qy,i,j,2,1) = a_right(qx,i) * a_left (qy,j) + Phisub(qx,qy,i,j,2,2) = a_right(qx,i) * a_right(qy,j) enddo ; enddo enddo ; enddo @@ -3818,12 +5069,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 +5209,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 +5219,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 @@ -3978,25 +5229,43 @@ end subroutine interpolate_H_to_B !> Deallocates all memory associated with the ice shelf dynamics module subroutine ice_shelf_dyn_end(CS) - type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + type(ice_shelf_dyn_CS), pointer :: CS + !< A pointer to the ice shelf dynamics control structure + + logical :: is_open + ! True if CS%fileenergy_ascii is open if (.not.associated(CS)) return deallocate(CS%u_shelf, CS%v_shelf) deallocate(CS%taudx_shelf, CS%taudy_shelf) + deallocate(CS%sx_shelf, CS%sy_shelf) deallocate(CS%t_shelf, CS%tmask) deallocate(CS%u_bdry_val, CS%v_bdry_val) deallocate(CS%u_face_mask, CS%v_face_mask) + deallocate(CS%u_flux_bdry_val, CS%v_flux_bdry_val) deallocate(CS%umask, CS%vmask) deallocate(CS%u_face_mask_bdry, CS%v_face_mask_bdry) deallocate(CS%h_bdry_val) deallocate(CS%float_cond) + if (associated(CS%calve_mask)) deallocate(CS%calve_mask) deallocate(CS%ice_visc, CS%AGlen_visc) - deallocate(CS%basal_traction,CS%C_basal_friction) + deallocate(CS%newton_visc_factor, CS%newton_str_ux, CS%newton_str_vy, CS%newton_str_sh) + deallocate(CS%C_basal_friction) + deallocate(CS%coef_prefactor, CS%fB_elem) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%t_bdry_val, CS%bed_elev) deallocate(CS%ground_frac, CS%ground_frac_rt) + if (associated(CS%Jac)) deallocate(CS%Jac) + if (associated(CS%Phi)) deallocate(CS%Phi) + if (associated(CS%Phisub)) deallocate(CS%Phisub) + if (associated(CS%PhiC)) deallocate(CS%PhiC) + + is_open = .false. + if (CS%IS_fileenergy_ascii /= -1) & + inquire(unit=CS%IS_fileenergy_ascii, opened=is_open) + if (is_open) call close_file(CS%IS_fileenergy_ascii) deallocate(CS) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index ee089706b7..57b6bd7d1d 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -24,7 +24,7 @@ module MOM_ice_shelf_initialize public initialize_ice_shelf_boundary_from_file public initialize_ice_C_basal_friction public initialize_ice_AGlen -public initialize_ice_SMB + ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -33,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)), & @@ -42,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 @@ -51,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. "//& @@ -66,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 @@ -88,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]. @@ -96,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 @@ -129,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) @@ -141,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 @@ -222,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) @@ -313,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 @@ -424,7 +440,7 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& default="ice_shelf_vel.nc") filename = trim(inputdir)//trim(vel_file) - call log_param(PF, mdl, "INPUTDIR/THICKNESS_FILE", filename) + call log_param(PF, mdl, "INPUTDIR/ICE_VELOCITY_FILE", filename) call get_param(PF, mdl, "ICE_U_VEL_VARNAME", ushelf_varname, & "The name of the u velocity variable in ICE_VELOCITY_FILE.", & default="u_shelf") @@ -651,58 +667,13 @@ 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 end subroutine initialize_ice_AGlen -!> Initialize ice surface mass balance field that is held constant over time -subroutine initialize_ice_SMB(SMB, G, US, PF) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: SMB !< Ice surface mass balance parameter, often in [R Z T-1 ~> kg m-2 s-1] - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters - - real :: SMB_val ! Constant ice surface mass balance parameter, often in [R Z T-1 ~> kg m-2 s-1] - character(len=40) :: mdl = "initialize_ice_SMB" ! This subroutine's name. - character(len=200) :: config - character(len=200) :: varname - character(len=200) :: inputdir, filename, SMB_file - - call get_param(PF, mdl, "ICE_SMB_CONFIG", config, & - "This specifies how the initial ice surface mass balance parameter is specified. "//& - "Valid values are: CONSTANT and FILE.", & - default="CONSTANT") - - if (trim(config)=="CONSTANT") then - call get_param(PF, mdl, "SMB", SMB_val, & - "Surface mass balance.", units="kg m-2 s-1", default=0.0, scale=US%kg_m2s_to_RZ_T) - - SMB(:,:) = SMB_val - - elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading SMB parameter") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) - - call get_param(PF, mdl, "ICE_SMB_FILE", SMB_file, & - "The file from which the ice surface mass balance is read.", & - default="ice_SMB.nc") - filename = trim(inputdir)//trim(SMB_file) - call log_param(PF, mdl, "INPUTDIR/ICE_SMB_FILE", filename) - call get_param(PF, mdl, "ICE_SMB_VARNAME", varname, & - "The variable to use as surface mass balance.", & - default="SMB") - - if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & - " initialize_ice_SMV_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename,trim(varname), SMB, G%Domain, scale=US%kg_m2s_to_RZ_T) - - endif -end subroutine initialize_ice_SMB end module MOM_ice_shelf_initialize diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index bcab79fe95..10a3336871 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -26,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] @@ -47,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]. @@ -76,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 ) @@ -86,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 @@ -100,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 3f949f8b06..3eec43e335 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -112,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 e3c7e2b49a..57460227c5 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -72,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_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index eb405f2e6e..605671b0ff 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -27,6 +27,7 @@ module MOM_fixed_initialization 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 +use MOM_shared_initialization, only : set_meanSL_from_file use MOM_unit_scaling, only : unit_scale_type use user_initialization, only : user_initialize_topography @@ -61,9 +62,9 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF) !! to parse for model parameter values. ! Local variables - character(len=200) :: inputdir ! The directory where NetCDF input files are. character(len=200) :: config - logical :: read_porous_file, OBC_projection_bug, open_corners, enable_bugs + 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,52 +72,60 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF) # 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 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, do_not_log=.not.associated(OBC)) - open_corners = .not.OBC_projection_bug - - ! This call sets masks that prohibit flow over any point interpreted as land + ! 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) + 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 - ! Make OBC mask consistent with land mask - call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US) - if (debug) then call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, unscale=US%Z_to_m) call hchksum(G%mask2dT, 'MOM_initialize_fixed: mask2dT ', G%HI) @@ -125,6 +134,9 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF) 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"//& @@ -169,12 +181,12 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF) 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 @@ -188,7 +200,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF) 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) call callTree_leave('MOM_initialize_fixed()') @@ -196,21 +208,29 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF) 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"//& @@ -240,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) @@ -264,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 78160866d5..7bc3838b19 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -748,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 @@ -788,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 @@ -855,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. @@ -1137,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 @@ -1171,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 @@ -1186,7 +1186,7 @@ end function Adcroft_reciprocal !! 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 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) +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 @@ -1205,6 +1205,10 @@ subroutine initialize_masks(G, PF, US, OBC_dir_u, OBC_dir_v, open_corner_OBCs) 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]. @@ -1226,40 +1230,40 @@ subroutine initialize_masks(G, PF, US, OBC_dir_u, OBC_dir_v, open_corner_OBCs) "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 open_corners = .false. ; if (present(open_corner_OBCs)) open_corners = open_corner_OBCs - G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0 + 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 - enddo ; enddo + 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 - 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 + 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) then - if (G%bathyT(i,j) > Dmask) G%mask2dCu(I,j) = 1.0 - endif - if (OBC_dir_u(I,j) < 0) then - if (G%bathyT(i+1,j) > Dmask) G%mask2dCu(I,j) = 1.0 - endif + 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 @@ -1269,21 +1273,13 @@ subroutine initialize_masks(G, PF, US, OBC_dir_u, OBC_dir_v, open_corner_OBCs) 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) then - if (G%bathyT(i,j) > Dmask) G%mask2dCv(i,J) = 1.0 - endif - if (OBC_dir_v(i,J) < 0) then - if (G%bathyT(i,j+1) > Dmask) G%mask2dCv(i,J) = 1.0 - endif + 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 @@ -1334,6 +1330,7 @@ subroutine initialize_masks(G, PF, US, OBC_dir_u, OBC_dir_v, open_corner_OBCs) 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 @@ -1341,6 +1338,7 @@ subroutine initialize_masks(G, PF, US, OBC_dir_u, OBC_dir_v, open_corner_OBCs) 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 8cdf8156af..ad520eb594 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -33,6 +33,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 @@ -139,6 +140,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) @@ -837,15 +873,12 @@ subroutine reset_face_lengths_list(G, param_file, US) real :: lon_p, lon_m ! The longitude of a point shifted by 360 degrees [degrees_E]. logical :: check_360 ! If true, check for longitudes that are shifted by ! +/- 360 degrees from the specified range of values. - logical :: found_u, found_v logical :: unit_in_use logical :: fatal_unused_lengths integer :: unused - integer :: ios, iounit, isu, isv + integer :: ios, iounit, isu, isv, isu_por, isv_por integer :: num_lines, nl_read, ln, npt, u_pt, v_pt integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - integer :: isu_por, isv_por - logical :: found_u_por, found_v_por isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -887,6 +920,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 @@ -933,19 +968,17 @@ 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. + isu = index(uppercase(line), "U_WIDTH") + isv = index(uppercase(line), "V_WIDTH") + isu_por = index(uppercase(line), "U_WIDTH_POR") + isv_por = index(uppercase(line), "V_WIDTH_POR") ! Store and check the relevant values. - if (found_u) then + if (isu > 0) then ! This line includes "U_WIDTH". u_pt = u_pt + 1 - if (found_u_por .eqv. .false.) then + if (isu_por <= 0) then ! This line sets "U_WIDTH" read(line(isu+8:),*) u_lon(1:2,u_pt), u_lat(1:2,u_pt), u_width(u_pt) - elseif (found_u_por) then + else ! This line sets "U_WIDTH_POR" read(line(isu_por+12:),*) u_lon(1:2,u_pt), u_lat(1:2,u_pt), u_width(u_pt), & Dmin_u(u_pt), Dmax_u(u_pt), Davg_u(u_pt) endif @@ -982,12 +1015,12 @@ subroutine reset_face_lengths_list(G, param_file, US) "topographical min/max found when reading line "//trim(line)//" from file "//& trim(filename)) endif - elseif (found_v) then + elseif (isv > 0) then ! This line includes "V_WIDTH". v_pt = v_pt + 1 - if (found_v_por .eqv. .false.) then + if (isv_por <= 0) then ! This line sets "V_WIDTH" read(line(isv+8:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt) - elseif (found_v_por) then - read(line(isv+12:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt), & + else ! This line sets "V_WIDTH_POR" + read(line(isv_por+12:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt), & Dmin_v(v_pt), Dmax_v(v_pt), Davg_v(v_pt) endif v_width(v_pt) = US%m_to_L*v_width(v_pt) ! Rescale units equivalently to scale=US%m_to_L during read. @@ -1148,7 +1181,7 @@ subroutine read_face_length_list(iounit, filename, num_lines, lines) ! list file, after removing comments. character(len=120) :: line, line_up logical :: found_u, found_v - integer :: isu, isv, icom + integer :: icom integer :: last num_lines = 0 @@ -1165,9 +1198,8 @@ 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 = (index(line_up(:last), "U_WIDTH") > 0) + found_v = (index(line_up(:last), "V_WIDTH") > 0) if (found_u .and. found_v) call MOM_error(FATAL, & "read_face_length_list : both U_WIDTH and V_WIDTH found when "//& @@ -1254,8 +1286,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 a1a512ac92..62aeb5f2f1 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -26,7 +26,6 @@ module MOM_state_initialization 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_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_restart, only : restore_state, is_new_run, copy_restart_var, copy_restart_vector use MOM_restart, only : restart_registry_lock, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density @@ -152,7 +151,7 @@ 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. @@ -161,17 +160,14 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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_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 :: OBC_TS_reservoir_init_bug ! If true, set the OBC temperature and salinity reservoirs + ! at the startup of a new run from initial values that are set before remapping. 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. @@ -445,11 +441,11 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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 + call get_param(PF, mdl, "OBC_TS_RESERVOIR_INIT_BUG", OBC_TS_reservoir_init_bug, & + "If true, set the OBC temperature and salinity reservoirs at the startup of a "//& + "new run from initial values that are set before remapping.", & + default=enable_bugs, do_not_log=.true.) + if (OBC_TS_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.) @@ -624,7 +620,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, & @@ -673,6 +669,8 @@ subroutine MOM_initialize_OBCs(h, tv, OBC, Time, G, GV, US, PF, restart_CS, trac 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_TS_reservoir_init_bug ! If true, set the OBC temperature and salinity reservoirs + ! at the startup of a new run from initial values that are set before remapping. 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. @@ -686,24 +684,26 @@ subroutine MOM_initialize_OBCs(h, tv, OBC, Time, G, GV, US, PF, restart_CS, trac 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_TS_RESERVOIR_INIT_BUG", OBC_TS_reservoir_init_bug, & + "If true, set the OBC temperature and salinity reservoirs at the startup of a "//& + "new run from initial values that are set before remapping.", default=enable_bugs) + if (associated(tv%T) .and. (.not.OBC_TS_reservoir_init_bug)) then + ! 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 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 + if (OBC_reservoir_init_bug .and. associated(tv%T) .and. 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. + ! When OBC_RESERVOIR_INIT_BUG is false, setup_OBC_tracer_reservoirs() is called from initialize_MOM + ! after all tracer package initialization is finished and grid rotation has been dealt with. + 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 ! This controls user code for setting open boundary data @@ -1221,7 +1221,7 @@ 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. @@ -1443,7 +1443,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 @@ -2045,7 +2045,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. @@ -2262,7 +2261,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 @@ -2648,11 +2647,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) @@ -2807,6 +2804,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) & @@ -2917,8 +2918,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) @@ -3002,7 +3005,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 diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 4c665fd9e1..7ab89310b4 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -19,9 +19,10 @@ module MOM_oda_driver_mod use MOM_ensemble_manager, only : get_ensemble_pelist, get_ensemble_filter_pelist use MOM_error_handler, only : stdout, stdlog, MOM_error use MOM_io, only : SINGLE_FILE -use MOM_interp_infra, only : init_extern_field, get_external_field_info +use MOM_interp_infra, only : init_extern_field use MOM_interp_infra, only : time_interp_extern use MOM_interpolate, only : external_field +use MOM_interpolate, only : get_external_field_info use MOM_remapping, only : remappingSchemesDoc use MOM_time_manager, only : time_type, real_to_time, get_date use MOM_time_manager, only : operator(+), operator(>=), operator(/=) @@ -129,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 @@ -266,7 +267,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) 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."//& + "Logical flag needed to reproduce older NMME forecast answers. "//& "True gives old answers, the default of false gives different answers.", & default=.false.) @@ -347,13 +348,13 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge, answer_date=CS%answer_date) call set_regrid_params(CS%regridCS, min_thickness=0.) - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ! breaking with the MOM6 convention and using global indices !call get_domain_extent(G%Domain,is,ie,js,je,isd,ied,jsd,jed,& ! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric) - !isd=isd+idg_offset; ied=ied+idg_offset ! using global indexing within the DA module - !jsd=jsd+jdg_offset; jed=jed+jdg_offset ! TODO: switch to local indexing? (mjh) + !isd = isd+idg_offset ; ied = ied+idg_offset ! using global indexing within the DA module + !jsd = jsd+jdg_offset ; jed = jed+jdg_offset ! TODO: switch to local indexing? (mjh) if (.not. associated(CS%h)) then allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke), source=CS%GV%Angstrom_H) @@ -421,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 @@ -450,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) @@ -632,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 @@ -640,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)) @@ -659,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 @@ -668,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 @@ -715,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 @@ -725,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) @@ -798,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 d55d030d44..7e1b95763b 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -226,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. & @@ -238,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 @@ -474,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 @@ -568,9 +568,8 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB if (.not.associated(CS)) return - ! no assimilation after CS%step_incupd + ! no assimilation after CS%nstep_incupd if (CS%ncount >= CS%nstep_incupd) then - if (is_root_pe()) call MOM_error(NOTE,"ended updating fields with increments. ") return endif !ncount>CS%nstep_incupd diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 3f96e689c7..ec0b28f49d 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -375,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 @@ -620,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)) * & @@ -630,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)) * & @@ -1367,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.) @@ -1431,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 "//& @@ -1525,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, & @@ -1542,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 "//& diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index 8b4a8856b7..8473c58b35 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -266,11 +266,11 @@ subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) ! Mask is included to automatically satisfy B.C. do j=js-2,je+2 ; do i=is-2,ie+2 CS%kappa_h(i,j) = -CS%amplitude * G%areaT(i,j) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 CS%kappa_q(I,J) = -CS%amplitude * G%areaBu(I,J) * G%mask2dBu(I,J) - enddo; enddo + enddo ; enddo if (CS%Klower_R_diss > 0) then allocate(CS%ICoriolis_h(SZI_(G),SZJ_(G))) @@ -282,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 @@ -390,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 @@ -404,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) @@ -447,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) @@ -501,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] @@ -523,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 @@ -535,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 @@ -576,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 @@ -667,7 +661,7 @@ subroutine compute_stress_ANN_collocated(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, m + integer :: i, j, k, m integer :: ii, jj integer :: nij @@ -679,7 +673,6 @@ subroutine compute_stress_ANN_collocated(G, GV, CS) ! (Txy,Txx,Tyy) [nondim] real :: yy(3) ! Vector of dimensional ! output features (Txy,Txx,Tyy) [L2 T-2 ~> m2 s-2] - real :: input_norm ! Norm of input features [T-1 ~> s-1] 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 @@ -725,15 +718,15 @@ subroutine compute_stress_ANN_collocated(G, GV, CS) + (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 + 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 + do jj=j-offset,j+offset ; do ii=i-offset,i+offset tmp = tmp + sqr_h(ii,jj) - enddo; enddo + enddo ; enddo norm_h(i,j,k) = sqrt(tmp) - enddo; enddo + enddo ; enddo enddo call pass_var(sh_xy_h, G%Domain, clock=CS%id_clock_mpi) @@ -755,7 +748,7 @@ subroutine compute_stress_ANN_collocated(G, GV, CS) j-offset:j+offset,k), (/stencil_points/)) x(m,:) = x(m,:) / (norm_h(i,j,k) + CS%subroundoff_shear) - enddo; enddo + enddo ; enddo call ANN_apply_array_sio(nij, x, y, CS%ann_Tall) @@ -772,7 +765,7 @@ subroutine compute_stress_ANN_collocated(G, GV, CS) 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 ; enddo enddo ! end of k loop @@ -943,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 @@ -960,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 @@ -992,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) @@ -1007,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) @@ -1040,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 @@ -1061,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) @@ -1165,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 diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 1410f37ff8..f3277b6337 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -23,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 @@ -103,8 +105,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. @@ -450,6 +454,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, logical :: rescale_Kh logical :: find_FrictWork logical :: apply_OBC = .false. + logical :: apply_OBC_strain logical :: use_MEKE_Ku logical :: use_MEKE_Au logical :: skeb_use_frict @@ -510,6 +515,12 @@ 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.") @@ -693,7 +704,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP is_vort, ie_vort, js_vort, je_vort, & !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, & - !$OMP apply_OBC, rescale_Kh, find_FrictWork, use_kh_struct, skeb_use_frict, & + !$OMP apply_OBC, apply_OBC_strain, rescale_Kh, find_FrictWork, use_kh_struct, skeb_use_frict, & !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, use_cont_huv, slope_x, slope_y, dz, & !$OMP backscat_subround, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & @@ -809,28 +820,29 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, ! thicknesses on open boundaries. if (apply_OBC) then ; do n=1,OBC%number_of_segments J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB - if (OBC%zero_strain .or. OBC%freeslip_strain .or. OBC%computed_strain) then + if (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) @@ -838,25 +850,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) @@ -1507,22 +1520,23 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, dDel2udy(I,J) = CS%DX_dyBu(I,J)*((Del2u(I,j+1)*G%IdxCu(I,j+1)) - (Del2u(I,j)*G%IdxCu(I,j))) enddo ; enddo ! Adjust contributions to shearing strain on open boundaries. - if (apply_OBC) then ; if (OBC%zero_strain .or. OBC%freeslip_strain) then + if (apply_OBC) then ; if ((OBC%strain_config == OBC_STRAIN_ZERO) .or. & + (OBC%strain_config == OBC_STRAIN_FREESLIP)) then do n=1,OBC%number_of_segments J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= Jeq)) then do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - if (OBC%zero_strain) then + if (OBC%strain_config == OBC_STRAIN_ZERO) then dDel2vdx(I,J) = 0. ; dDel2udy(I,J) = 0. - elseif (OBC%freeslip_strain) then + elseif (OBC%strain_config == OBC_STRAIN_FREESLIP) then dDel2udy(I,J) = 0. endif enddo elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= Ieq)) then do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB - if (OBC%zero_strain) then + if (OBC%strain_config == OBC_STRAIN_ZERO) then dDel2vdx(I,J) = 0. ; dDel2udy(I,J) = 0. - elseif (OBC%freeslip_strain) then + elseif (OBC%strain_config == OBC_STRAIN_FREESLIP) then dDel2vdx(I,J) = 0. endif enddo @@ -1697,12 +1711,12 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, Kh_BS(I,J) = 0.25 * ((BS_coeff_h(i,j ,k) + BS_coeff_h(i+1,j+1,k)) + & (BS_coeff_h(i,j+1,k) + BS_coeff_h(i+1,j ,k))) enddo ; enddo - endif - if (CS%id_BS_coeff_q>0) then - do J=js-1,Jeq ; do I=is-1,Ieq - BS_coeff_q(I,J,k) = Kh_BS(I,J) - enddo ; enddo + if (CS%id_BS_coeff_q > 0) then + do J=js-1,Jeq ; do I=is-1,Ieq + BS_coeff_q(I,J,k) = Kh_BS(I,J) + enddo ; enddo + endif endif if (CS%id_Kh_q > 0 .or. CS%debug) then @@ -1822,7 +1836,7 @@ 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 + endif if (CS%id_Ah_q>0 .or. CS%debug) then do J=js-1,Jeq ; do I=is-1,Ieq @@ -2034,7 +2048,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 (CS%id_FrictWork_bh>0 .or. CS%id_FrictWorkIntz_bh > 0 .or. allocated(MEKE%mom_src_bh) & + .or. (allocated(MEKE%mom_src) .and. MEKE%backscatter_Ro_c /= 0.)) then if (CS%FrictWork_bug) then ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) ! This is the old formulation that includes energy diffusion !cyc @@ -2501,7 +2516,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "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, "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. @@ -2618,7 +2633,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 @@ -2678,9 +2693,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 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"//& + "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.) diff --git a/src/parameterizations/lateral/MOM_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90 index 652da865ee..645333991a 100644 --- a/src/parameterizations/lateral/MOM_interface_filter.F90 +++ b/src/parameterizations/lateral/MOM_interface_filter.F90 @@ -298,7 +298,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. @@ -338,7 +338,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. @@ -385,9 +385,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 73740e5412..0803a70841 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -50,7 +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 [s ~> T] + 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. @@ -103,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] @@ -132,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, @@ -340,15 +340,12 @@ 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 @@ -1365,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)) @@ -1428,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]. @@ -1462,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] @@ -1543,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 @@ -1683,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 @@ -2107,8 +2104,6 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, test, halo_size, r 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]. @@ -2311,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 @@ -2401,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 @@ -2650,7 +2645,6 @@ subroutine turning_latitude(En, NAngle, freq2, CS, G, LB) 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 :: Pi_2 ! pi/2 [nondim] real :: Angle_size ! size of beam wedge [rad] real :: I_Angle_size ! inverse of size of beam wedge [rad-1] real :: f2 @@ -3258,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, m - 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] @@ -3413,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] @@ -3515,8 +3507,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "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", & + "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 @@ -3775,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 @@ -4070,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 f220d696c8..d8a93a3f93 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -49,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 @@ -208,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 @@ -226,11 +227,15 @@ 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 @@ -843,18 +848,18 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C integer :: OBC_dir_v(SZI_(G),SZJB_(G)) ! An integer indicating where there are v OBCs: +1 for ! northern OBCs, -1 for southern OBCs and 0 at points with no OBCs. real :: h4_u(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! The product of the 4 thicknesses surrounding a u-point - ! interface or the inward equivalent with OBCs [H4 ~> m4 or kg2 m-4] + ! 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 kg2 m-4] + ! 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 @@ -1049,7 +1054,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 @@ -1070,7 +1075,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. @@ -1113,7 +1118,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. @@ -1194,6 +1199,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] @@ -1208,15 +1214,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 @@ -1303,9 +1308,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 @@ -1328,9 +1334,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 @@ -1593,7 +1600,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.",& @@ -1614,7 +1621,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 "// & @@ -1789,7 +1796,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 "//& @@ -1954,10 +1961,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, & @@ -2114,7 +2121,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 diff --git a/src/parameterizations/lateral/MOM_meso_sfn_ANN.F90 b/src/parameterizations/lateral/MOM_meso_sfn_ANN.F90 new file mode 100644 index 0000000000..e08224b575 --- /dev/null +++ b/src/parameterizations/lateral/MOM_meso_sfn_ANN.F90 @@ -0,0 +1,696 @@ +! This 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 an ANN-based mesoscale streamfunction parameterization for use +!! with isopycnal height diffusion in MOM_thickness_diffuse. +!! +!! The network reads a nondimensionalized stencil of density gradients, +!! strain rate components, and relative vorticity, and returns two density +!! flux components at the cell center. The dimensionalization in +!! meso_sfn_ANN_compute (multiplication by rho_grad_mag * vel_grad_mag * +!! areaT * ann_coeff) must match the nondimensionalization used when the +!! network was trained -- changing one without the other will produce +!! garbage fluxes. The training procedure is the implicit contract. +!! +!! Density fluxes are converted to a velocity-scale streamfunction +!! Upsilon (Ferrari et al. 2010) by dividing by the local 3-D density +!! gradient magnitude; a configurable clamp acts on Upsilon so the cap is +!! grid-independent. The volume-transport streamfunction passed back to +!! thickness_diffuse is Upsilon * dy_Cu (or dx_Cv), matching MOM6's +!! Sfn_unlim convention. +module MOM_meso_sfn_ANN + +use MOM_ANN, only : ANN_init, ANN_apply_array_sio, ANN_end, ANN_CS +use MOM_diag_mediator, only : post_data, register_diag_field, diag_ctrl, time_type +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_isopycnal_slopes, only : calc_isoneutral_slopes +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_domains, only : pass_vector + +implicit none ; private + +#include + +public :: meso_sfn_ANN_init, meso_sfn_ANN_compute, meso_sfn_ANN_end + +!> Control structure for meso-scale streamfunction ANN parameterization +type, public :: MESO_SFN_ANN_CS; private + logical :: initialized = .false. !< If true, the module has been initialized. + logical :: debug !< if true, write verbose checksums for debugging purposes. + + real :: ann_coeff !< Coefficient to multiply the ANN output by. + real :: kappa_smooth !< Vertical diffusivity used to interpolate more sensible values + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + integer :: ann_window !< Size of the window used in the ANN model. + + type(ANN_CS) :: ann_rho_flux !< ANN instance for off-diagonal and diagonal stress + character(len=200) :: ann_file_rho_flux !< Path to netcdf file with ANN + real :: min_dist_from_boundary !< Minimum distance from bottom for valid interface [Z ~> m] + real :: mag_grad_floor !< Floor for density gradient magnitude [R Z-1 ~> kg m-4] + real :: flux_clamp !< Maximum magnitude of ANN output density flux [R L T-1 ~> kg m-2 s-1] + real :: Upsilon_clamp !< Maximum magnitude of the velocity-scale streamfunction + !! Upsilon (Ferrari et al. 2010) [L Z T-1 ~> m2 s-1] + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics + ! Diagnostic identifiers + integer :: id_drdx_u !< Diagnostic id for zonal density gradient at u-points. + integer :: id_drdy_v !< Diagnostic id for meridional density gradient at v-points. + integer :: id_drdz_u !< Diagnostic id for vertical density gradient at u-points. + integer :: id_drdz_v !< Diagnostic id for vertical density gradient at v-points. + integer :: id_drdx_c !< Diagnostic id for zonal density gradient at center points. + integer :: id_drdy_c !< Diagnostic id for meridional density gradient at center points. + integer :: id_Fx_c !< Diagnostic id for zonal density flux at center points. + integer :: id_Fy_c !< Diagnostic id for meridional density flux at center points. + integer :: id_Fx_u !< Diagnostic id for zonal density flux at u-points. + integer :: id_Fy_v !< Diagnostic id for meridional density flux at v-points. + integer :: id_sfn_u !< Diagnostic id for volume streamfunction at u-points. + integer :: id_sfn_v !< Diagnostic id for volume streamfunction at v-points. +end type MESO_SFN_ANN_CS + +contains + +!> Compute the ANN-based mesoscale streamfunction on u- and v-points. +!! +!! Computes density gradients and velocity gradients, feeds them through the ANN +!! to get density fluxes at cell centers, then converts those fluxes into a +!! streamfunction on u- and v-points for use in thickness_diffuse. +subroutine meso_sfn_ANN_compute(h, e, sfn_u, sfn_v, G, GV, US, tv, CS, dt, u, v) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Layer thickness [Z ~> m or kg m-2] + type(MESO_SFN_ANN_CS), intent(inout) :: CS !< Control structure for thickness_flux_ann + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: sfn_u !< Mesoscale volume streamfunction + !! on u-points [Z L2 T-1 ~> m3 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(out) :: sfn_v !< Mesoscale volume streamfunction + !! on v-points [Z L2 T-1 ~> m3 s-1] + real, intent(in) :: dt !< Model time step [T ~> s] + 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]. + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz, shift, stencil_points, ii, jj + integer :: nij, m + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: drdx_u !< Zonal density gradient at u [R L-1 ~> kg m-4] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: drdz_u !< Vertical density gradient at u [R Z-1 ~> kg m-4] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: drdy_v !< Meridional density gradient at v [R L-1 ~> kg m-4] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: drdz_v !< Vertical density gradient at v [R Z-1 ~> kg m-4] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: slope_x !< Isopycnal slope in x at u [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: slope_y !< Isopycnal slope in y at v [Z L-1 ~> nondim] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: Fx_u !< Zonal density flux at u-points [R L T-1 ~> kg m-2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: Fy_v !< Meridional density flux at v-points [R L T-1 ~> kg m-2 s-1] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: drdx_c !< Zonal density gradient at center points [R L-1 ~> kg m-4] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: drdy_c !< Meridional density gradient + !! at center points [R L-1 ~> kg m-4] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: Fx_c !< Zonal density flux at center points [R L T-1 ~> kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: Fy_c !< Meridional density flux at + !! center points [R L T-1 ~> kg m-2 s-1] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dudx !< du/dx at cell center [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dvdy !< dv/dy at cell center [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dudy !< du/dy at cell center [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dvdx !< dv/dx at cell center [T-1 ~> s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: norm_y !< Scaling coefficient for ANN outputs [R L-1 T-1 ~> kg m-4 s-1] + + real, allocatable :: drdx_local(:,:) !< Local stencil of drdx [R L-1 ~> kg m-4] + real, allocatable :: drdy_local(:,:) !< Local stencil of drdy [R L-1 ~> kg m-4] + real, allocatable :: dudx_local(:,:) !< Local stencil of du/dx [T-1 ~> s-1] + real, allocatable :: dudy_local(:,:) !< Local stencil of du/dy [T-1 ~> s-1] + real, allocatable :: dvdx_local(:,:) !< Local stencil of dv/dx [T-1 ~> s-1] + real, allocatable :: dvdy_local(:,:) !< Local stencil of dv/dy [T-1 ~> s-1] + real, allocatable :: sh_xx_local(:,:) !< Local stencil of normal strain [T-1 ~> s-1] + real, allocatable :: sh_xy_local(:,:) !< Local stencil of shear strain [T-1 ~> s-1] + real, allocatable :: vort_local(:,:) !< Local stencil of relative vorticity [T-1 ~> s-1] + real :: vel_grad_mag !< Magnitude of velocity gradient tensor over stencil [T-1 ~> s-1] + real :: rho_grad_mag !< Magnitude of density gradient over stencil [R L-1 ~> kg m-4] + real, allocatable :: x(:,:) !< Input vector to the ANN + real, allocatable :: y(:,:) !< Output vector from the ANN + real, allocatable :: yy(:) !< Local output vector from the ANN + real :: mag_grad !< Magnitude of 3-D density gradient [R Z-1 ~> kg m-4] + logical :: use_stanley + logical :: use_EOS + real :: dist_from_bot_a, dist_from_bot_b ! Distance from interface to bottom [Z ~> m] + real :: dist_from_sfc_a, dist_from_sfc_b ! Distance from interface to surface [Z ~> m] + real :: Upsilon_u ! Velocity-scale streamfunction at u-point (Ferrari et al. 2010) [L Z T-1 ~> m2 s-1] + real :: Upsilon_v ! Velocity-scale streamfunction at v-point (Ferrari et al. 2010) [L Z T-1 ~> m2 s-1] + real :: rho_grad_neglect ! A density gradient magnitude so small it is lost in + ! roundoff; used to prevent division by zero [R L-1 ~> kg m-4] + real :: vel_grad_neglect ! A velocity gradient magnitude so small it is lost in + ! roundoff; used to prevent division by zero [T-1 ~> s-1] + + if (.not. CS%initialized) call MOM_error(FATAL, & + "meso_sfn_ANN_compute: Module MOM_meso_sfn_ANN must be initialized before use.") + + use_stanley = .false. ! Not using Stanley smoothing here. + use_EOS = associated(tv%eqn_of_state) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + rho_grad_neglect = 1.0e-30 * US%kg_m3_to_R * US%L_to_m + vel_grad_neglect = 1.0e-30 * US%T_to_s + + ! Allocate the local stencil variables + allocate(drdx_local(CS%ann_window, CS%ann_window), drdy_local(CS%ann_window, CS%ann_window), & + dudx_local(CS%ann_window, CS%ann_window), dudy_local(CS%ann_window, CS%ann_window), & + dvdx_local(CS%ann_window, CS%ann_window), dvdy_local(CS%ann_window, CS%ann_window), & + sh_xx_local(CS%ann_window, CS%ann_window), sh_xy_local(CS%ann_window, CS%ann_window), & + vort_local(CS%ann_window, CS%ann_window)) + + shift = (CS%ann_window-1)/2 + stencil_points = CS%ann_window * CS%ann_window + + ! Number of horizontal grid points in ANN inference loop below + nij = (ie - is + 3) * (je - js + 3) + allocate(x(nij, stencil_points*5), y(nij, 2)) + allocate(yy(2)) + + slope_x(:,:,:) = 0.0 + slope_y(:,:,:) = 0.0 + + sfn_u(:,:,:) = 0.0 + sfn_v(:,:,:) = 0.0 + + Fx_u(:,:,:) = 0.0 + Fy_v(:,:,:) = 0.0 + Fx_c(:,:,:) = 0.0 + Fy_c(:,:,:) = 0.0 + + drdx_u(:,:,:) = 0.0 + drdy_v(:,:,:) = 0.0 + drdz_u(:,:,:) = 0.0 + drdz_v(:,:,:) = 0.0 + drdx_c(:,:,:) = 0.0 + drdy_c(:,:,:) = 0.0 + ! Compute rho gradients + if (use_EOS) then + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, use_stanley, slope_x, slope_y, & + drdx_u=drdx_u, drdy_v=drdy_v, drdz_u=drdz_u, drdz_v=drdz_v, halo=3) + else + call calc_layered_density_gradients(G, GV, US, h, e, drdx_u, drdy_v, drdz_u, drdz_v, halo=3, & + min_dist_from_boundary=CS%min_dist_from_boundary) + endif + + ! Interpolate the rho gradients to the center point + call center_grad_rho(drdx_u, drdy_v, drdx_c, drdy_c, G, GV, CS) + + ! Compute velocity gradients at center points + call vel_gradients(u, v, G, GV, dudx, dudy, dvdx, dvdy, CS) + + ! Post diagnostics + if (CS%id_drdx_u > 0) call post_data(CS%id_drdx_u, drdx_u, CS%diag) + if (CS%id_drdy_v > 0) call post_data(CS%id_drdy_v, drdy_v, CS%diag) + + if (CS%id_drdz_u > 0) call post_data(CS%id_drdz_u, drdz_u, CS%diag) + if (CS%id_drdz_v > 0) call post_data(CS%id_drdz_v, drdz_v, CS%diag) + + if (CS%id_drdx_c > 0) call post_data(CS%id_drdx_c, drdx_c, CS%diag) + if (CS%id_drdy_c > 0) call post_data(CS%id_drdy_c, drdy_c, CS%diag) + + ! Compute the density fluxes at center points using the ANN. + do K = 2, nz + m = 0 + do j = js-1, je+1 ; do i = is-1, ie+1 + m = m + 1 + drdx_local(:,:) = drdx_c(i-shift:i+shift,j-shift:j+shift,K) + drdy_local(:,:) = drdy_c(i-shift:i+shift,j-shift:j+shift,K) + ! Take the velocity gradients below the interface K + dudx_local(:,:) = dudx(i-shift:i+shift,j-shift:j+shift,k) + dudy_local(:,:) = dudy(i-shift:i+shift,j-shift:j+shift,k) + dvdx_local(:,:) = dvdx(i-shift:i+shift,j-shift:j+shift,k) + dvdy_local(:,:) = dvdy(i-shift:i+shift,j-shift:j+shift,k) + + ! Compute the strain rate tensor components and vorticity + sh_xx_local(:,:) = dudx_local(:,:) - dvdy_local(:,:) + sh_xy_local(:,:) = dudy_local(:,:) + dvdx_local(:,:) + vort_local(:,:) = dvdx_local(:,:) - dudy_local(:,:) + + ! Compute the magnitude of the velocity gradient tensor for the local stencil + rho_grad_mag = 0.0 + vel_grad_mag = 0.0 + do jj=1, CS%ann_window + do ii=1, CS%ann_window + rho_grad_mag = (rho_grad_mag + drdx_local(ii,jj)*drdx_local(ii,jj)) + & + drdy_local(ii,jj)*drdy_local(ii,jj) + vel_grad_mag = ((vel_grad_mag + sh_xx_local(ii,jj)*sh_xx_local(ii,jj)) + & + sh_xy_local(ii,jj)*sh_xy_local(ii,jj)) + & + vort_local(ii,jj)*vort_local(ii,jj) + enddo + enddo + rho_grad_mag = sqrt(rho_grad_mag) + rho_grad_neglect + vel_grad_mag = sqrt(vel_grad_mag) + vel_grad_neglect + norm_y(i,j) = rho_grad_mag * vel_grad_mag + + ! Normalize inputs + drdx_local(:,:) = drdx_local(:,:) / rho_grad_mag + drdy_local(:,:) = drdy_local(:,:) / rho_grad_mag + + sh_xx_local(:,:) = sh_xx_local(:,:)/ vel_grad_mag + sh_xy_local(:,:) = sh_xy_local(:,:)/ vel_grad_mag + vort_local(:,:) = vort_local(:,:)/ vel_grad_mag + + ! Prepare input vector for ANN + x(m,1:stencil_points) = RESHAPE(drdx_local, (/stencil_points/)) + x(m,stencil_points+1:2*stencil_points) = RESHAPE(drdy_local, (/stencil_points/)) + x(m,2*stencil_points+1:3*stencil_points) = RESHAPE(sh_xx_local, (/stencil_points/)) + x(m,3*stencil_points+1:4*stencil_points) = RESHAPE(sh_xy_local, (/stencil_points/)) + x(m,4*stencil_points+1:5*stencil_points) = RESHAPE(vort_local, (/stencil_points/)) + + enddo ; enddo + + ! Call the ANN + call ANN_apply_array_sio(nij, x,y, CS%ann_rho_flux) + + m=0 + do j = js-1, je+1 ; do i = is-1, ie+1 + m=m+1 + ! Dimensionalize the output. The factors applied here must match the + ! nondimensionalization used when the network was trained; this is + ! an implicit contract with the training procedure. + yy(:) = ((y(m,:) * norm_y(i,j)) * G%areaT(i,j)) * CS%ann_coeff + + ! Clamp ANN output to prevent extreme values + yy(1) = max(-CS%flux_clamp, min(CS%flux_clamp, yy(1))) + yy(2) = max(-CS%flux_clamp, min(CS%flux_clamp, yy(2))) + + ! The sign convention is that ANN outputs -u'rho', so we negate. + Fx_c(i,j,K) = -yy(1) + Fy_c(i,j,K) = -yy(2) + + enddo ; enddo + enddo + + ! Interpolate the density fluxes to u and v points. + call center2uv(Fx_c, Fy_c, Fx_u, Fy_v, G, GV) + + do K=2, nz + do j=js,je ; do I=is-1,ie + ! In layered mode, skip interfaces at the bottom or surface + if (.not. use_EOS) then + dist_from_bot_a = e(i,j,K) - e(i,j,nz+1) + dist_from_bot_b = e(i+1,j,K) - e(i+1,j,nz+1) + dist_from_sfc_a = e(i,j,1) - e(i,j,K) + dist_from_sfc_b = e(i+1,j,1) - e(i+1,j,K) + if (dist_from_bot_a < CS%min_dist_from_boundary .or. & + dist_from_bot_b < CS%min_dist_from_boundary .or. & + dist_from_sfc_a < CS%min_dist_from_boundary .or. & + dist_from_sfc_b < CS%min_dist_from_boundary) then + sfn_u(I,j,K) = 0.0 + cycle + endif + endif + ! Skip if density gradient is too small (prevents division by ~zero) + mag_grad = sqrt( US%Z_to_L**2*drdx_u(I,j,K)**2 + drdz_u(I,j,K)**2 ) + if (mag_grad < CS%mag_grad_floor) then + sfn_u(I,j,K) = 0.0 + cycle + endif + ! Velocity-scale (grid-independent) streamfunction, Upsilon in Ferrari et al. 2010. + Upsilon_u = (Fx_u(I,j,K)/mag_grad) * G%OBCmaskCu(I,j) + Upsilon_u = max(-CS%Upsilon_clamp, min(CS%Upsilon_clamp, Upsilon_u)) + sfn_u(I,j,K) = Upsilon_u * G%dy_Cu(I,j) + + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (.not. use_EOS) then + dist_from_bot_a = e(i,j,K) - e(i,j,nz+1) + dist_from_bot_b = e(i,j+1,K) - e(i,j+1,nz+1) + dist_from_sfc_a = e(i,j,1) - e(i,j,K) + dist_from_sfc_b = e(i,j+1,1) - e(i,j+1,K) + if (dist_from_bot_a < CS%min_dist_from_boundary .or. & + dist_from_bot_b < CS%min_dist_from_boundary .or. & + dist_from_sfc_a < CS%min_dist_from_boundary .or. & + dist_from_sfc_b < CS%min_dist_from_boundary) then + sfn_v(i,J,K) = 0.0 + cycle + endif + endif + ! Skip if density gradient is too small (prevents division by ~zero) + mag_grad = sqrt( US%Z_to_L**2*drdy_v(i,J,K)**2 + drdz_v(i,J,K)**2 ) + + if (mag_grad < CS%mag_grad_floor) then + sfn_v(i,J,K) = 0.0 + cycle + endif + + ! Velocity-scale (grid-independent) streamfunction, Upsilon in Ferrari et al. 2010. + Upsilon_v = (Fy_v(i,J,K)/mag_grad) * G%OBCmaskCv(i,J) + Upsilon_v = max(-CS%Upsilon_clamp, min(CS%Upsilon_clamp, Upsilon_v)) + sfn_v(i,J,K) = Upsilon_v * G%dx_Cv(i,J) + + enddo ; enddo + enddo + + call pass_vector(sfn_u, sfn_v, G%Domain) + + if (CS%id_Fx_c > 0) call post_data(CS%id_Fx_c, Fx_c, CS%diag) + if (CS%id_Fy_c > 0) call post_data(CS%id_Fy_c, Fy_c, CS%diag) + + if (CS%id_Fx_u > 0) call post_data(CS%id_Fx_u, Fx_u, CS%diag) + if (CS%id_Fy_v > 0) call post_data(CS%id_Fy_v, Fy_v, CS%diag) + + if (CS%id_sfn_u > 0) call post_data(CS%id_sfn_u, sfn_u, CS%diag) + if (CS%id_sfn_v > 0) call post_data(CS%id_sfn_v, sfn_v, CS%diag) + + deallocate(drdx_local, drdy_local, dudx_local, dudy_local, dvdx_local, dvdy_local, & + sh_xx_local, sh_xy_local, vort_local) + deallocate(x, y, yy) +end subroutine meso_sfn_ANN_compute + +!> Interpolate density gradients from u- and v-points to cell centers. +subroutine center_grad_rho(drdx_u, drdy_v, drdx_c, drdy_c, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(MESO_SFN_ANN_CS), intent(inout) :: CS !< Control structure for thickness_flux_ann + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: drdx_u !< Zonal density gradient + !! at u-points [R L-1 ~> kg m-4] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: drdy_v !< Meridional density gradient + !! at v-points [R L-1 ~> kg m-4] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: drdx_c !< Zonal density gradient + !! at center [R L-1 ~> kg m-4] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: drdy_c !< Meridional density gradient + !! at center [R L-1 ~> kg m-4] + + integer :: i, j, k, is, ie, js, je, nz, shift + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + shift = (CS%ann_window-1)/2 + + do K=1, nz+1 + do j=js-shift-1,je+shift+1 ; do i=is-shift-1,ie+shift+1 + drdx_c(i,j,K) = 0.5 * (drdx_u(i-1,j,K) * G%mask2dCu(i-1,j) + drdx_u(i,j,K) * G%mask2dCu(i,j)) * G%mask2dT(i,j) + drdy_c(i,j,K) = 0.5 * (drdy_v(i,j-1,K) * G%mask2dCv(i,j-1) + drdy_v(i,j,K) * G%mask2dCv(i,j)) * G%mask2dT(i,j) + enddo ; enddo + enddo + +end subroutine center_grad_rho + +!> Interpolate two fields from cell centers to u- and v-points. +subroutine center2uv(var1_c, var2_c, var1_u, var2_v, G, GV) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: var1_c !< Variable at center points [arbitrary] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: var2_c !< Variable at center points [arbitrary] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: var1_u !< Variable at u points [arbitrary] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: var2_v !< Variable at v points [arbitrary] + + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + do K=1, nz+1 + do j=js,je ; do I=is-1,ie + var1_u(I,j,K) = 0.5 * (var1_c(i,j,K) * G%mask2dT(i,j) + var1_c(i+1,j,K) * G%mask2dT(i+1,j)) * G%mask2dCu(I,j) + enddo ; enddo + do J=js-1,je ; do i=is,ie + var2_v(i,J,K) = 0.5 * (var2_c(i,j,K) * G%mask2dT(i,j) + var2_c(i,j+1,K) * G%mask2dT(i,j+1)) * G%mask2dCv(i,J) + enddo ; enddo + enddo + +end subroutine center2uv +!> Calculates the velocity gradients at the center points in 3D. +subroutine vel_gradients(u, v, G, GV, dudx, dudy, dvdx, dvdy, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)),intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)),intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: dudx !< du/dx [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: dvdy !< dv/dy [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: dudy !< du/dy [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: dvdx !< dv/dx [T-1 ~> s-1] + type(MESO_SFN_ANN_CS), intent(in) :: CS !< Control structure for thickness_flux_ann + + ! Corner points + real, dimension(SZIB_(G), SZJB_(G),SZK_(GV)) :: dudy_q !< du/dy at corner points [T-1 ~> s-1] + real, dimension(SZIB_(G), SZJB_(G),SZK_(GV)) :: dvdx_q !< dv/dx at corner points [T-1 ~> s-1] + integer :: is, ie, js, je + integer :: nz + integer :: i, j, k + integer :: shift + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + shift = (CS%ann_window-1)/2 + + do k=1, nz + ! Calculate velocity gradients at center points directly. + do j=js-shift-1,je+shift+1 ; do i=is-shift-1,ie+shift+1 + dudx(i,j,k) = G%IdxT(i,j)* (u(I,j,k) * G%mask2dCu(I,j) - u(I-1,j,k) * G%mask2dCu(I-1,j)) * G%mask2dT(i,j) + dvdy(i,j,k) = G%IdyT(i,j)* (v(i,J,k) * G%mask2dCv(i,J) - v(i,J-1,k) * G%mask2dCv(i,J-1)) * G%mask2dT(i,j) + enddo ; enddo + + ! Calculate velocity gradients at corner points. + ! Bounds extend one further on the lower side than the center-point loop above + ! because the 4-point corner-to-center interpolation below reads indices (I-1,J-1). + do j=js-shift-2,je+shift+1 ; do i=is-shift-2,ie+shift+1 + dvdx_q(I,J,k) = G%IdxBu(I,J)*(v(i+1,J,k) - v(i,J,k) ) * G%mask2dBu(I,J) + dudy_q(I,J,k) = G%IdyBu(I,J)*(u(I,j+1,k) - u(I,j,k) ) * G%mask2dBu(I,J) + ! + enddo ; enddo + + ! interpolate corner grads to center points + do j = js-shift-1, je+shift+1; do i = is-shift-1, ie+shift+1 + dvdx(i,j,k) = 0.25 * (((dvdx_q(I,J,k) + dvdx_q(I-1,J,k)) + dvdx_q(I,J-1,k)) + & + dvdx_q(I-1,J-1,k)) * G%mask2dT(i,j) + dudy(i,j,k) = 0.25 * (((dudy_q(I,J,k) + dudy_q(I-1,J,k)) + dudy_q(I,J-1,k)) + & + dudy_q(I-1,J-1,k)) * G%mask2dT(i,j) + enddo; enddo + enddo +end subroutine vel_gradients +!> Compute density gradients from fixed layer densities and interface heights +!! This is a workaround for running the ANN parameterization in pure layered +!! mode (USE_EOS=False) where calc_isoneutral_slopes won't work. +subroutine calc_layered_density_gradients(G, GV, US, h, e, & + drdx_u, drdy_v, drdz_u, drdz_v, halo, min_dist_from_boundary) + type(ocean_grid_type), intent(in) :: G + type(verticalGrid_type), intent(in) :: GV + type(unit_scale_type), intent(in) :: US + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h ! Layer thickness [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e ! Interface heights [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: drdx_u ! [R L-1 ~> kg m-4] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(out) :: drdy_v ! [R L-1 ~> kg m-4] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: drdz_u ! [R Z-1 ~> kg m-4] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(out) :: drdz_v ! [R Z-1 ~> kg m-4] + integer, intent(in) :: halo + real, intent(in) :: min_dist_from_boundary ! Threshold for boundaries [Z] + + ! Local variables + real :: drho_k ! Density difference across interface K [R] + real :: dz_u, dz_v ! Vertical length scale at u,v points [Z] + real :: dedx, dedy ! Interface slope [Z L-1] + real :: h_neglect ! Small thickness [H] + real :: dist_from_bot_a, dist_from_bot_b ! Distance from interface to bottom [Z] + real :: dist_from_sfc_a, dist_from_sfc_b ! Distance from interface to surface [Z] + + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + h_neglect = GV%H_subroundoff + ! Initialize to zero + drdx_u(:,:,:) = 0.0 + drdy_v(:,:,:) = 0.0 + drdz_u(:,:,:) = 0.0 + drdz_v(:,:,:) = 0.0 + + ! Loop over interfaces (K=1 is surface, K=nz+1 is bottom) + do K = 2, nz + ! Density jump across this interface (from GV%Rlay - the target layer densities) + drho_k = GV%Rlay(k) - GV%Rlay(k-1) ! [R ~> kg m-3] + + ! --- U-points (zonal gradients) --- + do j = js-halo, je+halo + do I = is-1-halo, ie+halo + + ! Check if interface is above bottom on both sides + ! e is negative (depth), e(nz+1) is the bottom, e(1) is the surface + dist_from_bot_a = e(i,j,K) - e(i,j,nz+1) + dist_from_bot_b = e(i+1,j,K) - e(i+1,j,nz+1) + dist_from_sfc_a = e(i,j,1) - e(i,j,K) + dist_from_sfc_b = e(i+1,j,1) - e(i+1,j,K) + + if (dist_from_bot_a > min_dist_from_boundary .and. & + dist_from_bot_b > min_dist_from_boundary .and. & + dist_from_sfc_a > min_dist_from_boundary .and. & + dist_from_sfc_b > min_dist_from_boundary .and. & + G%mask2dCu(I,j) > 0.5) then + + ! Average thickness of layers above and below interface at u-point + dz_u = 0.25 * GV%H_to_Z * ( & + (h(i,j,k-1) + h(i,j,k)) + (h(i+1,j,k-1) + h(i+1,j,k)) ) + dz_u = max(dz_u, GV%H_to_Z * h_neglect) + + ! Interface height gradient (slope of isopycnal) + dedx = (e(i+1,j,K) - e(i,j,K)) * G%IdxCu(I,j) ! [Z L-1] + + ! In a layered model with tilted interfaces: + ! dρ/dx comes from the interface tilt: (Δρ across interface) * (∂η/∂x) / Δz + ! dρ/dz is simply Δρ / Δz + ! + ! Physical interpretation: if interface tilts up to the east, + ! denser water (layer k) is lifted, creating ∂ρ/∂x < 0 + + drdx_u(I,j,K) = drho_k * dedx / dz_u ! [R L-1] + drdz_u(I,j,K) = - drho_k / dz_u ! [R Z-1] + + ! Apply land mask + drdx_u(I,j,K) = drdx_u(I,j,K) * (G%mask2dCu(I,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) + drdz_u(I,j,K) = drdz_u(I,j,K) * (G%mask2dCu(I,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) + else + ! Interface is at/near bottom or surface on at least one side - set gradients to zero + drdx_u(I,j,K) = 0.0 + drdz_u(I,j,K) = 0.0 + endif + enddo + enddo + + ! --- V-points (meridional gradients) --- + do J = js-1-halo, je+halo + do i = is-halo, ie+halo + ! Check if interface is above bottom and below surface on both sides + dist_from_bot_a = e(i,j,K) - e(i,j,nz+1) + dist_from_bot_b = e(i,j+1,K) - e(i,j+1,nz+1) + dist_from_sfc_a = e(i,j,1) - e(i,j,K) + dist_from_sfc_b = e(i,j+1,1) - e(i,j+1,K) + + if (dist_from_bot_a > min_dist_from_boundary .and. & + dist_from_bot_b > min_dist_from_boundary .and. & + dist_from_sfc_a > min_dist_from_boundary .and. & + dist_from_sfc_b > min_dist_from_boundary .and. & + G%mask2dCv(i,J) > 0.5) then + + ! Interface is a real isopycnal on both sides - compute gradients + dz_v = 0.25 * GV%H_to_Z * ( & + (h(i,j,k-1) + h(i,j,k)) + (h(i,j+1,k-1) + h(i,j+1,k)) ) + dz_v = max(dz_v, GV%H_to_Z * h_neglect) + + ! Interface height gradient + dedy = (e(i,j+1,K) - e(i,j,K)) * G%IdyCv(i,J) ! [Z L-1] + + drdy_v(i,J,K) = drho_k * dedy / dz_v ! [R L-1] + drdz_v(i,J,K) = -drho_k / dz_v ! [R Z-1] + else + ! Interface is at/near bottom or surface on at least one side, or masked + drdy_v(i,J,K) = 0.0 + drdz_v(i,J,K) = 0.0 + endif + enddo + enddo + enddo + +end subroutine calc_layered_density_gradients + +!> Initializes the meso-scale streamfunction ANN parameterization +!! +subroutine meso_sfn_ANN_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(MESO_SFN_ANN_CS), intent(inout) :: CS !< Control structure for meso sfn ann + + ! Local variables + character(len=40) :: mdl = "meso_sfn_ANN" ! This is module's name +# include "version_variable.h" + + CS%diag => diag + + call log_version(param_file, mdl, version, & + "ANN-based mesoscale streamfunction parameterization.") + + ! We don't need to check if use is true, because this is only called if it is. + call get_param(param_file, mdl, "MESO_SFN_ANN_COEFF", CS%ann_coeff, & + "Coefficient to multiply the mesoscale streamfunction ANN output by", default=1.0, units="nondim") + + call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & + "A diapycnal diffusivity that is used to interpolate "//& + "more sensible values of T & S into thin layers.", & + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "MESO_SFN_MIN_DIST_BOUNDARY", CS%min_dist_from_boundary, & + "Minimum distance from surface or bottom for interface to be considered valid "//& + "for density gradient calculations in layered mode.", & + units="m", default=50.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "MESO_SFN_MAG_GRAD_FLOOR", CS%mag_grad_floor, & + "Minimum density gradient magnitude below which the streamfunction "//& + "is set to zero to avoid division by near-zero values.", & + units="kg m-4", default=1.0e-10, scale=US%kg_m3_to_R*US%Z_to_m) + call get_param(param_file, mdl, "MESO_SFN_FLUX_CLAMP", CS%flux_clamp, & + "Maximum magnitude of ANN output density flux before conversion "//& + "to streamfunction.", & + units="kg m-2 s-1", default=1.0e2, scale=US%kg_m3_to_R*US%m_to_L*US%T_to_s) + call get_param(param_file, mdl, "MESO_UPSILON_CLAMP", CS%Upsilon_clamp, & + "Maximum magnitude of the velocity-scale mesoscale streamfunction "//& + "(Upsilon in Ferrari et al. 2010).", & + units="m2 s-1", default=15., scale=US%m_to_L*US%m_to_Z*US%T_to_s) + call get_param(param_file, mdl, "MESO_SFN_ANN_WINDOW", CS%ann_window, & + "Number of horizontal grid points to use in the thickness flux ANN window", default=1) + ! The stencil reads drdx_c(i-shift:i+shift,...) with shift=(ann_window-1)/2. + ! halo=3 is requested in meso_sfn_ANN_compute, so shift must be <= 3. + if (CS%ann_window < 1 .or. CS%ann_window > 3 .or. mod(CS%ann_window, 2) == 0) & + call MOM_error(FATAL, "meso_sfn_ANN_init: MESO_SFN_ANN_WINDOW must be an odd integer in [1,3].") + call get_param(param_file, mdl, "MESO_SFN_ANN_FILE", CS%ann_file_rho_flux, & + "ANN parameters for prediction of density fluxes (netcdf)", & + default="INPUT/rho_flux.nc") + call ANN_init(CS%ann_rho_flux, CS%ann_file_rho_flux) + + ! Register diagnostic fields + CS%id_drdx_u = register_diag_field('ocean_model', 'meso_sfn_drdx_u', diag%axesCui, Time, & + 'Zonal density gradient used in meso sfn', & + 'kg m-4', conversion=US%R_to_kg_m3*US%m_to_L) + CS%id_drdy_v = register_diag_field('ocean_model', 'meso_sfn_drdy_v', diag%axesCvi, Time, & + 'Meridional density gradient used in meso sfn', & + 'kg m-4', conversion=US%R_to_kg_m3*US%m_to_L) + CS%id_drdz_u = register_diag_field('ocean_model', 'meso_sfn_drdz_u', diag%axesCui, Time, & + 'Vertical density gradient at u points used in meso sfn', & + 'kg m-4', conversion=US%R_to_kg_m3*US%m_to_Z) + CS%id_drdz_v = register_diag_field('ocean_model', 'meso_sfn_drdz_v', diag%axesCvi, Time, & + 'Vertical density gradient at v points used in meso sfn', & + 'kg m-4', conversion=US%R_to_kg_m3*US%m_to_Z) + CS%id_drdx_c = register_diag_field('ocean_model', 'meso_sfn_drdx_c', diag%axesTi, Time, & + 'Zonal density gradient at center points used in meso sfn', & + 'kg m-4', conversion=US%R_to_kg_m3*US%m_to_L) + CS%id_drdy_c = register_diag_field('ocean_model', 'meso_sfn_drdy_c', diag%axesTi, Time, & + 'Meridional density gradient at center points used in meso sfn', & + 'kg m-4', conversion=US%R_to_kg_m3*US%m_to_L) + CS%id_Fx_c = register_diag_field('ocean_model', 'meso_sfn_flux_x_c', diag%axesTi, Time, & + 'Zonal density flux at center points used in meso sfn', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%L_to_m*US%s_to_T) + CS%id_Fy_c = register_diag_field('ocean_model', 'meso_sfn_flux_y_c', diag%axesTi, Time, & + 'Meridional density flux at center points used in meso sfn', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%L_to_m*US%s_to_T) + CS%id_Fx_u = register_diag_field('ocean_model', 'meso_sfn_flux_x_u', diag%axesCui, Time, & + 'Zonal density flux at u points used in meso sfn', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%L_to_m*US%s_to_T) + CS%id_Fy_v = register_diag_field('ocean_model', 'meso_sfn_flux_y_v', diag%axesCvi, Time, & + 'Meridional density flux at v points used in meso sfn', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%L_to_m*US%s_to_T) + CS%id_sfn_u = register_diag_field('ocean_model', 'meso_sfn_unlim_u', diag%axesCui, Time, & + 'Meso-scale volume streamfunction at u points', & + 'm3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_sfn_v = register_diag_field('ocean_model', 'meso_sfn_unlim_v', diag%axesCvi, Time, & + 'Meso-scale volume streamfunction at v points', & + 'm3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + + CS%initialized = .true. +end subroutine meso_sfn_ANN_init +!> Finalizes the meso-scale streamfunction ANN parameterization +!! +subroutine meso_sfn_ANN_end(CS) + type(MESO_SFN_ANN_CS), intent(inout) :: CS !< Control structure + + ! Deallocate anything that needs to be. + call ANN_end(CS%ann_rho_flux) + +end subroutine meso_sfn_ANN_end + +end module MOM_meso_sfn_ANN diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 9aea1d5e93..4affcf5c17 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -245,8 +245,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] @@ -261,7 +261,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 @@ -309,7 +309,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. @@ -330,7 +330,8 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, unscale=GV%H_to_mks) - call hchksum(h_MLD, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, unscale=GV%H_to_mks) + if (CS%MLE_density_diff <= 0.) & + call hchksum(h_MLD, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, unscale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) bFac = dt / ( dt + CS%MLE_MLD_decay_time ) @@ -506,7 +507,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 @@ -528,7 +529,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 @@ -543,7 +544,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 @@ -595,7 +596,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 @@ -618,7 +619,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 @@ -633,7 +634,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 @@ -835,17 +836,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 @@ -1230,7 +1230,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". @@ -1244,8 +1244,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] @@ -1298,7 +1298,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] @@ -1430,7 +1430,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 @@ -1481,7 +1481,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 @@ -1685,7 +1685,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, logical :: stoch_eos ! Can't use Stanley param here unless stoch_eos is true # include "version_variable.h" - integer :: i, j character(len=200) :: filename, varname ! Read all relevant parameters and write them to the model log. @@ -1783,16 +1782,16 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "parameter a micron away from the equator.", & units="m2 s-2", default=1.0e-24, scale=US%m_to_Z**2*US%T_to_s**2) call get_param(param_file, mdl, "WAVE_ENHANCED_USTAR", CS%wave_enhanced_ustar, & - "If true, enhance ustar using surface waves, following Eq. 28 in Bodner23. " //& - "Use a Langmuir number if provided. Otherwise, assumes equilibrium "// & + "If true, enhance ustar using surface waves, following Eq. 28 in Bodner23. "//& + "Use a Langmuir number if provided. Otherwise, assumes equilibrium "//& "surface waves (La-2=11.).", default=.false.) call get_param(param_file, mdl, "TAIL_DH", CS%MLE_tail_dh, & "Fraction by which to extend the mixed-layer restratification "//& "depth used for a smoother stream function at the base of "//& "the mixed-layer.", units="nondim", default=0.0) call get_param(param_file, mdl, "USE_CR_GRID", CS%Cr_grid, & - "If true, read in a spatially varying Cr field." //& - "If CR = 0 (default), this field is scaled by 1.0." //& + "If true, read in a spatially varying Cr field. "//& + "If CR = 0 (default), this field is scaled by 1.0. "//& "If CR>0., this field works as a mask and is scaled by CR.", default=.false.) call get_param(param_file, mdl, "USE_MLD_GRID", CS%MLD_grid, & "If true, read in a spatially varying MLD_decaying_Tfilt field.", default=.false.) @@ -1891,7 +1890,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 "//& @@ -2065,8 +2064,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 ==================' @@ -2118,7 +2117,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 ae1e0fec7c..7f6e35008c 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -42,7 +42,7 @@ 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 @@ -209,7 +209,7 @@ subroutine SAL_init(h, tv, G, GV, US, param_file, CS, restart_CS) 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 @@ -271,8 +271,12 @@ subroutine SAL_init(h, tv, G, GV, US, param_file, CS, restart_CS) end select call pass_var(CS%pbot_ref, G%Domain) endif - call get_param(param_file, '', "TIDES_ANSWER_DATE", tides_answer_date, default=20230630, & - do_not_log=.True.) ! used to check SAL_USE_BPA + + 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.") diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 44bdce9b71..d948583a42 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -231,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 618ae12786..701d0848a0 100644 --- a/src/parameterizations/lateral/MOM_streaming_filter.F90 +++ b/src/parameterizations/lateral/MOM_streaming_filter.F90 @@ -12,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 @@ -161,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 @@ -178,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 @@ -103,6 +106,9 @@ module MOM_thickness_diffuse !! isopycnal height diffusivity logical :: use_stanley_gm !< If true, also use the Stanley parameterization in MOM_thickness_diffuse + logical :: use_meso_sfn_ANN !< If true, use the meso-scale streamfunction ANN parameterization + type(MESO_SFN_ANN_CS) :: meso_sfn_ANN_CS !< Control structure for the meso-scale streamfunction ANN parameterization + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, allocatable :: GMwork(:,:) !< Work by isopycnal height diffusion [R Z L2 T-3 ~> W m-2] real, allocatable :: diagSlopeX(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] @@ -130,7 +136,7 @@ module MOM_thickness_diffuse !> Calculates isopycnal height diffusion coefficients and applies isopycnal height diffusion !! by modifying to the layer thicknesses, h. Diffusivities are limited to ensure stability. !! Also returns along-layer mass fluxes used in the continuity equation. -subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS, STOCH) +subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS, STOCH, u, v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -146,12 +152,18 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse type(stochastic_CS), intent(inout) :: STOCH !< Stochastic control 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]. + ! Local variables real :: e(SZI_(G),SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean ! sea level [Z ~> m], positive up. real :: uhD(SZIB_(G),SZJ_(G),SZK_(GV)) ! Diffusive u*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] real :: vhD(SZI_(G),SZJB_(G),SZK_(GV)) ! Diffusive v*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: Sfn_unlim_u_3D(SZIB_(G), SZJ_(G),SZK_(GV)+1) ! Volume streamfunction for u-points [Z L2 T-1 ~> m3 s-1] + real :: Sfn_unlim_v_3D(SZI_(G), SZJB_(G),SZK_(GV)+1) ! Volume streamfunction for v-points [Z L2 T-1 ~> m3 s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & KH_u, & ! Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] int_slope_u ! A nondimensional ratio from 0 to 1 that gives the relative @@ -231,8 +243,13 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp (dt * ((G%IdxCv(i,J)*G%IdxCv(i,J)) + (G%IdyCv(i,J)*G%IdyCv(i,J)))) enddo ; enddo - ! Calculates interface heights, e, in [Z ~> m]. - call find_eta(h, tv, G, GV, US, e, halo_size=1) + ! Calculates interface heights, e, in [Z ~> m]. The ANN streamfunction + ! needs a wider halo on e; default users keep the original halo_size=1. + if (CS%use_meso_sfn_ANN) then + call find_eta(h, tv, G, GV, US, e, halo_size=3) + else + call find_eta(h, tv, G, GV, US, e, halo_size=1) + endif ! Set the diffusivities. !$OMP parallel default(shared) @@ -482,6 +499,11 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp call add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, int_slope_u, int_slope_v) endif + if (CS%use_meso_sfn_ANN) then + call meso_sfn_ANN_compute(h, e, Sfn_unlim_u_3D, Sfn_unlim_v_3D, G, GV, US, tv, & + CS%meso_sfn_ANN_CS, dt, u, v) + endif + if (CS%debug) then call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & unscale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) @@ -509,18 +531,22 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (use_stored_slopes) then call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y, & - STOCH=STOCH, VarMix=VarMix) + STOCH=STOCH, VarMix=VarMix, & + Sfn_unlim_u_3D=Sfn_unlim_u_3D, Sfn_unlim_v_3D=Sfn_unlim_v_3D) else call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & - int_slope_u, int_slope_v, STOCH=STOCH, VarMix=VarMix) + int_slope_u, int_slope_v, STOCH=STOCH, VarMix=VarMix, & + Sfn_unlim_u_3D=Sfn_unlim_u_3D, Sfn_unlim_v_3D=Sfn_unlim_v_3D) endif else if (use_stored_slopes) then call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & - int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y) + int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y, & + Sfn_unlim_u_3D=Sfn_unlim_u_3D, Sfn_unlim_v_3D=Sfn_unlim_v_3D) else call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & - int_slope_u, int_slope_v) + int_slope_u, int_slope_v, & + Sfn_unlim_u_3D=Sfn_unlim_u_3D, Sfn_unlim_v_3D=Sfn_unlim_v_3D) endif endif @@ -632,7 +658,8 @@ end subroutine thickness_diffuse !! Fluxes are limited to give positive definite thicknesses. !! Called by thickness_diffuse(). subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, & - CS, int_slope_u, int_slope_v, slope_x, slope_y, STOCH, VarMix) + CS, int_slope_u, int_slope_v, slope_x, slope_y, STOCH, VarMix, & + Sfn_unlim_u_3D, Sfn_unlim_v_3D) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -661,6 +688,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! density gradients [nondim]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopyc. slope at u [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopyc. slope at v [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: Sfn_unlim_u_3D !< ANN streamfunction + !! at u [Z L2 T-1 ~> m3 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: Sfn_unlim_v_3D !< ANN streamfunction + !! at v [Z L2 T-1 ~> m3 s-1] type(stochastic_CS), optional, intent(inout) :: STOCH !< Stochastic control structure type(VarMix_CS), target, optional, intent(in) :: VarMix !< Variable mixing coefficents @@ -782,14 +813,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 @@ -857,7 +882,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 @@ -903,7 +928,8 @@ 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 Sfn_unlim_u_3D, & + !$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, & @@ -1061,6 +1087,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Estimate the streamfunction at each interface [H L2 T-1 ~> m3 s-1 or kg s-1]. Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope + if (CS%use_meso_sfn_ANN) then + Sfn_unlim_u(I,K) = Sfn_unlim_u(I,K) + Sfn_unlim_u_3D(I,j,K) + endif + ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. if (Sfn_unlim_u(I,K) > 0.0) then ! The flow below this interface is positive. @@ -1085,11 +1115,36 @@ 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 dzN2_u(I,K) = GV%g_prime(K) + + if (CS%use_meso_sfn_ANN) then + Sfn_unlim_u(I,K) = Sfn_unlim_u(I,K) + Sfn_unlim_u_3D(I,j,K) + + ! Avoid moving dense water upslope from below the level of + ! the bottom on the receiving side. + if (Sfn_unlim_u(I,K) > 0.0) then ! The flow below this interface is positive. + if (e(i,j,K) < e(i+1,j,nz+1)) then + Sfn_unlim_u(I,K) = 0.0 ! This is not uhtot, because it may compensate for + ! deeper flow in very unusual cases. + elseif (e(i+1,j,nz+1) > e(i,j,K+1)) then + ! Scale the transport with the fraction of the donor layer above + ! the bottom on the receiving side. + Sfn_unlim_u(I,K) = Sfn_unlim_u(I,K) * ((e(i,j,K) - e(i+1,j,nz+1)) / & + ((e(i,j,K) - e(i,j,K+1)) + dz_neglect)) + endif + else + if (e(i+1,j,K) < e(i,j,nz+1)) then ; Sfn_unlim_u(I,K) = 0.0 + elseif (e(i,j,nz+1) > e(i+1,j,K+1)) then + Sfn_unlim_u(I,K) = Sfn_unlim_u(I,K) * ((e(i+1,j,K) - e(i,j,nz+1)) / & + ((e(i+1,j,K) - e(i+1,j,K+1)) + dz_neglect)) + endif + endif + endif + endif ! if (use_EOS) else ! if (k > nk_linear) dzN2_u(I,K) = N2_floor * dz_neglect @@ -1218,7 +1273,8 @@ 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 Sfn_unlim_v_3D, & + !$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, & @@ -1381,6 +1437,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) + if (CS%use_meso_sfn_ANN) then + Sfn_unlim_v(i,K) = Sfn_unlim_v(i,K) + Sfn_unlim_v_3D(i,J,k) + endif + ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. if (Sfn_unlim_v(i,K) > 0.0) then ! The flow below this interface is positive. @@ -1405,11 +1465,36 @@ 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) dzN2_v(i,K) = GV%g_prime(K) + + if (CS%use_meso_sfn_ANN) then + Sfn_unlim_v(i,K) = Sfn_unlim_v(i,K) + Sfn_unlim_v_3D(i,J,k) + + ! Avoid moving dense water upslope from below the level of + ! the bottom on the receiving side. + if (Sfn_unlim_v(i,K) > 0.0) then ! The flow below this interface is positive. + if (e(i,j,K) < e(i,j+1,nz+1)) then + Sfn_unlim_v(i,K) = 0.0 ! This is not vhtot, because it may compensate for + ! deeper flow in very unusual cases. + elseif (e(i,j+1,nz+1) > e(i,j,K+1)) then + ! Scale the transport with the fraction of the donor layer above + ! the bottom on the receiving side. + Sfn_unlim_v(i,K) = Sfn_unlim_v(i,K) * ((e(i,j,K) - e(i,j+1,nz+1)) / & + ((e(i,j,K) - e(i,j,K+1)) + dz_neglect)) + endif + else + if (e(i,j+1,K) < e(i,j,nz+1)) then ; Sfn_unlim_v(i,K) = 0.0 + elseif (e(i,j,nz+1) > e(i,j+1,K+1)) then + Sfn_unlim_v(i,K) = Sfn_unlim_v(i,K) * ((e(i,j+1,K) - e(i,j,nz+1)) / & + ((e(i,j+1,K) - e(i,j+1,K+1)) + dz_neglect)) + endif + endif + endif + endif ! if (use_EOS) else ! if (k > nk_linear) dzN2_v(i,K) = N2_floor * dz_neglect @@ -2205,6 +2290,12 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "THICKNESSDIFFUSE", CS%thickness_diffuse, & "If true, interface heights are diffused with a "//& "coefficient of KHTH.", default=.false.) + call get_param(param_file, mdl, "USE_THICKNESS_DIFFUSE_ANN", CS%use_meso_sfn_ANN, & + "If true, use the ANN to compute the mesoscale streamfunction "//& + "for thickness diffusivity.", default=.false.) + if (CS%use_meso_sfn_ANN) then + call meso_sfn_ANN_init(Time, G, GV, US, param_file, diag, CS%meso_sfn_ANN_CS) + endif call get_param(param_file, mdl, "KHTH", CS%Khth, & "The background horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) @@ -2386,6 +2477,8 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "The minimum total depth over which to average the diffusivity used for MEKE. "//& "When the total depth is less than this, the diffusivity is scaled away.", & units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%Use_KH_in_MEKE) + else + CS%Use_KH_in_MEKE = .false. endif call get_param(param_file, mdl, "USE_GME", CS%use_GME_thickness_diffuse, & diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 47e01fd50d..473a1eaf63 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -12,7 +12,7 @@ module MOM_tidal_forcing use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : field_exists, file_exists, MOM_read_data -use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) +use MOM_time_manager, only : set_date, time_type, time_minus_signed use MOM_unit_scaling, only : unit_scale_type implicit none ; private @@ -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 @@ -268,7 +268,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, 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, "") @@ -633,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) @@ -707,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 aef40d86b1..eb3062769d 100644 --- a/src/parameterizations/lateral/MOM_wave_drag.F90 +++ b/src/parameterizations/lateral/MOM_wave_drag.F90 @@ -25,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 @@ -42,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 @@ -57,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", & @@ -69,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, & @@ -81,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)) @@ -105,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 @@ -134,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 0f6e896c26..4234cb66df 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -56,7 +56,7 @@ 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. integer :: answer_date !< The vintage of the order of arithmetic in the stochastics !! calculations. Values below 20250701 recover the answers from @@ -134,7 +134,7 @@ subroutine stochastics_init(dt, grid, GV, US, 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, & diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index c0cfb3b45c..0d3a148458 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -24,7 +24,8 @@ module MOM_ALE_sponge use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer -use MOM_interpolate, only : init_external_field, get_external_field_info, time_interp_external_init +use MOM_interpolate, only : init_external_field, time_interp_external_init +use MOM_interpolate, only : get_external_field_info use MOM_interpolate, only : external_field use MOM_io, only : axis_info use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping @@ -144,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 @@ -190,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 @@ -673,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 diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 759c470d39..98fc8b5656 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -87,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 c46efb8a45..0c3ecaee3f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -183,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 @@ -203,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 d4d9f031d9..bd6dd287bd 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -268,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 d9fcbe081a..5b41cef038 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -337,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] @@ -485,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 b9fc8eb70a..16fbc24b1f 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -280,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]. @@ -775,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 @@ -1120,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] @@ -2642,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 @@ -2656,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) @@ -3328,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 bcde4feb34..3540b95421 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -12,7 +12,7 @@ module MOM_diabatic_aux use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density_derivs -use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, extractFluxes1d, forcing_SinglePointPrint @@ -72,16 +72,22 @@ module MOM_diabatic_aux logical :: chl_from_file !< If true, chl_a is read from a file. logical :: do_brine_plume !< If true, insert salt flux below the surface according to !! a parameterization by \cite Nguyen2009. + logical :: check_salt_bp !< A logical to check for salt conservation in the brine plume scheme + !TODO: Delete DEBUG lines after brine plume is proven to be conservative to numerical precision. + !DEBUG logical :: check_salt_verbose !< A logical to be verbose when checking salt conservation integer :: brine_plume_n !< The exponent in the brine plume parameterization. real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed !! layer [nondim]. + real :: plume_mld_fac !< Proportionality factor between the mixed/mixing layer depth and the + !! vertical scale used for the brine plume parameterization [nondim]. + real :: check_salt_threshold!< The maximum relative salt change acceptable in a time step [nondim] type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output ! Diagnostic handles integer :: id_createdH = -1 !< Diagnostic ID of mass added to avoid grounding - integer :: id_brine_lay = -1 !< Diagnostic ID of which layer receives the brine + integer :: id_brine_input = -1 !< Diagnostic ID of which layer receives the brine salt flux integer :: id_penSW_diag = -1 !< Diagnostic ID of Penetrative shortwave heating (flux convergence) integer :: id_penSWflux_diag = -1 !< Diagnostic ID of Penetrative shortwave flux integer :: id_nonpenSW_diag = -1 !< Diagnostic ID of Non-penetrative shortwave heating @@ -90,6 +96,8 @@ module MOM_diabatic_aux ! Optional diagnostic arrays real, allocatable, dimension(:,:) :: createdH !< The amount of volume added in order to !! avoid grounding [H T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: brine_input !< Brine input diagnostic indicating + !! the resulting salt tendency [S T-1 ~> ppt s-1] real, allocatable, dimension(:,:,:) :: penSW_diag !< Heating in a layer from convergence of !! penetrative SW [Q R Z T-1 ~> W m-2] real, allocatable, dimension(:,:,:) :: penSWflux_diag !< Penetrative SW flux at base of grid @@ -756,9 +764,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t netheat_rate, & ! netheat but for dt=1 [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - netMassInOut_rate, & ! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] - mixing_depth, & ! The mixing depth for brine plumes [H ~> m or kg m-2] - total_h ! Total thickness of the water column [H ~> m or kg m-2] + netMassInOut_rate! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] ! dz, & ! Layer thicknesses in depth units [Z ~> m] @@ -791,19 +797,30 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! and rejected brine are initially applied in vanishingly thin layers at the ! top of the layer before being mixed throughout the layer. logical :: calculate_buoyancy ! If true, calculate the surface buoyancy flux. - real :: dK(SZI_(G)) ! Depth of the layer center in thickness units [H ~> m or kg m-2] - real :: A_brine(SZI_(G)) ! Constant [H-(n+1) ~> m-(n+1) or m(2n+2) kg-(n+1)]. - real :: fraction_left_brine ! Fraction of the brine that has not been applied yet [nondim] - real :: plume_fraction ! Fraction of the brine that is applied to a layer [nondim] - real :: plume_flux ! Brine flux to move downwards [S H ~> ppt m or ppt kg m-2] + real :: A_brine ! Constant [H-(n+1) ~> m-(n+1) or m(2n+2) kg-(n+1)]. + real :: plume_flux ! Brine flux to move downwards [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + real :: mixing_depth! The mixing depth for brine plumes [H ~> m or kg m-2] + real :: total_h ! Total thickness of the water column [H ~> m or kg m-2] + real :: plume_source! The rate of salt removal by the brine plume scheme + ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + real :: salt_added, salt_removed ! Trackers to keep stock of salt being moved by brine flux + ! [S H ~> ppt m or ppt kg m-2] + real :: salt_before, salt_after ! Helpers to keep stock of salt before and after the brine plume scheme + ! [S H ~> ppt m or ppt kg m-2] + real :: top, bottom ! The thickness (positive) of the top and bottom of the cell [H ~> m or kg m-2] + real :: np1, inp1 ! Brine plume exponent plus 1 and its inverse for integrals [nondim] + real :: top_np1, bottom_np1 ! top/bottom raised to power np1 [H^(n+1) ~> m^(n+1) or (kg m-2)^(n+1)] + integer :: nz_finite! the index of the last (deepest) finite thickness layer integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, is, ie, js, je, k, nz, nb + integer :: i, j, is, ie, js, je, k, nz, nb, ne character(len=45) :: mesg + character(len=80), dimension(10) :: salt_error_mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 1.0 / dt - plume_flux = 0.0 + inp1 = 1./(CS%brine_plume_n+1) + np1 = CS%brine_plume_n+1 calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) @@ -825,7 +842,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (CS%do_brine_plume .and. .not.present(MLD_h)) then call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& - "Brine plume parameterization requires a mixed-layer depth argument,\n"//& + "Brine plume parameterization requires a mixed-layer depth argument, "//& "currently coming from the energetic PBL scheme.") endif if (CS%do_brine_plume .and. .not.associated(MLD_h)) then @@ -834,7 +851,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t endif if (CS%do_brine_plume .and. .not. associated(fluxes%salt_left_behind)) then call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& - "Brine plume parameterization requires DO_BRINE_PLUME\n"//& + "Brine plume parameterization requires DO_BRINE_PLUME "//& "to be turned on in SIS2 as well as MOM6.") endif @@ -855,7 +872,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP minimum_forcing_depth,evap_CFL_limit,dt,EOSdom, & !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho,& !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2, & - !$OMP EnthalpyConst,MLD_h) & + !$OMP EnthalpyConst,MLD_h,np1,inp1) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & !$OMP IforcingDepthScale,g_conv,dSpV_dT,dSpV_dS, & @@ -864,9 +881,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & - !$OMP mixing_depth,A_brine,fraction_left_brine, & - !$OMP plume_fraction,dK,total_h) & - !$OMP firstprivate(SurfPressure,plume_flux) + !$OMP A_brine,plume_flux,mixing_depth,total_h, & + !$OMP plume_source,salt_added, salt_removed,salt_before,& + !$OMP salt_after,top,bottom,nz_finite,bottom_np1, & + !$OMP top_np1,salt_error_mesg,ne) & + !$OMP firstprivate(SurfPressure) do j=js,je ! Work in vertical slices for efficiency @@ -982,6 +1001,13 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t fluxes%netMassOut(i,j) = 0.0 fluxes%netMassIn(i,j) = 0.0 endif + if (CS%do_brine_plume .and. associated(fluxes%salt_left_behind)) then + if (fluxes%salt_left_behind(i,j) > 0.0) then + !Don't add in the salt that will later be distributed by the brine plume scheme + netSalt(i) = netSalt(i) - dt*((1000.0*US%ppt_to_S) * & + (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H + endif + endif enddo ! Apply the surface boundary fluxes in three steps: @@ -989,16 +1015,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! ocean (and corresponding outward heat content), and ignoring penetrative SW. ! B/ update mass, salt, temp from mass leaving ocean. ! C/ update temp due to penetrative SW - if (CS%do_brine_plume) then - ! Find the plume mixing depth. - do i=is,ie ; total_h(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; total_h(i) = total_h(i) + h(i,j,k) ; enddo ; enddo - do i=is,ie - mixing_depth(i) = min( max(MLD_h(i,j) - minimum_forcing_depth, minimum_forcing_depth), & - max(total_h(i), GV%angstrom_h) ) + GV%H_subroundoff - A_brine(i) = (CS%brine_plume_n + 1) / (mixing_depth(i) ** (CS%brine_plume_n + 1)) - enddo - endif do i=is,ie if (G%mask2dT(i,j) > 0.) then @@ -1075,7 +1091,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t enddo ! k=1,1 ! B/ Update mass, salt, temp from mass leaving ocean and other fluxes of heat and salt. - fraction_left_brine = 1.0 do k=1,nz ! Place forcing into this layer if this layer has nontrivial thickness. ! For layers thin relative to 1/IforcingDepthScale, then distribute @@ -1091,32 +1106,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t fractionOfForcing = -evap_CFL_limit*h2d(i,k)/netMassOut(i) endif - if (CS%do_brine_plume .and. associated(fluxes%salt_left_behind)) then - if (fluxes%salt_left_behind(i,j) > 0 .and. fraction_left_brine > 0.0) then - ! Place forcing into this layer by depth for brine plume parameterization. - if (k == 1) then - dK(i) = 0.5 * h(i,j,k) ! Depth of center of layer K - plume_flux = - (1000.0*US%ppt_to_S * (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H - plume_fraction = 1.0 - else - dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) ! Depth of center of layer K - plume_flux = 0.0 - endif - if (dK(i) <= mixing_depth(i) .and. fraction_left_brine > 0.0) then - plume_fraction = min(fraction_left_brine, (A_brine(i) * dK(i)**CS%brine_plume_n) * h(i,j,k)) - else - IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) - ! plume_fraction = fraction_left_brine, unless h2d is less than IforcingDepthScale. - plume_fraction = min(fraction_left_brine, h2d(i,k)*IforcingDepthScale) - endif - fraction_left_brine = fraction_left_brine - plume_fraction - plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * (CS%plume_strength * & - fluxes%salt_left_behind(i,j))) * GV%RZ_to_H - else - plume_flux = 0.0 - endif - endif - ! Change in state due to forcing dThickness = max( fractionOfForcing*netMassOut(i), -h2d(i,k) ) @@ -1161,9 +1150,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t endif Ithickness = 1.0/h2d(i,k) ! Inverse of new thickness T2d(i,k) = (hOld*T2d(i,k) + dTemp)*Ithickness - tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt + plume_flux)*Ithickness + tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt)*Ithickness elseif (h2d(i,k) < 0.0) then ! h2d==0 is a special limit that needs no extra handling call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (h<0)') + !TODO: remove write statements write(0,*) 'applyBoundaryFluxesInOut(): lon,lat=',G%geoLonT(i,j),G%geoLatT(i,j) write(0,*) 'applyBoundaryFluxesInOut(): netT,netS,netH=', & US%C_to_degC*netHeat(i), US%S_to_ppt*netSalt(i), netMassInOut(i) @@ -1176,11 +1166,131 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t enddo ! k + if (CS%do_brine_plume .and. associated(fluxes%salt_left_behind)) then + if (fluxes%salt_left_behind(i,j) > 0.0) then + + ! Find the plume mixing depth. + total_h = 0.0 + do k=1,nz + total_h = total_h + h2d(i,k) + if (h2d(i,k)>GV%h_subroundoff) nz_finite = k + enddo + mixing_depth = min( max(CS%plume_mld_fac * MLD_h(i,j), minimum_forcing_depth), & + max(total_h, GV%angstrom_h) ) + + ! Sets the brine plume coefficient based on integral constraint + A_brine = (CS%brine_plume_n + 1) / (mixing_depth**(CS%brine_plume_n + 1)) + + if (CS%check_salt_bp) then + ! Record the total salt in the column before applying the plume scheme + salt_before = 0.0 + do k=1,nz + salt_before = salt_before + h2d(i,k)*tv%S(i,j,k) + enddo + !DEBUG if (CS%check_salt_verbose) call MOM_error(NOTE,'Salt before brine plume: ',salt_before) + endif + + ! Set the plume strength based on the salt rejected + plume_source = ((1000.0*US%ppt_to_S) * (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H + ! Note salt removed + salt_removed = plume_source*dt + ! Track salt added + salt_added = 0.0 + + ! Add salt back to any level (starting at top) + bottom = 0.0 + bottom_np1 = 0.0 + do k=1,nz ; if (salt_removed > salt_added) then + top = bottom + bottom = top+h2d(i,k) + + if (bottom <= mixing_depth .and. kGV%H_subroundoff) then + ! if the bottom of the cell is > MLD or we are in the last + ! finite thickness cell, we put all the remaining salt in the level + plume_flux = salt_removed-salt_added + endif + + ! Update salinity + Ithickness = 1.0/h2d(i,k) + tv%S(i,j,k) = tv%S(i,j,k) + plume_flux*Ithickness + + ! Track salt added + salt_added = salt_added + plume_flux + !DEBUG if (CS%check_salt_verbose) then + !DEBUG write(mesg, '(A, I0, A, ES24.16, A, ES24.16)') & + !DEBUG 'Salt to layer ', k, ' and remaining deficit: ', salt_added, ', ', salt_removed-salt_added + !DEBUG call MOM_error(NOTE,trim(mesg)) + !DEBUG endif + + if (CS%id_brine_input > 0.) then + CS%brine_input(i,j,k) = plume_flux*Idt + endif + + endif ; enddo + + if (CS%check_salt_bp) then + salt_after = 0.0 + do k=1,nz + salt_after = salt_after + h2d(i,k)*tv%S(i,j,k) + enddo + if (abs((salt_after-salt_before-salt_removed)/salt_after)>CS%check_salt_threshold) then + write(salt_error_mesg(1), '(A, ES24.16)') & + 'Net plume strength: ', fluxes%salt_left_behind(i,j) + write(salt_error_mesg(2), '(A, 2ES24.16)') & + ' H/Plume dpt (h-unit): ', total_h, mixing_depth + write(salt_error_mesg(3), '(A, 2ES24.16)') & + ' H/Plume dpt (m): ', total_h*GV%H_to_Z, mixing_depth*GV%H_to_Z + write(salt_error_mesg(4), '(A, 2ES24.16)') & + ' Salt before/after BP: ', salt_before, salt_after + write(salt_error_mesg(5), '(A, 2ES24.16)') & + ' Salt change, abs/rel: ', salt_after-salt_before, (salt_after-salt_before)/salt_after + write(salt_error_mesg(6), '(A, 2ES24.16)') & + ' Salt removed, abs/rel:', salt_removed, salt_removed/salt_after + write(salt_error_mesg(7), '(A, 2ES24.16)') & + ' Salt added, abs/rel: ', salt_added, salt_added/salt_after + write(salt_error_mesg(8), '(A, ES24.16)') & + ' Scheme relative error:', (salt_added-salt_removed)/salt_after + write(salt_error_mesg(9), '(A, ES24.16)') & + ' Diagnosed salt error: ', (salt_after-salt_before-salt_removed)/salt_after + write(salt_error_mesg(10),'(A, ES24.16)') & + ' Allowed error: ', CS%check_salt_threshold + + !DEBUG write(0,*),'h',h2d(i,:) + !DEBUG write(0,*),'z',h2d(i,:)*GV%H_to_Z + !DEBUG write(0,*),'S',tv%S(i,j,:) + + ! Ideally this would be written to a single fatal error call, + ! but the long message seems to hit an FMS character limit? + call MOM_error(WARNING,'Salt change in brine plume scheme exceeds CHECK_SALT_BRINE_PLUME_THRESHOLD ') + do ne=1,10 + call MOM_error(WARNING,salt_error_mesg(ne),all_print=.true.) + enddo + call MOM_error(FATAL,'Salt conservation failed check in brine plume parameterization') + !call MOM_error(FATAL,'Salt conservation failed check in brine plume parameterization'//& + ! NEW_LINE('a')//salt_error_mesg(1)//NEW_LINE('a')//salt_error_mesg(2)//& + ! NEW_LINE('a')//salt_error_mesg(3)//NEW_LINE('a')//salt_error_mesg(4)//& + ! NEW_LINE('a')//salt_error_mesg(5)//NEW_LINE('a')//salt_error_mesg(6)//& + ! NEW_LINE('a')//salt_error_mesg(7)//NEW_LINE('a')//salt_error_mesg(8)//& + ! NEW_LINE('a')//salt_error_mesg(9)//NEW_LINE('a')//salt_error_mesg(10)) + endif + endif + + endif ! Salt was rejected + + endif ! Do brine plume + ! Check if trying to apply fluxes over land points elseif ((abs(netHeat(i)) + abs(netSalt(i)) + abs(netMassIn(i)) + abs(netMassOut(i))) > 0.) then if (.not. CS%ignore_fluxes_over_land) then call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (land)') + !TODO: Remove write statements write(0,*) 'applyBoundaryFluxesInOut(): lon,lat=',G%geoLonT(i,j),G%geoLatT(i,j) write(0,*) 'applyBoundaryFluxesInOut(): netHeat,netSalt,netMassIn,netMassOut=',& US%C_to_degC*netHeat(i), US%S_to_ppt*netSalt(i), netMassIn(i), netMassOut(i) @@ -1324,6 +1434,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Post the diagnostics if (CS%id_createdH > 0) call post_data(CS%id_createdH , CS%createdH , CS%diag) + if (CS%id_brine_input > 0) call post_data(CS%id_brine_input , CS%brine_input , CS%diag) if (CS%id_penSW_diag > 0) call post_data(CS%id_penSW_diag , CS%penSW_diag , CS%diag) if (CS%id_penSWflux_diag > 0) call post_data(CS%id_penSWflux_diag, CS%penSWflux_diag, CS%diag) if (CS%id_nonpenSW_diag > 0) call post_data(CS%id_nonpenSW_diag , CS%nonpenSW_diag , CS%diag) @@ -1452,6 +1563,21 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori call get_param(param_file, mdl, "BRINE_PLUME_FRACTION", CS%plume_strength, & "Fraction of the available brine to mix down using the brine plume parameterization.", & units="nondim", default=1.0, do_not_log=.not.CS%do_brine_plume) + call get_param(param_file, mdl, "BRINE_PLUME_MLD_FAC", CS%plume_mld_fac, & + "Proportionality factor between plume scale and MLD used in brine plume parameteterization.", & + units="nondim", default=1.0, do_not_log=.not.CS%do_brine_plume) + if (CS%plume_mld_fac<0.0) call MOM_error(FATAL,"BRINE_PLUME_MLD_FAC shouldn't be negative!") + call get_param(param_file, mdl, "CHECK_SALT_BRINE_PLUME", CS%check_salt_bp, & + "If true, check for conservation in the brine plume scheme.", default=.false., debuggingParam=.true.) + if (CS%check_salt_bp) then + call get_param(param_file, mdl, "CHECK_SALT_BRINE_PLUME_THRESHOLD", CS%check_salt_threshold, & + "Maximum allowed relative salt change in brine plume scheme.", & + units="nondim", default=1.0e-14, debuggingParam=.true.) + !DEBUG call get_param(param_file, mdl, "CHECK_SALT_BRINE_PLUME_VERBOSE", CS%check_salt_verbose, & + !DEBUG "Add output tracking salt conservation with brine plume scheme enabled.", default=.false., & + !DEBUG debuggingParam=.true.) + endif + if (useALEalgorithm) then CS%id_createdH = register_diag_field('ocean_model',"created_H",diag%axesT1, & @@ -1459,6 +1585,12 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori "m s-1", conversion=GV%H_to_m*US%s_to_T) if (CS%id_createdH>0) allocate(CS%createdH(isd:ied,jsd:jed)) + CS%id_brine_input = register_diag_field('ocean_model', 'Brine_Salt_Increment', & + diag%axesTL, Time, 'Salt rate of change due to brine plume','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_brine_input>0) allocate(CS%brine_input(isd:ied,jsd:jed,nz), source=0.0) + + ! diagnostic for heating of a grid cell from convergence of SW heat into the cell CS%id_penSW_diag = register_diag_field('ocean_model', 'rsdoabsorb', & diag%axesTL, Time, 'Convergence of Penetrative Shortwave Flux in Sea Water Layer',& diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index af1fa1a637..55179734d4 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -187,6 +187,9 @@ module MOM_diabatic_driver !! MLD calculation [Z ~> m]. logical :: Use_KdWork_diag = .false. !< Logical flag to indicate if any Kd_work diagnostics are on. logical :: Use_N2_diag = .false. !< Logical flag to indicate if any N2 diagnostics are on. + logical :: MLD_param_003 = .false. !< Logical flag if MLD in brine plume should use the 0.03 mixed layer depth + logical :: MLD_param_EN1 = .false. !< Logical flag if MLD in brine plume should use the EN1 mixed layer depth + logical :: MLD_param_ePBL = .false.!< Logical flag if MLD in brine plume should use the ePBL boundary layer depth ! MARBL needs T & S from before the tracer_vertdiff call real, allocatable, dimension(:,:,:) :: prediabatic_T !< Temperature prior to calling diabatic driver [C ~> degC] @@ -315,7 +318,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] @@ -376,7 +379,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) @@ -463,10 +466,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 @@ -498,10 +501,18 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & ! Diagnose mixed layer depths. call enable_averages(dt, Time_end, CS%diag) - if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & - CS%ref_h_mld, CS%id_MLD_003_zr, CS%id_MLD_003_rr, & - id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) + if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0 .or. CS%MLD_param_003 ) then + if (CS%MLD_param_003) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & + CS%ref_h_mld, CS%id_MLD_003_zr, CS%id_MLD_003_rr, & + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2, & + MLD_out=visc%MLD_param) + call convert_MLD_to_ML_thickness(visc%MLD_param, h, visc%h_ML_param, tv, G, GV) + else + call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & + CS%ref_h_mld, CS%id_MLD_003_zr, CS%id_MLD_003_rr, & + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) + endif endif if (CS%id_MLD_0125 > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag, & @@ -511,10 +522,16 @@ subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag, & ref_H_MLD=0.0, id_ref_z=-1, id_ref_rho=-1) endif - if ((CS%id_MLD_EN1 > 0) .or. (CS%id_MLD_EN2 > 0) .or. (CS%id_MLD_EN3 > 0)) then + if ((CS%id_MLD_EN1 > 0) .or. (CS%id_MLD_EN2 > 0) .or. (CS%id_MLD_EN3 > 0) .or. (CS%MLD_param_EN1)) then ! 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) + if (CS%MLD_param_EN1) then + 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,MLD_out=visc%MLD_param) + call convert_MLD_to_ML_thickness(visc%MLD_param, h, visc%h_ML_param, tv, G, GV) + else + 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 endif if ((CS%id_BMLD_EN1 > 0) .or. (CS%id_BMLD_EN2 > 0) .or. (CS%id_BMLD_EN3 > 0)) then ! Bottom Mixed Layer diagnostic @@ -601,7 +618,6 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim 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] @@ -913,7 +929,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML_param) if (CS%debug) then call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, unscale=GV%H_to_mks) @@ -939,6 +955,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim ! If visc%MLD or visc%h_ML exist, copy ePBL's BLD into them with appropriate conversions. if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (CS%MLD_param_ePBL) visc%h_ML_param = visc%h_ML if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) ! Find the vertical distances across layers, which may have been modified by the net surface flux @@ -973,7 +990,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD_h=visc%h_ML) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD_h=visc%h_ML_param) ! Find the vertical distances across layers, which may have been modified by the net surface flux call thickness_to_dz(h, tv, dz, G, GV, US) @@ -1341,7 +1358,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] @@ -1593,7 +1609,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML_param) if (CS%debug) then call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) @@ -1614,6 +1630,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, ! If visc%MLD or visc%h_ML exist, copy ePBL's BLD into them with appropriate conversions. if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (CS%MLD_param_ePBL) visc%h_ML_param = visc%h_ML if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. @@ -1639,7 +1656,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD_h=visc%h_ML) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD_h=visc%h_ML_param) endif ! endif for CS%use_energetic_PBL @@ -3292,10 +3309,9 @@ 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 + character(len=20) :: brine_plume_mld_def + logical :: physical_OBL_scheme, do_brine_plume + 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 @@ -3309,7 +3325,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call extract_tracer_flow_member(tracer_flow_CSp, use_MARBL_tracers=use_MARBL_tracers) if (use_MARBL_tracers) & allocate(CS%prediabatic_T(SZI_(G),SZJ_(G), SZK_(G)), CS%prediabatic_S(SZI_(G),SZJ_(G), SZK_(G))) - end if + endif if (associated(sponge_CSp)) CS%sponge_CSp => sponge_CSp if (associated(ALE_sponge_CSp)) CS%ALE_sponge_CSp => ALE_sponge_CSp if (associated(oda_incupd_CSp)) CS%oda_incupd_CSp => oda_incupd_CSp @@ -3440,6 +3456,28 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "mass loss is passed down through the column.", & units="nondim", default=0.8) + call get_param(param_file, mdl, "DO_BRINE_PLUME", do_brine_plume, & + "If true, enables a brine plume parameterizations (not logged here)", & + do_not_log=.true.,default=.false.) + if (do_brine_plume) then + call get_param(param_file, mdl, "BRINE_PLUME_MLD_DEF", brine_plume_mld_def, & + "A string that determines which mixed/mixing depth is used in setting "//& + "the brine plume depth, \n Valid options are MLD_003, MLD_EN1, and H_ePBL",& + default='MLD_EN1') + select case (trim(brine_plume_mld_def)) + case ('MLD_003') + CS%MLD_param_003 = .true. + case ('MLD_EN1') + CS%MLD_param_EN1 = .true. + case ('H_ePBL') + CS%MLD_param_ePBL = .true. + case default + call MOM_error(FATAL,"Invalid choice for BRINE_PLUME_MLD_DEF. Valid options are"//& + "MLD_003, MLD_EN1, or H_ePBL.") + end select + + endif + if (CS%use_energetic_PBL .and. .not.CS%useALEalgorithm) & call MOM_error(FATAL, "diabatic_driver_init: "//& "ENERGETICS_SFC_PBL = True is only coded to work when USE_REGRIDDING = True.") diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index b7f3a3462b..6930007bd1 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -9,6 +9,7 @@ module MOM_energetic_PBL 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 @@ -263,6 +264,7 @@ 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 @@ -460,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] @@ -479,8 +481,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, diag_mstar_LT, & ! mstar due to Langmuir turbulence [nondim] diag_LA, & ! Langmuir number [nondim] diag_LA_mod, & ! Modified Langmuir number [nondim] - diag_ustar, & ! The surface boundary layer friction velocity [Z T-1 ~> m s-1] - diag_bflx ! The surface boundary layer buoyancy flux [Z2 T-3 ~> m2 s-3] + 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) :: & @@ -693,6 +694,8 @@ 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 @@ -828,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, & @@ -1030,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 @@ -2070,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. @@ -2100,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]. @@ -2158,7 +2161,6 @@ 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] @@ -2779,8 +2781,7 @@ subroutine kappa_eqdisc(shape_func, CS, GV, dz, absf, B_flux, u_star, MLD_guess) ! variables used for optimizing computations: real :: sm_h ! sigma_max multiplied by boundary layer depth [Z ~> m] - real :: sm_h_I ! inverse of sm_h,[Z-1 ~> m-1] - real :: sm_h_I2 ! An inverse variable given by 1.0/(h - sm_h), [Z-1 ~> m-1] + real :: 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] @@ -2796,7 +2797,7 @@ subroutine kappa_eqdisc(shape_func, CS, GV, dz, absf, B_flux, u_star, MLD_guess) hz(1) = 0.0 do K=2,nz hz(K) = hz(K-1) + dz(K-1) - end do + enddo hbl = MLD_Guess ! hbl is boundary layer depth. u_star_I = 1.0/u_star @@ -2865,7 +2866,7 @@ subroutine kappa_eqdisc(shape_func, CS, GV, dz, absf, B_flux, u_star, MLD_guess) elseif (hz(n) > hbl) then shape_func(n) = CS%shape_function_epsilon ! set an arbitrary low constant value below hbl, default 0.01 endif - end do + enddo end subroutine kappa_eqdisc !> Gives velocity scale (v_0) using equations that approximate neural network of Sane et al. 2023 @@ -4336,6 +4337,8 @@ 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') diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 7746ed84dc..93c429198d 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -372,7 +372,8 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, BFlx_geothermal, halo) real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(geothermal_CS), intent(in) :: CS !< Geothermal heating control struct - real, dimension(SZI_(G), SZJ_(G)), intent(out) :: BFlx_geothermal !< Geothermal Buoyancy Flux [m2 s-3] + 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 @@ -398,7 +399,7 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, BFlx_geothermal, halo) real :: Idt ! inverse of the timestep [T-1 ~> s-1] real :: H_to_Pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real :: I_Cp ! 1.0 / C_p [C Q-1 ~> kg degC J-1] - real :: I_Rho0Squared ! 1.0 / rho_0^2 (Boussinesq only) [ R-2 ~> kg2 m-6] + 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. @@ -442,7 +443,7 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, BFlx_geothermal, halo) 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 + enddo ; enddo if (nonBous) then dSpVdT(:) = 0.0 dSpVdS(:) = 0.0 diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index a03dca73a8..f8ed9f111c 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -553,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 b2e112cb36..0dbd34c88c 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -185,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] @@ -213,7 +213,7 @@ 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) @@ -1009,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 @@ -2214,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 6728bf820c..02c9958e6e 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -392,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 @@ -415,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 @@ -460,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 @@ -470,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 diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index da1667a77b..a8dd0cb1e6 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -574,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 c6124e0c9a..971e5f6226 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -231,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 @@ -309,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] @@ -536,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 @@ -554,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 @@ -650,19 +648,19 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i 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 @@ -700,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 @@ -890,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 @@ -1384,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 @@ -1807,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]. @@ -2624,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.) @@ -2669,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 2bfada3bf1..0115e9aa69 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -77,6 +77,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. @@ -89,6 +91,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. @@ -105,12 +113,20 @@ 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 - !! viscosity calculations. Values below 20190101 recover the answers - !! from the end of 2018, while higher values use updated and more robust - !! forms of the same expressions. + integer :: answer_date !< The vintage of the order of arithmetic and expressions + !! in the set viscosity calculations. Values below + !! 20190101 recover the answers from the end of 2018, + !! while higher values use updated and more robust forms + !! of the same expressions. Values below 20260704 use + !! the non-reproducible power operator in place of + !! cuberoot() when finding the open distances with + !! CHANNEL_DRAG. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: BBL_use_tidal_bg !< If true, use a tidal background amplitude for the bottom velocity !! when computing the bottom stress. @@ -119,7 +135,9 @@ module MOM_set_visc type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. ! Allocatable data arrays - real, allocatable, dimension(:,:) :: tideamp !< RMS tidal amplitude at h points [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: cdrag_u !< The spatially varying quadratic drag coefficient [nondim] + real, allocatable, dimension(:,:) :: cdrag_v !< The spatially varying quadratic drag coefficient [nondim] + real, allocatable, dimension(:,:) :: tideamp !< RMS tidal amplitude at h points [L T-1 ~> m s-1] ! Diagnostic arrays real, allocatable, dimension(:,:) :: bbl_u !< BBL mean U current [L T-1 ~> m s-1] real, allocatable, dimension(:,:) :: bbl_v !< BBL mean V current [L T-1 ~> m s-1] @@ -209,6 +227,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]. @@ -244,7 +263,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]. @@ -257,8 +276,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually set to 2e7 Pa = 2000 dbar). - real :: D_vel ! The bottom depth at a velocity point [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 @@ -303,6 +325,7 @@ 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)) @@ -318,6 +341,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.") @@ -342,11 +366,13 @@ 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) @@ -368,23 +394,23 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) !$OMP parallel do default(shared) do J=js-1,je ; do i=is-1,ie+1 - D_v(i,J) = 0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) + G%Z_ref + D_v(i,J) = 0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) mask_v(i,J) = G%mask2dCv(i,J) enddo ; enddo !$OMP parallel do default(shared) do j=js-1,je+1 ; do I=is-1,ie - D_u(I,j) = 0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) + G%Z_ref + D_u(I,j) = 0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) mask_u(I,j) = G%mask2dCu(I,j) enddo ; enddo - if (associated(OBC)) then + if (associated(OBC) .and. CS%Channel_drag) then ! Use a one-sided projection of bottom depths at OBC points. if (OBC%v_N_OBCs_on_PE) then Js_OBC = max(js-1, OBC%Js_v_N_obc) ; Je_OBC = min(je, OBC%Je_v_N_obc) is_OBC = max(is-1, OBC%is_v_N_obc) ; ie_OBC = min(ie+1, OBC%ie_v_N_obc) !$OMP parallel do default(shared) do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC - if (OBC%segnum_v(i,J) > 0) D_v(i,J) = G%bathyT(i,j) + G%Z_ref ! OBC_DIRECTION_N + if (OBC%segnum_v(i,J) > 0) D_v(i,J) = G%bathyT(i,j) ! OBC_DIRECTION_N enddo ; enddo endif if (OBC%v_S_OBCs_on_PE) then @@ -392,7 +418,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) is_OBC = max(is-1, OBC%is_v_S_obc) ; ie_OBC = min(ie+1, OBC%ie_v_S_obc) !$OMP parallel do default(shared) do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC - if (OBC%segnum_v(i,J) < 0) D_v(i,J) = G%bathyT(i,j+1) + G%Z_ref ! OBC_DIRECTION_S + if (OBC%segnum_v(i,J) < 0) D_v(i,J) = G%bathyT(i,j+1) ! OBC_DIRECTION_S enddo ; enddo endif if (OBC%u_E_OBCs_on_PE) then @@ -400,7 +426,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Is_OBC = max(is-1, OBC%Is_u_E_obc) ; Ie_OBC = min(ie, OBC%Ie_u_E_obc) !$OMP parallel do default(shared) do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC - if (OBC%segnum_u(I,j) > 0) D_u(I,j) = G%bathyT(i,j) + G%Z_ref ! OBC_DIRECTION_E + if (OBC%segnum_u(I,j) > 0) D_u(I,j) = G%bathyT(i,j) ! OBC_DIRECTION_E enddo ; enddo endif if (OBC%u_W_OBCs_on_PE) then @@ -408,12 +434,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Is_OBC = max(is-1, OBC%Is_u_W_obc) ; Ie_OBC = min(ie, OBC%Ie_u_W_obc) !$OMP parallel do default(shared) do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC - if (OBC%segnum_u(I,j) < 0) D_u(I,j) = G%bathyT(i+1,j) + G%Z_ref ! OBC_DIRECTION_W + if (OBC%segnum_u(I,j) < 0) D_u(I,j) = G%bathyT(i+1,j) ! OBC_DIRECTION_W enddo ; enddo endif endif - if (associated(OBC)) then ; do n=1,OBC%number_of_segments + if (associated(OBC) .and. CS%Channel_drag) then ; do n=1,OBC%number_of_segments ! Now project bottom depths across cell-corner points in the OBCs. The two ! projections have to occur in sequence and can not be combined easily. if (.not. OBC%segment(n)%on_pe) cycle @@ -610,10 +636,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! 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))+ & + u2_bg(I) = tideampfac2_x_0p5 * ( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) else - u2_bg(i) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + u2_bg(i) = tideampfac2_x_0p5 * ( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) endif ; endif ; enddo else @@ -631,6 +657,16 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) dztot_vel = 0.0 ; dzwtot = 0.0 Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0 + if (CS%bottomdragmap) then + if (m==1) then + cdrag_sqrt = sqrt(CS%cdrag_u(i,j)) + else + cdrag_sqrt = sqrt(CS%cdrag_v(i,j)) + endif + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H + endif + do k=nz,1,-1 if (htot_vel>=CS%Hbbl) exit ! terminate the k loop @@ -694,7 +730,17 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif ; enddo else - do i=is,ie ; ustar(i) = cdrag_sqrt_H*CS%drag_bg_vel ; enddo + do i=is,ie + if (CS%bottomdragmap) then + if (m==1) then + cdrag_sqrt = sqrt(CS%cdrag_u(i,j)) + else + cdrag_sqrt = sqrt(CS%cdrag_v(i,j)) + endif + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + endif + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + enddo endif ! Not linear_drag if (use_BBL_EOS) then @@ -725,6 +771,16 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) 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 @@ -884,19 +940,29 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) vol_below(K) = vol_below(K+1) + dz_vel(i,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) @@ -957,7 +1023,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. @@ -1733,11 +1799,11 @@ subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) L(K) = 1.0 elseif (vol_below(K) <= Vol_direct) then ! Both edges of the cell are bounded by walls. - ! if (CS%answer_date < 20240101)) then + if (CS%answer_date < 20260704) then L(K) = (-0.25*C24_crv*vol_below(K))**C1_3 - ! else - ! L(K) = cuberoot(-0.25*C24_crv*vol_below(K)) - ! endif + else + L(K) = cuberoot(-0.25*C24_crv*vol_below(K)) + endif else ! x_R is at 1/2 but x_L is in the interior & L is found by iteratively solving ! vol_below(K) = 0.5*L^2*(slope + crv/3*(3-4L)) @@ -1942,7 +2008,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. @@ -2332,7 +2398,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)) @@ -2611,7 +2677,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)) @@ -2818,6 +2884,10 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C use_neutral_diffusion .or. use_hor_bnd_diff .or. use_ideal_age) then call safe_alloc_ptr(visc%h_ML, isd, ied, jsd, jed) endif + if (do_brine_plume) then + call safe_alloc_ptr(visc%h_ML_param, isd, ied, jsd, jed) + call safe_alloc_ptr(visc%MLD_param, isd, ied, jsd, jed) + endif if (MLE_use_PBL_MLD .or. MLE_use_Bodner) then call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & @@ -2833,6 +2903,11 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C "Instantaneous active mixing layer thickness", & units=get_thickness_units(GV), conversion=GV%H_to_mks) endif + if (do_brine_plume) then + call register_restart_field(visc%h_ML_param, "h_ML_param", .false., restart_CS, & + "Instantaneous active mixed layer thickness", & + units=get_thickness_units(GV), conversion=GV%H_to_mks) + endif ! visc%sfc_buoy_flx is used to communicate the state of the (e)PBL or KPP to the rest of the model if (MLE_use_PBL_MLD .or. MLE_use_Bodner) then @@ -2912,8 +2987,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 @@ -2922,8 +3004,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. @@ -2946,10 +3028,16 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) call get_param(param_file, mdl, "SET_VISC_ANSWER_DATE", CS%answer_date, & - "The vintage of the order of arithmetic and expressions in the set viscosity "//& - "calculations. Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values use updated and more robust forms of the same expressions.", & - default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "The vintage of the order of arithmetic and expressions " // & + "in the set viscosity calculations. Values below " // & + "20190101 recover the answers from the end of 2018, " // & + "while higher values use updated and more robust forms " // & + "of the same expressions. Values below 20260704 use " // & + "the non-reproducible power operator in place of " // & + "cuberoot() when finding the open distances with " // & + "CHANNEL_DRAG.", & + default=min(20260703,default_answer_date), & + do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& @@ -2965,8 +3053,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.) @@ -3039,6 +3137,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. "//& @@ -3056,6 +3164,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 "//& @@ -3184,11 +3303,32 @@ 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) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, tideamp_var, CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(filename, tideamp_var, CS%tideamp, G%domain, scale=US%m_s_to_L_T) call pass_var(CS%tideamp,G%domain) endif endif diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index aa8361e2c7..f91eeac4f2 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -520,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 e596a9af2f..21c1c07c7c 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -509,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) @@ -715,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] @@ -1011,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] @@ -1490,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 9eba7e3471..1cee9e5417 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -24,7 +24,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 @@ -82,8 +82,6 @@ module MOM_vert_friction !! [H Z T ~> m2 s or kg s m-1] real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0 [L T-1 ~> m s-1]. - logical :: CFL_based_trunc !< If true, base truncations on CFL numbers, not - !! absolute velocities. real :: CFL_trunc !< Velocity components will be truncated when they !! are large enough that the corresponding CFL number !! exceeds this value [nondim]. @@ -250,10 +248,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.) @@ -615,7 +613,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & 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): "// & @@ -647,8 +645,7 @@ 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 @@ -674,7 +671,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & 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; enddo + enddo ; enddo ; enddo endif if (associated(ADp%du_dt_visc_gl90)) then @@ -1046,7 +1043,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (present(tauy_bot)) then do J=Jsq,Jeq ; do i=is,ie tauy_bot(i,J) = GV%H_to_RZ * (v(i,J,nz) * CS%a_v(i,J,nz+1)) - enddo; enddo + enddo ; enddo if (allocated(visc%Ray_v)) then do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie @@ -1369,7 +1366,7 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, logical :: do_any_shelf 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, ij + 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 @@ -2445,7 +2442,7 @@ subroutine find_coupling_coef(a_cpl, hvel, i, j, h_harm, bbl_thick, kv_bbl, z_i, 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. + ! 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. @@ -2550,6 +2547,7 @@ subroutine find_coupling_coef(a_cpl, hvel, i, j, h_harm, bbl_thick, kv_bbl, z_i, endif end subroutine find_coupling_coef + !> 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 @@ -2578,6 +2576,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS real :: u_old(SZIB_(G),SZJ_(G),SZK_(GV)) ! The previous u-velocity [L T-1 ~> m s-1] real :: v_old(SZI_(G),SZJB_(G),SZK_(GV)) ! The previous v-velocity [L T-1 ~> m s-1] logical :: trunc_any, dowrite(SZIB_(G),SZJB_(G)) + logical :: do_any_write integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -2585,45 +2584,55 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS H_report = 3.0 * GV%Angstrom_H if (len_trim(CS%u_trunc_file) > 0) then - !$OMP parallel do default(shared) private(trunc_any,CFL) - do j=js,je - trunc_any = .false. - do I=Isq,Ieq ; dowrite(I,j) = .false. ; enddo - 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 I=Isq,Ieq ; if (dowrite(I,j)) then - u_old(I,j,:) = u(I,j,:) - endif ; enddo - - if (trunc_any) 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 (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & - (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 - elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then - u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) - if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & - (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 - endif - enddo ; enddo + do j=js,je ; do I=Isq,Ieq + dowrite(I,j) = .false. + vel_report(I,j) = 3.0e8 * US%m_s_to_L_T + enddo ; enddo + + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) u(I,j,k) = 0.0 + if (u(I,j,k) < 0.0) then + CFL = (-u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + else + CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) endif - enddo ! j-loop + if (CFL > CS%CFL_trunc) trunc_any = .true. + if (CFL > CS%CFL_report) then + dowrite(I,j) = .true. + do_any_write = .true. + vel_report(I,j) = min(vel_report(I,j), abs(u(I,j,k))) + endif + enddo ; enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then + u_old(I,j,:) = u(I,j,:) + endif ; enddo ; enddo + + if (trunc_any) then + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo + endif + + if (do_any_write) then + do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then + ! Call a diagnostic reporting subroutines are called if unphysically large values are found. + call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + vel_report(I,j), forces%taux(I,j), a=CS%a_u, hv=CS%h_u) + endif ; enddo ; enddo + endif else ! Do not report accelerations leading to large velocities. - !$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 @@ -2638,54 +2647,57 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS enddo ; enddo ; enddo 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) + if (len_trim(CS%v_trunc_file) > 0) then + do_any_write =.false. + trunc_any = .false. + + + do J=Jsq,Jeq ; do i=is,ie + dowrite(i,J) = .false. + vel_report(i,J) = 3.0e8 * US%m_s_to_L_T + enddo ; enddo + + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) v(i,J,k) = 0.0 + if (v(i,J,k) < 0.0) then + CFL = (-v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + else + CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + endif + if (CFL > CS%CFL_trunc) trunc_any = .true. + if (CFL > CS%CFL_report) then + dowrite(i,J) = .true. + do_any_write = .true. + vel_report(i,J) = min(vel_report(i,J), abs(v(i,J,k))) + endif + enddo ; enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then + v_old(i,J,:) = v(i,J,:) endif ; enddo ; enddo - endif - if (len_trim(CS%v_trunc_file) > 0) then - !$OMP parallel do default(shared) private(trunc_any,CFL) - do J=Jsq,Jeq - trunc_any = .false. - do i=is,ie ; dowrite(i,J) = .false. ; enddo - 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))) + if (trunc_any) then + do k=1,nz ; do J=Jsq,Jeq ; 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 (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 endif - enddo ; enddo + enddo ; enddo ; enddo + endif - do i=is,ie ; if (dowrite(i,J)) then - v_old(i,J,:) = v(i,J,:) - endif ; enddo - - if (trunc_any) 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 (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & - (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 - elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then - v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) - if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & - (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 - endif - enddo ; enddo - endif - enddo ! J-loop + if (do_any_write) then + do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then + ! Call a diagnostic reporting subroutines are called if unphysically large values are found. + call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + vel_report(i,J), forces%tauy(i,J), a=CS%a_v, hv=CS%h_v) + endif ; enddo ; enddo + endif else ! Do not report accelerations leading to large velocities. - !$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 @@ -2700,16 +2712,9 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS enddo ; enddo ; enddo 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 - endif - end subroutine vertvisc_limit_vel + !> Initialize the vertical friction module subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ntrunc, CS, fpmix) @@ -2752,8 +2757,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%initialized = .true. - if (GV%Boussinesq) then; thickness_units = "m" - else; thickness_units = "kg m-2"; endif + if (GV%Boussinesq) then ; thickness_units = "m" + else ; thickness_units = "kg m-2" ; endif isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -3229,7 +3234,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 @@ -3241,8 +3246,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 diff --git a/src/tracer/MARBL_forcing_mod.F90 b/src/tracer/MARBL_forcing_mod.F90 index 1c80c5787f..d33cb72ab0 100644 --- a/src/tracer/MARBL_forcing_mod.F90 +++ b/src/tracer/MARBL_forcing_mod.F90 @@ -329,7 +329,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 a7bd64999e..29531f07ac 100644 --- a/src/tracer/MARBL_tracers.F90 +++ b/src/tracer/MARBL_tracers.F90 @@ -437,7 +437,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", & @@ -446,8 +446,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 @@ -996,17 +996,17 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag call MOM_error(NOTE, 'Enforcing consistency across autotroph tracer initial conditions') do j=G%jsc, G%jec ; do i=G%isc, G%iec ! Copy tracer data into flat array - do k=1,GV%ke; do m=1, CS%ntr + do k=1,GV%ke ; do m=1, CS%ntr MARBL_instances%tracers(m,k) = CS%tracer_data(m)%tr(i,j,k) - end do ; end do + enddo ; enddo ! call consistency enforcement call MARBL_instances%autotroph_tracer_consistency_enforce() ! Copy tracer data out of flat array - do k=1,GV%ke; do m=1, CS%ntr + do k=1,GV%ke ; do m=1, CS%ntr CS%tracer_data(m)%tr(i,j,k) = MARBL_instances%tracers(m,k) - end do ; end do - end do ; end do - end if + enddo ; enddo + enddo ; enddo + endif ! Initialize total chlorophyll to get SW Pen correct (if it wasn't initialized from restart file) if ((CS%total_Chl_ind > 0) .and. & @@ -1355,7 +1355,7 @@ subroutine MARBL_tracers_column_physics(h_old, ea, eb, fluxes, dt, G, GV, US, CS 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] diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index f8420b47a0..2ce801c63a 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -518,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 @@ -692,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) @@ -704,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) @@ -721,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_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 96cddfa4d1..40a2db5899 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -106,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 @@ -552,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) @@ -812,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 @@ -1023,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./) @@ -1034,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/) @@ -1045,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./) @@ -1057,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./) @@ -1069,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 bf28f2dbfc..78ad2bd7c8 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -191,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, & @@ -391,7 +391,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, visc, CS, p_surf) if (associated(visc%h_ML)) then CS%hbl(:,:) = visc%h_ML(:,:) else - call MOM_error(FATAL, "hor_bnd_diffusion requires that visc%h_ML is associated.") + call MOM_error(FATAL, "neutral_diffusion requires that visc%h_ML is associated.") endif call pass_var(CS%hbl, G%Domain, halo=1) @@ -401,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 @@ -695,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 @@ -1411,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 @@ -1697,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. @@ -2175,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 @@ -2889,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. @@ -2905,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, & @@ -2919,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, & @@ -2933,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, & @@ -2947,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, & @@ -2961,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, & @@ -2975,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, & @@ -2989,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, & @@ -3003,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, & @@ -3017,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, & @@ -3031,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, & @@ -3045,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, & @@ -3059,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, & diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 4ea3ee70cc..a1822fc6bc 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -621,7 +621,7 @@ end subroutine offline_add_diurnal_sw !! in a previous integration of the online model subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, snap_file, & surf_file, h_end, uhtr, vhtr, temp_mean, salt_mean, mld, Kd, fluxes, & - ridx_sum, ridx_snap, read_mld, read_sw, read_ts_uvh, do_ale_in) + ridx_sum, ridx_snap, read_mld, mld_var_name, read_sw, read_ts_uvh, do_ale_in) type(ocean_grid_type), intent(inout) :: G !< Horizontal grid type type(verticalGrid_type), intent(in ) :: GV !< Vertical grid type @@ -650,6 +650,8 @@ subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, s integer, intent(in ) :: ridx_sum !< Read index for sum, mean, and surf files integer, intent(in ) :: ridx_snap !< Read index for snapshot file logical, intent(in ) :: read_mld !< True if reading in MLD + character(len=*), intent(in ) :: mld_var_name !< Name of the mixed layer depth variable + !! to read from a file. logical, intent(in ) :: read_sw !< True if reading in radiative fluxes logical, intent(in ) :: read_ts_uvh !< True if reading in uh, vh, and h logical, optional, intent(in ) :: do_ale_in !< True if using ALE algorithms @@ -726,7 +728,7 @@ subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, s endif if (read_mld) then - call MOM_read_data(surf_file, 'ePBL_h_ML', mld, G%Domain, timelevel=ridx_sum, scale=US%m_to_Z) + call MOM_read_data(surf_file, mld_var_name, mld, G%Domain, timelevel=ridx_sum, scale=US%m_to_Z) endif if (read_sw) then diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index e97eb61373..a86a207ab7 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -102,6 +102,7 @@ module MOM_offline_main logical :: skip_diffusion !< Skips horizontal diffusion of tracers logical :: read_sw !< Read in averaged values for shortwave radiation logical :: read_mld !< Check to see whether mixed layer depths should be read in + real :: Hmix_fixed !< A fixed mixed layer depth to use when read_mld is false [Z ~> m] logical :: diurnal_sw !< Adds a synthetic diurnal cycle on shortwave radiation logical :: debug !< If true, write verbose debugging messages logical :: redistribute_barotropic !< Redistributes column-summed residual transports throughout @@ -129,10 +130,8 @@ module MOM_offline_main !! routine [H L2 ~> m3 or kg] !>@{ Diagnostic manager IDs for some fields that may be of interest when doing offline transport integer :: & - id_uhr = -1, & - id_vhr = -1, & - id_ear = -1, & - id_ebr = -1, & + id_uhr = -1, id_vhr = -1, & + ! Unused: id_ear = -1, id_ebr = -1, & id_hr = -1, & id_hdiff = -1, & id_uhr_redist = -1, & @@ -1051,8 +1050,9 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) ! Most fields will be read in from files call update_offline_from_files( G, GV, US, CS%nk_input, CS%mean_file, CS%sum_file, CS%snap_file, & CS%surf_file, CS%h_end, CS%uhtr, CS%vhtr, CS%tv%T, CS%tv%S, & - CS%mld, CS%Kd, fluxes, CS%ridx_sum, CS%ridx_snap, CS%read_mld, & - CS%read_sw, .not.CS%read_all_ts_uvh, do_ale) + CS%mld, CS%Kd, fluxes, CS%ridx_sum, CS%ridx_snap, & + CS%read_mld, CS%mld_var_name, CS%read_sw, & + .not.CS%read_all_ts_uvh, do_ale) ! If uh, vh, h_end, temp, salt were read in at the beginning, fields are copied from those arrays if (CS%read_all_ts_uvh) then call update_offline_from_arrays(G, GV, CS%nk_input, CS%ridx_sum, CS%mean_file, CS%sum_file, & @@ -1177,10 +1177,10 @@ subroutine register_diags_offline_transport(Time, diag, CS, GV, US) 'm', conversion=GV%H_to_m) CS%id_hr = register_diag_field('ocean_model', 'hr', diag%axesTL, Time, & 'Layer thickness at end of offline step', 'm', conversion=GV%H_to_m) - CS%id_ear = register_diag_field('ocean_model', 'ear', diag%axesTL, Time, & - 'Remaining thickness entrained from above', 'm') - CS%id_ebr = register_diag_field('ocean_model', 'ebr', diag%axesTL, Time, & - 'Remaining thickness entrained from below', 'm') + ! Unused: CS%id_ear = register_diag_field('ocean_model', 'ear', diag%axesTL, Time, & + ! 'Remaining thickness entrained from above', 'm') + ! Unused: CS%id_ebr = register_diag_field('ocean_model', 'ebr', diag%axesTL, Time, & + ! 'Remaining thickness entrained from below', 'm') CS%id_eta_pre_distribute = register_diag_field('ocean_model','eta_pre_distribute', & diag%axesT1, Time, 'Total water column height before residual transport redistribution', & 'm', conversion=GV%H_to_m) @@ -1413,6 +1413,15 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) "when in offline tracer mode", default=.false.) call get_param(param_file, mdl, "MLD_VAR_NAME", CS%mld_var_name, & "Name of the variable containing the depth of active mixing", default='ePBL_h_ML') + if (CS%read_mld) then + CS%Hmix_fixed = 0.0 + else + call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix_fixed, & + "The prescribed depth over which the near-surface viscosity and "//& + "diffusivity are elevated when the bulk mixed layer is not used.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) + endif + call get_param(param_file, mdl, "OFFLINE_ADD_DIURNAL_SW", CS%diurnal_sw, & "Adds a synthetic diurnal cycle in the same way that the ice "//& "model would have when time-averaged fields of shortwave "//& @@ -1477,7 +1486,7 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) allocate(CS%ebtr(isd:ied,jsd:jed,nz), source=0.0) allocate(CS%h_end(isd:ied,jsd:jed,nz), source=0.0) allocate(CS%Kd(isd:ied,jsd:jed,nz+1), source=0.0) - if (CS%read_mld) allocate(CS%mld(G%isd:G%ied,G%jsd:G%jed), source=0.0) + allocate(CS%mld(G%isd:G%ied,G%jsd:G%jed), source=CS%Hmix_fixed) if (CS%read_all_ts_uvh) then call read_all_input(CS, G, GV, US) @@ -1549,7 +1558,7 @@ subroutine offline_transport_end(CS) deallocate(CS%ebtr) deallocate(CS%h_end) deallocate(CS%Kd) - if (CS%read_mld) deallocate(CS%mld) + if (allocated(CS%mld)) deallocate(CS%mld) if (CS%read_all_ts_uvh) then deallocate(CS%uhtr_all) deallocate(CS%vhtr_all) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 6005a4b668..d3f6b29259 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -153,7 +153,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first do m = 1,ntr local_advect_scheme(m) = Reg%Tr(m)%advect_scheme - if(local_advect_scheme(m) < 0) local_advect_scheme(m) = CS%default_advect_scheme + if (local_advect_scheme(m) < 0) local_advect_scheme(m) = CS%default_advect_scheme if (local_advect_scheme(m) == ADVECT_PLM) then stencil_local = 2 @@ -273,15 +273,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first !$OMP end parallel isv = is ; iev = ie ; jsv = js ; jev = je + nsten_halo = min(is - isd, ied - ie, js - jsd, jed - je) / stencil do itt=1,max_iter if (isv > is-stencil) then call do_group_pass(CS%pass_uhr_vhr_t_hprev, G%Domain, clock=id_clock_pass) - nsten_halo = min(is-isd,ied-ie,js-jsd,jed-je)/stencil - isv = is-nsten_halo*stencil ; jsv = js-nsten_halo*stencil - iev = ie+nsten_halo*stencil ; jev = je+nsten_halo*stencil + isv = is - nsten_halo * stencil ; jsv = js - nsten_halo * stencil + iev = ie + nsten_halo * stencil ; jev = je + nsten_halo * stencil ! Reevaluate domore_u & domore_v unless the valid range is the same size as ! before. Also, do this if there is Strang splitting. if ((nsten_halo > 1) .or. (itt==1)) then @@ -540,18 +540,10 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values ntr_id = segment%tr_reg%Tr(m)%ntr_index if (advect_this_tracer(ntr_id)) then - 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) - else - T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) - endif + if (segment%direction == OBC_DIRECTION_W) then + T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - if (segment%direction == OBC_DIRECTION_W) then - T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc - else - T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc - endif + T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif endif ! advect_this_tracer enddo @@ -692,9 +684,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index if (advect_this_tracer(ntr_id)) then - 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 + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) endif ! advect_this_tracer enddo endif @@ -718,9 +708,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index if (advect_this_tracer(ntr_id)) then - 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 + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) endif ! advect_this_tracer enddo endif @@ -752,13 +740,12 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! Update do_i so that nothing changes outside of the OBC (problem for interior OBCs only) if (associated(OBC)) then - if ((.not.OBC%exterior_OBC_bug) .and. (OBC%OBC_pe)) then - if (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally) then - do i=is,ie-1 - if (OBC%segnum_u(I,j) > 0) do_i(i+1,j) = .false. ! OBC_DIRECTION_E - if (OBC%segnum_u(I,j) < 0) do_i(i,j) = .false. ! OBC_DIRECTION_W - enddo - endif + if ((.not.OBC%exterior_OBC_bug) .and. (OBC%OBC_pe) .and. & + (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally)) then + ! OBC_DIRECTION_E / OBC_DIRECTION_W on the west / east edge + do i=is,ie ; if ((OBC%segnum_u(I-1,j) > 0) .or. (OBC%segnum_u(I,j) < 0)) & + do_i(i,j) = .false. + enddo endif endif @@ -780,9 +767,9 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! diagnostics if (flux_type == 0) then - if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then + if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt - endif ; enddo ; endif + 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. @@ -793,13 +780,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & endif ; enddo endif elseif (flux_type == 1) then - if (associated(Tr(m)%ad_x_resolved)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then + if (associated(Tr(m)%ad_x_resolved)) then ; do I=is-1,ie Tr(m)%ad_x_resolved(I,j,k) = Tr(m)%ad_x_resolved(I,j,k) + flux_x(I,j,m)*Idt - endif ; enddo ; endif + enddo ; endif elseif (flux_type == 2) then - if (associated(Tr(m)%ad_x_param)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then + if (associated(Tr(m)%ad_x_param)) then ; do I=is-1,ie Tr(m)%ad_x_param(I,j,k) = Tr(m)%ad_x_param(I,j,k) + flux_x(I,j,m)*Idt - endif ; enddo ; endif + enddo ; endif endif ! the case of flux_type not equal 0, 1, or 2 is caught in advect_tracer above. endif ! advect_this_tracer enddo @@ -821,9 +808,9 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !$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 I=is-1,ie Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt - endif ; enddo + enddo endif ; enddo endif ; enddo ! End of m-loop. !$OMP end ordered @@ -981,18 +968,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values ntr_id = segment%tr_reg%Tr(m)%ntr_index if (advect_this_tracer(ntr_id)) then - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) - else - T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) - endif + if (segment%direction == OBC_DIRECTION_S) then + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc - else - T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc - endif + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif endif ! advect_this_tracer enddo @@ -1135,9 +1114,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index if (advect_this_tracer(ntr_id)) then - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) - else ; flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) endif ! advect_this_tracer enddo endif @@ -1161,9 +1138,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index if (advect_this_tracer(ntr_id)) then - 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 + flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) endif ! advect_this_tracer enddo endif @@ -1205,13 +1180,12 @@ 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) > 0) do_i(i,j) = .false. ! OBC_DIRECTION_N - if (OBC%segnum_v(i,J) < 0) do_i(i,j) = .false. ! OBC_DIRECTION_S - enddo - endif + if ((.not.OBC%exterior_OBC_bug) .and. (OBC%OBC_pe) .and. & + (OBC%specified_v_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) then + ! OBC_DIRECTION_N / OBC_DIRECTION_S on the south / north edge + do i=is,ie ; if ((OBC%segnum_v(i,J-1) > 0) .or. (OBC%segnum_v(i,J) < 0)) & + do_i(i,j) = .false. + enddo endif endif @@ -1251,17 +1225,17 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !$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 i=is,ie Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt - endif ; enddo + enddo endif ; enddo endif ; enddo ! End of m-loop. do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then do J=js-1,je ; if (domore_v_initial(J)) then - do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then + do i=is,ie Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt - endif ; enddo + enddo endif ; enddo endif ; enddo ! End of m-loop. !$OMP end ordered @@ -1269,9 +1243,9 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !$OMP ordered do m=1,ntr ; if (associated(Tr(m)%ad_y_resolved)) 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 i=is,ie Tr(m)%ad_y_resolved(i,J,k) = Tr(m)%ad_y_resolved(i,J,k) + flux_y(i,m,J)*Idt - endif ; enddo + enddo endif ; enddo endif ; enddo ! End of m-loop. !$OMP end ordered @@ -1279,9 +1253,9 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !$OMP ordered do m=1,ntr ; if (associated(Tr(m)%ad_y_param)) 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 i=is,ie Tr(m)%ad_y_param(i,J,k) = Tr(m)%ad_y_param(i,J,k) + flux_y(i,m,J)*Idt - endif ; enddo + enddo endif ; enddo endif ; enddo ! End of m-loop. !$OMP end ordered diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 33db88fe3f..83074fb1bf 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -347,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) & @@ -447,7 +447,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, & @@ -877,12 +877,12 @@ subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, 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(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(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 diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index c550f73ef5..bb0f6a08d6 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -383,7 +383,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)) @@ -676,7 +676,6 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo endif 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 @@ -703,7 +702,6 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo endif 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 @@ -736,7 +734,6 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ endif 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 @@ -1595,7 +1592,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! 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) + 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 @@ -1617,7 +1614,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & enddo else do k=1,nPv(i,J) - kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) + kLb = k0b_Lv(J)%p(i,k) ; kRb = k0b_Rv(J)%p(i,k) if (deep_wt_Lv(J)%p(i,k) >= 1.0) then tr_flux_N(i,j,kLb) = tr_flux_N(i,j,kLb) + Tr_flux_3d(i,J,k) else diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 08860c3ccb..ec3f1fa11e 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -240,7 +240,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 @@ -250,12 +250,12 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit if (present(ad_y)) then ; if (associated(ad_y)) Tr%ad_y => ad_y ; endif if (present(df_x)) then ; if (associated(df_x)) Tr%df_x => df_x ; endif if (present(df_y)) then ; if (associated(df_y)) Tr%df_y => df_y ; endif -! if (present(OBC_inflow)) Tr%OBC_inflow_conc = OBC_inflow ! if (present(OBC_in_u)) then ; if (associated(OBC_in_u)) Tr%OBC_in_u => OBC_in_u ; endif ! if (present(OBC_in_v)) then ; if (associated(OBC_in_v)) Tr%OBC_in_v => OBC_in_v ; endif if (present(ad_2d_x)) then ; if (associated(ad_2d_x)) Tr%ad2d_x => ad_2d_x ; endif if (present(ad_2d_y)) then ; if (associated(ad_2d_y)) Tr%ad2d_y => ad_2d_y ; endif if (present(df_2d_x)) then ; if (associated(df_2d_x)) Tr%df2d_x => df_2d_x ; endif + if (present(df_2d_y)) then ; if (associated(df_2d_y)) Tr%df2d_y => df_2d_y ; endif if (present(advection_xy)) then if (associated(advection_xy)) Tr%advection_xy => advection_xy @@ -308,7 +308,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u character(len=48) :: flux_units ! The units for fluxes, either ! [units] m3 s-1 or [units] kg s-1. character(len=48) :: conv_units ! The units for flux convergences, either - ! [units] m2 s-1 or [units] kg s-1. + ! [units] m s-1 or [units] kg m-2 s-1. character(len=48) :: unit2 ! The dimensions of the tracer squared character(len=72) :: cmorname ! The CMOR name of this tracer. character(len=120) :: cmor_longname ! The CMOR long name of that variable. @@ -398,9 +398,9 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u y_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional " //& - "flux from the horizontal boundary diffusion scheme", trim(flux_units), & - v_extensive=.true., & - x_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + "flux from the horizontal boundary diffusion scheme", & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & + conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, "Advective (by residual mean) Zonal Flux of "//trim(flux_longname), & @@ -522,37 +522,32 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u if (Tr%diag_form == 1) then Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + conv_units, conversion=Tr%conv_scale*US%s_to_T, v_extensive=.true.) Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", & trim(shortnm)//'_dfxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated neutral diffusion tracer content "//& - "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum') + "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T) Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//& trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + conv_units, conversion=Tr%conv_scale*US%s_to_T, v_extensive=.true.) Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", & trim(shortnm)//'_hbdxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated horizontal boundary diffusion tracer content "//& - "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum') + "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T) else cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& trim(lowercase(flux_longname))//& ' content due to parameterized mesoscale neutral diffusion' Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, & + conv_units, conversion=Tr%conv_scale*US%s_to_T, v_extensive=.true., & cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff', & cmor_long_name=trim(cmor_var_lname), & - cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & - x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + cmor_standard_name=trim(cmor_long_std(cmor_var_lname))) cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& trim(lowercase(flux_longname))//& @@ -563,20 +558,17 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & cmor_long_name=trim(cmor_var_lname), & - cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & - x_cell_method='sum', y_cell_method='sum') + cmor_standard_name=trim(cmor_long_std(cmor_var_lname))) Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & diag%axesTL, Time, & "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + conv_units, conversion=Tr%conv_scale*US%s_to_T, v_extensive=.true.) Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", & trim(shortnm)//'_hbdxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated horizontal boundary diffusion of tracer "//& - "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum') + "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T) endif Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & diag%axesTL, Time, "Neutral diffusion tracer concentration tendency for "//trim(shortnm), & @@ -752,7 +744,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) diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90 index 68a6f7da4f..cc5d53cb4c 100644 --- a/src/tracer/MOM_tracer_types.F90 +++ b/src/tracer/MOM_tracer_types.F90 @@ -13,7 +13,6 @@ module MOM_tracer_types type, public :: tracer_type real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array [CU ~> conc] -! real :: OBC_inflow_conc= 0.0 !< tracer concentration for generic inflows [CU ~> conc] ! real, dimension(:,:,:), pointer :: OBC_in_u => NULL() !< structured values for flow into the domain ! !! specified in OBCs through u-face of cell ! real, dimension(:,:,:), pointer :: OBC_in_v => NULL() !< structured values for flow into the domain diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 7f15d0ba1b..e0ab347ea5 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -297,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/dye_example.F90 b/src/tracer/dye_example.F90 index dbff568937..7cbeebd38f 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -7,7 +7,7 @@ module regional_dyes 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 @@ -61,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 @@ -118,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, & @@ -206,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 @@ -224,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] @@ -234,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) @@ -294,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 @@ -304,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 @@ -312,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 1e1b391964..881d18eac0 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -94,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 dca68c724d..1543a93094 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -18,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 @@ -179,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 @@ -373,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 b8dcb61326..851cd96bc6 100644 --- a/src/tracer/nw2_tracers.F90 +++ b/src/tracer/nw2_tracers.F90 @@ -14,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/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index fb4e87f51d..2472c1182c 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -207,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/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index d7e6c1cd6a..6cce3f9456 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -208,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 @@ -261,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. @@ -488,7 +488,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) enddo ; enddo ; enddo name = 'temp' call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) - call register_segment_tracer(tr_ptr, ntr_id, PF, GV, segment, OBC_array=.true., scale=US%degC_to_C) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, segment, scale=US%degC_to_C) endif ! Set up dye tracers @@ -501,7 +501,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) enddo ; enddo ; enddo name = 'tr_D1' call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) - call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_array=.true.) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1)) ! 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. diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index e93d0604f0..d0697a2e49 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -372,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 @@ -428,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) @@ -437,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. @@ -625,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) @@ -677,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 fe37fd4e67..9e83849a2c 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -24,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 @@ -228,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) @@ -310,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, & @@ -373,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 bbd6ffa4a5..36ccf6115e 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -19,7 +19,7 @@ module Kelvin_initialization 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 @@ -248,7 +248,7 @@ 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) diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index 68e2eb4265..dde4a2dd39 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -298,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) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index d7ce6cb95e..23f4c8cb7d 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -357,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 @@ -457,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, & @@ -513,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, & @@ -1824,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) + & @@ -1836,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 @@ -1881,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 + & @@ -1960,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 @@ -2005,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/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 3b20be4f34..cf4690a24b 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -283,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 418f739242..de7727ee72 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -37,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. @@ -84,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/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index dc026b5a38..708c17567a 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -185,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, & @@ -253,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 5e60f33057..246384bf38 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -149,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 @@ -168,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. ) @@ -282,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/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 2b09631151..2501cb0db3 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -209,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 b61b9242b6..2d34bbb59b 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -14,7 +14,7 @@ module dyed_channel_initialization 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 @@ -171,7 +171,7 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, h, Time) 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) turns = modulo(G%HI%turns, 4) diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index f298c6eefb..9d6abee421 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -57,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/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 3360b29a1d..488ac2b211 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -13,7 +13,7 @@ module shelfwave_initialization 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, rotate_OBC_segment_direction -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 use MOM_verticalGrid, only : verticalGrid_type @@ -169,7 +169,7 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, 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 = US%s_to_T*time_type_to_real(Time) + 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 diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 3fef6fd4e4..2fa18d5ee6 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -108,7 +108,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, !z_inter(k) = (2.0**(n-1)) * (z_unif(k) + 0.5)**n - 0.5 ! Thin pycnocline in the middle (piecewise linear profile) - x1 = 0.30; y1 = 0.48; x2 = 0.70; y2 = 0.52 + x1 = 0.30 ; y1 = 0.48 ; x2 = 0.70 ; y2 = 0.52 x = -z_unif(k) diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index 526e3a8a10..9190151569 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -11,7 +11,7 @@ module supercritical_initialization use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, rotate_OBC_segment_direction use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_time_manager, only : time_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index abd60c53ff..58938c65c0 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -16,7 +16,7 @@ module tidal_bay_initialization 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 @@ -97,7 +97,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) 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) segment => OBC%segment(1)