diff --git a/.codecov.yml b/.codecov.yml new file mode 100644 index 0000000000..ae3b27aed3 --- /dev/null +++ b/.codecov.yml @@ -0,0 +1,10 @@ +coverage: + status: + project: + default: + threshold: 100% + base: parent + patch: + default: + threshold: 100% + base: parent diff --git a/.github/actions/macos-setup/action.yml b/.github/actions/macos-setup/action.yml new file mode 100644 index 0000000000..4c248abd11 --- /dev/null +++ b/.github/actions/macos-setup/action.yml @@ -0,0 +1,33 @@ +name: 'install-macos-prerequisites' + +description: 'Install prerequisites for Mac OS compilation' + +runs: + using: 'composite' + + steps: + - name: Install macOS packages + shell: bash + run: | + echo "::group::Install packages" + brew reinstall gcc + brew install automake + brew install netcdf + brew install netcdf-fortran + brew install mpich + echo "::endgroup::" + + # NOTE: Floating point exceptions are currently disabled due to an error in + # HDF5 1.4.3. They will be re-enabled when the default brew version has + # been updated to a working version. + + - name: Set compiler flags + shell: bash + run: | + cd .testing + echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -fcheck=bounds" >> config.mk + echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk + echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk + echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk + cat config.mk + echo "::endgroup::" diff --git a/.github/actions/testing-setup/action.yml b/.github/actions/testing-setup/action.yml new file mode 100644 index 0000000000..60499d4be1 --- /dev/null +++ b/.github/actions/testing-setup/action.yml @@ -0,0 +1,45 @@ +name: 'Build-.testing-prerequisites' +description: 'Build pre-requisites for .testing including FMS and a symmetric MOM6 executable' +inputs: + build_symmetric: + description: 'If true, will build the symmetric MOM6 executable' + required: false + default: 'true' +runs: + using: 'composite' + steps: + - name: Git info + shell: bash + run: | + echo "::group::Git commit info" + echo "git log:" + git log | head -60 + echo "::endgroup::" + + - name: Env + shell: bash + run: | + echo "::group::Environment" + env + echo "::endgroup::" + + - name: Compile FMS library + shell: bash + run: | + echo "::group::Compile FMS library" + cd .testing + REPORT_ERROR_LOGS=true make build/deps/lib/libFMS.a -s -j + echo "::endgroup::" + + - name: Compile MOM6 in symmetric memory mode + shell: bash + run: | + echo "::group::Compile MOM6 in symmetric memory mode" + cd .testing + test ${{ inputs.build_symmetric }} == true && make build/symmetric/MOM6 -j + echo "::endgroup::" + + - name: Set flags + shell: bash + run: | + echo "TIMEFORMAT=... completed in %lR (user: %lU, sys: %lS)" >> $GITHUB_ENV diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml new file mode 100644 index 0000000000..83d6795954 --- /dev/null +++ b/.github/actions/ubuntu-setup/action.yml @@ -0,0 +1,31 @@ +name: 'install-ubuntu-prerequisites' + +description: 'Install prerequisites for Ubuntu Linux compilation' + +runs: + using: 'composite' + steps: + - name: Install Ubuntu Linux packages + shell: bash + run: | + echo "::group::Install linux packages" + sudo apt-get update + sudo apt-get install netcdf-bin + sudo apt-get install libnetcdf-dev + sudo apt-get install libnetcdff-dev + sudo apt-get install openmpi-bin + sudo apt-get install libopenmpi-dev + sudo apt-get install linux-tools-common + echo "::endgroup::" + + - name: Store compiler flags used in Makefile + shell: bash + run: | + echo "::group::config.mk" + cd .testing + echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk + echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk + echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk + echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk + cat config.mk + echo "::endgroup::" diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml new file mode 100644 index 0000000000..2d99b45967 --- /dev/null +++ b/.github/workflows/coupled-api.yml @@ -0,0 +1,30 @@ +name: API for coupled drivers + +on: [push, pull_request] + +jobs: + test-top-api: + + runs-on: ubuntu-latest + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - uses: ./.github/actions/testing-setup + with: + build_symmetric: 'false' + + - name: Compile MOM6 for the GFDL coupled driver + shell: bash + run: make check_mom6_api_coupled -j + + - name: Compile MOM6 for the NUOPC driver + shell: bash + run: make check_mom6_api_nuopc -j diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml new file mode 100644 index 0000000000..1f5a64ac56 --- /dev/null +++ b/.github/workflows/coverage.yml @@ -0,0 +1,48 @@ +name: Code coverage + +on: [push, pull_request] + +jobs: + build-coverage: + + runs-on: ubuntu-latest + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - uses: ./.github/actions/testing-setup + + - name: Compile file parser unit tests + run: make -j build/unit/test_MOM_file_parser + + - name: Run file parser unit tests + run: make run.cov.unit + + - name: Compile unit testing + run: make -j build.unit + + - name: Run (single processor) unit tests + run: make run.unit + + - name: Report unit test coverage to CI + run: make report.cov.unit + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} + + - name: Compile ocean-only MOM6 with code coverage + run: make -j build/cov/MOM6 + + - name: Run coverage tests + run: make -j -k run.cov + + - name: Report coverage to CI + run: make report.cov + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} diff --git a/.github/workflows/documentation-and-style.yml b/.github/workflows/documentation-and-style.yml new file mode 100644 index 0000000000..3ca7f0e613 --- /dev/null +++ b/.github/workflows/documentation-and-style.yml @@ -0,0 +1,39 @@ +name: Doxygen and style + +on: [push, pull_request] + +jobs: + doxygen: + + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - name: Check white space (non-blocking) + run: | + ./.testing/trailer.py -e TEOS10 -l 120 src config_src 2>&1 | tee style_errors + continue-on-error: true + + - name: Install packages used when generating documentation + run: | + sudo apt-get update + sudo apt-get install python3-sphinx python3-lxml perl + sudo apt-get install texlive-binaries texlive-base bibtool tex-common texlive-bibtex-extra + sudo apt-get install graphviz + + - name: Build doxygen HTML + run: | + cd docs + perl -e 'print "perl version $^V" . "\n"' + mkdir _build && make nortd DOXYGEN_RELEASE=Release_1_8_13 UPDATEHTMLEQS=Y + cat _build/doxygen_warn_nortd_log.txt + + - name: Report doxygen or style errors + run: | + grep "warning:" docs/_build/doxygen_warn_nortd_log.txt | grep -v "as part of a" | tee doxy_errors + cat style_errors doxy_errors > all_errors + cat all_errors + test ! -s all_errors diff --git a/.github/workflows/expression.yml b/.github/workflows/expression.yml new file mode 100644 index 0000000000..5860d32e37 --- /dev/null +++ b/.github/workflows/expression.yml @@ -0,0 +1,29 @@ +name: Expression verification + +on: [push, pull_request] + +jobs: + test-repro-and-dims: + + runs-on: ubuntu-latest + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - uses: ./.github/actions/testing-setup + + - name: Compile MOM6 using repro optimization + run: make build/repro/MOM6 -j + + - name: Create validation data + run: make run.symmetric -k -s + + - name: Run tests + run: make test.repro test.dim -k -s diff --git a/.github/workflows/macos-regression.yml b/.github/workflows/macos-regression.yml new file mode 100644 index 0000000000..d769e15131 --- /dev/null +++ b/.github/workflows/macos-regression.yml @@ -0,0 +1,35 @@ +name: MacOS regression + +on: [pull_request] + +jobs: + test-macos-regression: + + runs-on: macOS-latest + + env: + CC: gcc + FC: gfortran + FMS_COMMIT: 2019.01.03 + + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - uses: ./.github/actions/testing-setup + + - name: Compile reference model + run: make build.regressions MOM_TARGET_SLUG=$GITHUB_REPOSITORY MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF DO_REGRESSION_TESTS=true -j + + - name: Create validation data + run: make run.symmetric -k -s + + - name: Regression test + run: make test.regression DO_REGRESSION_TESTS=true -k -s diff --git a/.github/workflows/macos-stencil.yml b/.github/workflows/macos-stencil.yml new file mode 100644 index 0000000000..6e77a5c4a6 --- /dev/null +++ b/.github/workflows/macos-stencil.yml @@ -0,0 +1,35 @@ +name: MacOS stencil tests + +on: [push, pull_request] + +jobs: + test-macos-stencil: + + runs-on: macOS-latest + + env: + CC: gcc + FC: gfortran + FMS_COMMIT: 2019.01.03 + + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/macos-setup + + - uses: ./.github/actions/testing-setup + + - name: Compile MOM6 in asymmetric memory mode + run: make build/asymmetric/MOM6 -j + + - name: Create validation data + run: make run.symmetric -k -s + + - name: Run tests + run: make test.grid test.layout test.rotate -k -s diff --git a/.github/workflows/other.yml b/.github/workflows/other.yml new file mode 100644 index 0000000000..2cba17ae76 --- /dev/null +++ b/.github/workflows/other.yml @@ -0,0 +1,29 @@ +name: OpenMP and Restart verification + +on: [push, pull_request] + +jobs: + test-openmp-nan-restarts: + + runs-on: ubuntu-latest + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - uses: ./.github/actions/testing-setup + + - name: Compile with openMP + run: make build/openmp/MOM6 -j + + - name: Create validation data + run: make run.symmetric -k -s + + - name: Run tests + run: make test.openmp test.nan test.restart -k -s diff --git a/.github/workflows/perfmon.yml b/.github/workflows/perfmon.yml new file mode 100644 index 0000000000..8fd314cee3 --- /dev/null +++ b/.github/workflows/perfmon.yml @@ -0,0 +1,75 @@ +name: Performance Monitor + +on: [push, pull_request] + +jobs: + build-test-perfmon: + + runs-on: ubuntu-latest + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - uses: ./.github/actions/testing-setup + + - name: Compile optimized models + if: ${{ github.event_name == 'pull_request' }} + run: >- + make -j build.prof + MOM_TARGET_SLUG=$GITHUB_REPOSITORY + MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF + DO_REGRESSION_TESTS=true + + - name: Generate profile data + if: ${{ github.event_name == 'pull_request' }} + run: >- + pip install f90nml && + make profile + DO_REGRESSION_TESTS=true + + - name: Generate perf data + if: ${{ github.event_name == 'pull_request' }} + run: | + sudo sysctl -w kernel.perf_event_paranoid=2 + make perf DO_REGRESSION_TESTS=true + + # This job assumes that build/target_codebase was cloned above + - name: Compile timing tests for reference code + if: ${{ github.event_name == 'pull_request' }} + run: >- + make -j build.timing_target + MOM_TARGET_SLUG=$GITHUB_REPOSITORY + MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF + DO_REGRESSION_TESTS=true + + - name: Compile timing tests + run: | + make -j build.timing + + # DO_REGERESSION_TESTS=true is needed here to set the internal macro TARGET_CODEBASE + - name: Run timing tests for reference code + if: ${{ github.event_name == 'pull_request' }} + run: >- + make -j run.timing_target + DO_REGRESSION_TESTS=true + + - name: Run timing tests + run: | + make -j run.timing + + - name: Display timing results + run: | + make -j show.timing + + - name: Display comparison of timing results + if: ${{ github.event_name == 'pull_request' }} + run: >- + make -j compare.timing + DO_REGRESSION_TESTS=true diff --git a/.github/workflows/regression.yml b/.github/workflows/regression.yml new file mode 100644 index 0000000000..7cdd0a5cd6 --- /dev/null +++ b/.github/workflows/regression.yml @@ -0,0 +1,29 @@ +name: Regression + +on: [pull_request] + +jobs: + build-test-regression: + + runs-on: ubuntu-latest + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - uses: ./.github/actions/testing-setup + + - name: Compile reference model + run: make build.regressions MOM_TARGET_SLUG=$GITHUB_REPOSITORY MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF DO_REGRESSION_TESTS=true -j + + - name: Create validation data + run: make run.symmetric -k -s + + - name: Regression test + run: make test.regression DO_REGRESSION_TESTS=true -k -s diff --git a/.github/workflows/stencil.yml b/.github/workflows/stencil.yml new file mode 100644 index 0000000000..c85945072c --- /dev/null +++ b/.github/workflows/stencil.yml @@ -0,0 +1,29 @@ +name: Stencil related verification + +on: [push, pull_request] + +jobs: + test-symmetric-layout-rotation: + + runs-on: ubuntu-latest + defaults: + run: + working-directory: .testing + + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + + - uses: ./.github/actions/ubuntu-setup + + - uses: ./.github/actions/testing-setup + + - name: Compile MOM6 in asymmetric memory mode + run: make build/asymmetric/MOM6 -j + + - name: Create validation data + run: make run.symmetric -k -s + + - name: Run tests + run: make test.grid test.layout test.rotate -k -s diff --git a/.gitignore b/.gitignore index 01b8f29b54..25f7524d1c 100644 --- a/.gitignore +++ b/.gitignore @@ -2,4 +2,13 @@ *.swp *~ html -*.log + + +# Autoconf output +aclocal.m4 +autom4te.cache/ +config.log +config.status +configure +/Makefile +Makefile.mkmf diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e5af9feb36..55494696ae 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,240 +1,359 @@ stages: - - merge+setup + - setup - builds - run - tests - cleanup -# Merges MOM6 with dev/gfdl. Changes directory to test directory, if it exists. +# JOB_DIR points to a persistent working space used for most stages in this pipeline but +# that is unique to this pipeline. +# We use the "fetch" strategy to speed up the startup of stages +variables: + JOB_DIR: "/gpfs/f5/gfdl_o/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" + GIT_STRATEGY: fetch + +# Always eport value of $JOB_DIR before_script: - - MOM6_SRC=$CI_PROJECT_DIR - - echo Cache directory set to ${CACHE_DIR:=/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/cache/} - - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl && git submodule init && git submodule update - - pwd ; ls + - echo Job directory set to $JOB_DIR -# Tests that merge with dev/gfdl works. -merge: - stage: merge+setup +# Test that merge with dev/gfdl works. +p:merge: + stage: setup tags: - - ncrc4 + - ncrc5 script: - - pwd ; ls - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl -# Clones regression repo, if necessary, pulls latest of everything, and sets up working space -setup: - stage: merge+setup - tags: - - ncrc4 - script: - - pwd ; ls - # Clone regressions directory - - git clone --recursive http://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git tests && cd tests - # Install / update testing scripts - - git clone https://github.com/adcroft/MRS.git MRS - - (cd MRS ; git checkout xanadu-fms) - # Update MOM6-examples and submodules - - (cd MOM6-examples && git checkout . && git checkout dev/gfdl && git pull && git submodule init && git submodule update) - - (cd MOM6-examples/src/MOM6 && git submodule update) - - test -d MOM6-examples/src/LM3 || make -f MRS/Makefile.clone clone_gfdl -s - - make -f MRS/Makefile.clone MOM6-examples/.datasets -s - #- (cd MOM6-examples/src/mkmf && git pull https://github.com/adcroft/mkmf.git add_coverage_mode) - - env > gitlab_session.log - # Cache everything under tests to unpack for each subsequent stage - - cd ../ ; time tar zcf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz tests - -# Compiles -gnu:repro: +# Setup the persistent JOB_DIR for all subsequent stages +# +# This basically setups up a complete tree much as a user would in their workflow +p:clone: + stage: setup + tags: + - ncrc5 + script: + # NOTE: We could sweep any builds older than 3 days here if needed + #- find $HOME/ci/[0-9]* -mtime +3 -delete 2> /dev/null || true + - .gitlab/pipeline-ci-tool.sh create-job-dir +#.gitlab/pipeline-ci-tool.sh clean-job-dir + +# Make work spaces for running simultaneously in parallel jobs +# +# Each work space is a clone of MOM6-examples with symbolic links for the build and data directories +# so they can share executables which can run simultaneously without interfering with each other + +s:work-space:pgi: + stage: setup + tags: + - ncrc5 + needs: ["p:clone"] + script: + - .gitlab/pipeline-ci-tool.sh copy-test-space pgi + +s:work-space:intel: + stage: setup + tags: + - ncrc5 + needs: ["p:clone"] + script: + - .gitlab/pipeline-ci-tool.sh copy-test-space intel + +s:work-space:gnu: + stage: setup + tags: + - ncrc5 + needs: ["p:clone"] + script: + - .gitlab/pipeline-ci-tool.sh copy-test-space gnu + +s:work-space:gnu-restarts: + stage: setup + tags: + - ncrc5 + needs: ["p:clone"] + script: + - .gitlab/pipeline-ci-tool.sh copy-test-space gnu-rst + +# Compile executables +# +# gnu:repro, gnu:debug, intel:repro and pgi:repro are used by their respective run:* jobs +# gnu:ice-only-nolib and gnu:ocean-only-nolibs are not used but simply test that the model compiles without libraries + +compile:pgi:repro: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time make -f MRS/Makefile.build MOM6_SRC=../ build_gnu -s -j - - time make -f MRS/Makefile.build MOM6_SRC=../ static_gnu -s -j - - time tar zvcf $CACHE_DIR/build-gnu-repro-$CI_PIPELINE_ID.tgz `find build/gnu -name MOM6` + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_pgi -gnu:ocean-only-nolibs: +compile:intel:repro: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build build/gnu/env && cd build/gnu - # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{solo_driver,dynamic_symmetric} ../../../src ../../MOM6-examples/src/FMS - - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names - - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_intel -gnu:ice-ocean-nolibs: +compile:gnu:repro: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build build/gnu/env && cd build/gnu - # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{coupled_driver,dynamic} ../../../src ../../MOM6-examples/src/{FMS,coupler,SIS2,icebergs,ice_param,land_null,atmos_null} - - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names - - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu -intel:repro: +compile:gnu:debug: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ build_intel -s -j - - time tar zvcf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz `find build/intel -name MOM6` + - .gitlab/pipeline-ci-tool.sh mrs-compile debug_gnu -pgi:repro: +compile:gnu:ocean-only-nolibs: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ build_pgi -s -j - - time tar zvcf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz `find build/pgi -name MOM6` + - .gitlab/pipeline-ci-tool.sh nolibs-ocean-only-compile gnu -gnu:debug: +compile:gnu:ice-ocean-nolibs: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - make -f MRS/Makefile.build MOM6_SRC=../ debug_gnu -s -j - - time tar zvcf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz `find build/gnu -name MOM6` + - .gitlab/pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu # Runs -run: + +run:pgi: + stage: run + needs: ["s:work-space:pgi","compile:pgi:repro"] + tags: + - ncrc5 + script: + - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_pgi_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite pgi SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - test -f $JOB_DIR/CI-BATCH-SUCCESS-pgi-SNL || ( echo Batch job did not complete ; exit 911 ) + +run:intel: + stage: run + needs: ["s:work-space:intel","compile:intel:repro"] + tags: + - ncrc5 + script: + - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_intel_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite intel SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - test -f $JOB_DIR/CI-BATCH-SUCCESS-intel-SNL || ( echo Batch job did not complete ; exit 911 ) + +run:gnu: + stage: run + needs: ["s:work-space:gnu","compile:gnu:repro","compile:gnu:debug"] + tags: + - ncrc5 + script: + - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu SNLDT && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-SNLDT || ( echo Batch job did not complete ; exit 911 ) + +run:gnu-restarts: stage: run + needs: ["s:work-space:gnu-restarts","compile:gnu:repro"] + tags: + - ncrc5 + script: + - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_restarts --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu R && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-R || ( echo Batch job did not complete ; exit 911 ) + +# GH/autoconf tests (duplicates the GH actions tests) +# +# These stages replace the "before_script" and so start in the transient work-space provided by gitlab. +# We work here to avoid collisions with parallel jobs + +actions:gnu: + stage: tests + needs: [] tags: - - ncrc4 + - ncrc5 + before_script: + - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" + - git submodule init ; git submodule update + - echo -e "\e[0Ksection_end:`date +%s`:submodules\r\e[0K" script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/build-gnu-repro-$CI_PIPELINE_ID.tgz - - time tar zxf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz - - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz - # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all -B') > job.sh - - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh - - cat log.$CI_PIPELINE_ID - - test -f restart_results_gnu.tar.gz - - time tar zvcf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz *.tar.gz + - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" + - cd .testing + - module unload PrgEnv-gnu PrgEnv-intel PrgEnv-nvhpc ; module load PrgEnv-gnu ; module unload gcc ; module load gcc/12.2.0 cray-hdf5 cray-netcdf + - make -s -j + - MPIRUN= make preproc -s -j + - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh + - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make test -s + - make test.summary + +actions:intel: + stage: tests + needs: [] + tags: + - ncrc5 + before_script: + - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" + - git submodule init ; git submodule update + - echo -e "\e[0Ksection_end:`date +%s`:submodules\r\e[0K" + script: + - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" + - cd .testing + - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu ; module load PrgEnv-intel; module unload intel; module load intel-classic/2022.0.2 cray-hdf5 cray-netcdf + - make -s -j + - MPIRUN= make preproc -s -j + - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh + - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.intel.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make test -s + - make test.summary # Tests -gnu:non-symmetric: +# +# stats file tests involve comparing the check sums of the generated files against the check sums in the stats-repo +# log file tests involve comparing the check sums of the generated files against the check sums in MOM6-examples + +t:pgi:symmetric: + stage: tests + needs: ["run:pgi"] + tags: + - ncrc5 + script: + - .gitlab/pipeline-ci-tool.sh check-stats pgi S + +t:pgi:non-symmetric: stage: tests + needs: ["run:pgi"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_non_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats pgi N -intel:non-symmetric: +t:pgi:layout: stage: tests + needs: ["run:pgi"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_non_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats pgi L -pgi:non-symmetric: +t:pgi:params: stage: tests + needs: ["run:pgi"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_non_symmetric + - .gitlab/pipeline-ci-tool.sh check-params pgi + allow_failure: true + +t:intel:symmetric: + stage: tests + needs: ["run:intel"] + tags: + - ncrc5 + script: + - .gitlab/pipeline-ci-tool.sh check-stats intel S -gnu:symmetric: +t:intel:non-symmetric: stage: tests + needs: ["run:intel"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats intel N -intel:symmetric: +t:intel:layout: stage: tests + needs: ["run:intel"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats intel L -pgi:symmetric: +t:intel:params: stage: tests + needs: ["run:intel"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_symmetric + - .gitlab/pipeline-ci-tool.sh check-params intel + allow_failure: true -gnu:layout: +t:gnu:symmetric: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_layout + - .gitlab/pipeline-ci-tool.sh check-stats gnu S -intel:layout: +t:gnu:non-symmetric: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests intel_layout + - .gitlab/pipeline-ci-tool.sh check-stats gnu N -pgi:layout: +t:gnu:layout: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests pgi_layout + - .gitlab/pipeline-ci-tool.sh check-stats gnu L -gnu:static: +t:gnu:static: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_static + - .gitlab/pipeline-ci-tool.sh check-stats gnu T -gnu:restart: +t:gnu:symmetric-debug: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests gnu_check_restarts + - .gitlab/pipeline-ci-tool.sh check-stats gnu D + +t:gnu:restart: + stage: tests + needs: ["run:gnu-restarts"] + tags: + - ncrc5 + script: + - .gitlab/pipeline-ci-tool.sh check-stats gnu R + +t:gnu:params: + stage: tests + needs: ["run:gnu"] + tags: + - ncrc5 + script: + - .gitlab/pipeline-ci-tool.sh check-params gnu + allow_failure: true -gnu:params: +t:gnu:diags: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - - make -f MRS/Makefile.tests params_gnu_symmetric + - .gitlab/pipeline-ci-tool.sh check-diags gnu allow_failure: true +# We cleanup ONLY if the preceding stages were completed successfully cleanup: stage: cleanup tags: - - ncrc4 + - ncrc5 + before_script: + - echo Skipping usual preamble script: - - rm $CACHE_DIR/*$CI_PIPELINE_ID.tgz + - rm -rf $HOME/ci/$CI_PIPELINE_ID + - rm -rf $JOB_DIR diff --git a/.gitlab/README.md b/.gitlab/README.md new file mode 100644 index 0000000000..6e11900f9e --- /dev/null +++ b/.gitlab/README.md @@ -0,0 +1,148 @@ +# CI script pipeline-ci-tool.sh + +pipeline-ci-tool.sh contains functions corresponding to each job within the gitlab CI pipeline for MOM6 at GFDL, specifically on the gaea HPC. +Each function can be run by a parser function so that the functions can be invoked from the command line or a shell. +Some functions take arguments. +Encapsulating the job commands in a function allows us to develop/debug the pipeline by issuing the same, relatively short, commands at the command line. + +pipeline-ci-tool.sh relies on three environment variables to execute. They are mandatory. + - JOB_DIR is a scratch location that will be created and populated + - CI_PROJECT_DIR is normally set by gitlab and will point to the working directory where MOM6 is cloned + - CI_COMMIT_SHA is the commit of MOM6 to be tested + +To use pipeline-ci-tool.sh interactively from an existing MOM6 clone, you could use + `JOB_DIR=tmp CI_PROJECT_DIR=. CI_COMMIT_SHA=`git rev-parse HEAD` .gitlab/pipeline-ci-tool.sh ...` +This will use the HEAD commit in the current working dir and setup an independent test suite under tmp/. + +## Usage + `pipeline-ci-tool.sh FUNCTION [-x|+x] [-n|+n] [ARG1] [ARG2] [...]` + `pipeline-ci-tool.sh FUNCTION [-x|+x] [-n|+n] [ARG1] [ARG2] [[-x|+x] [-n|+n] FUNCTION [ARG1] [ARG2] [...]] [...]` + +FUNCTION can be one of + - `create-job-dir` : Create a "job directory" using the environment variable JOB_DIR. This is a where all the compilation and running takes place. + - `clean-job-dir` : Not used by .gitlab-ci.yml but useful for resetting an interactive session. + - `copy-test-space LABEL` : Within $JOB_DIR, clones MOM6-examples to tmp-MOM6-examples-LABEL to use as a workspace for tests + - `mrs-compile TARGET` : Invokes tools/MRS/Makefile.build to build MODE_VENDER. VENDER can be gnu, intel, or pgi. MODE can be repro, debug, static, etc. + - `nolibs-ocean-only-compile VENDER` : Compiles the "no libraries" executables. These are not used elsewhere in the CI but check we have no namespace problems. VENDER can be gnu, intel, or pgi. + - `run-suite VENDER CODE` : runs subsets of the MOM6-examples according to CODE using the VENDER executables. CODE is a string of the characters S (symmetric), N (non-symmetric), L (layout), D (debug), or R (restart), and if present executes the corresponding tests. + - `check-stats VENDER CODE` : check the stats files for the corresponding VENDOR/CODE resulting from run-suite + - `check-params VENDER CODE` : check the parameter documentation files for the corresponding VENDOR/CODE resulting from run-suite + - `check-diags VENDER CODE` : check the available diagnostics files for the corresponding VENDOR/CODE resulting from run-suite + +Options: + - `-x` : shows commands as they are executed. `+x` turns back to silent executions. You can precede each function as needed so that only commands from selected functions are shown. + - `-n` : for many function, disables all functionality and simply prints the banner that each sections was reached. `+n` turns the functions back on. + +## Correspondance to jobs in .gitlab-ci.yml + +The .gitlab-ci.yml jobs names and pipeline-ci-tool.sh commands are: + + clone: + `pipeline-ci-tool.sh create-job-dir` + + work-space:pgi: + `pipeline-ci-tool.sh copy-test-space pgi` + + work-space:intel: + `pipeline-ci-tool.sh copy-test-space intel` + + work-space:gnu: + `pipeline-ci-tool.sh copy-test-space gnu` + + work-space:gnu-restarts: + `pipeline-ci-tool.sh copy-test-space gnu-rst` + + compile:pgi:repro: + `pipeline-ci-tool.sh mrs-compile repro_pgi` + + compile:intel:repro: + `pipeline-ci-tool.sh mrs-compile repro_intel` + + compile:gnu:repro: + `pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu` + + compile:gnu:debug: + `pipeline-ci-tool.sh mrs-compile debug_gnu` + + compile:gnu:ocean-only-nolibs: + `pipeline-ci-tool.sh nolibs-ocean-only-compile gnu` + + compile:gnu:ice-ocean-nolibs: + `pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu` + + run:pgi: + `pipeline-ci-tool.sh run-suite pgi SNL` + + run:intel: + `pipeline-ci-tool.sh run-suite intel SNL` + + run:gnu: + `pipeline-ci-tool.sh run-suite gnu SNLD` + + run:gnu-restarts: + `pipeline-ci-tool.sh run-suite gnu R` + + t:pgi:symmetric: + `pipeline-ci-tool.sh check-stats pgi S` + + t:pgi:non-symmetric: + `pipeline-ci-tool.sh check-stats pgi N` + + t:pgi:layout: + `pipeline-ci-tool.sh check-stats pgi L` + + t:pgi:params: + `pipeline-ci-tool.sh check-params pgi S` + + t:intel:symmetric: + `pipeline-ci-tool.sh check-stats intel S` + + t:intel:non-symmetric: + `pipeline-ci-tool.sh check-stats intel N` + + t:intel:layout: + `pipeline-ci-tool.sh check-stats intel L` + + t:intel:params: + `pipeline-ci-tool.sh check-params intel S` + + t:gnu:symmetric: + `pipeline-ci-tool.sh check-stats gnu S` + + t:gnu:non-symmetric: + `pipeline-ci-tool.sh check-stats gnu N` + + t:gnu:layout: + `pipeline-ci-tool.sh check-stats gnu L` + + t:gnu:static: + `pipeline-ci-tool.sh check-stats gnu T` + + t:gnu:symmetric-debug: + `pipeline-ci-tool.sh check-stats gnu D` + + t:gnu:restart: + `pipeline-ci-tool.sh check-stats gnu R` + + t:gnu:params: + `pipeline-ci-tool.sh check-params gnu S` + + t:gnu:diags: + `pipeline-ci-tool.sh check-diags gnu S` + +### Duplicating the pipeline interactively + +You can run a sequence of commands as follows. The setup and compile phases of the CI pipeline can be summarized with +``` +pipeline-ci-tool.sh create-job-dir copy-test-space pgi copy-test-space intel copy-test-space gnu copy-test-space gnu-rst mrs-compile repro_pgi mrs-compile repro_intel mrs-compile repro_gnu mrs-compile static_gnu mrs-compile debug_gnu nolibs-ocean-only-compile gnu nolibs-ocean-ice-compile gnu +``` + +The run stage (works on compute nodes only) can be summarized with: +``` +pipeline-ci-tool.sh run-suite pgi SNL run-suite intel SNL run-suite gnu SNLDT run-suite gnu R +``` + +The test stage is summarized by: +``` +pipeline-ci-tool.sh check-stats pgi S check-stats pgi N check-stats pgi L check-params pgi S check-stats intel S check-stats intel N check-stats intel L check-params intel S check-stats gnu S check-stats gnu N check-stats gnu L check-stats gnu T check-stats gnu D check-stats gnu R check-params gnu S check-diags gnu S +``` diff --git a/.gitlab/mom6-ci-run-gnu-restarts-script.sh b/.gitlab/mom6-ci-run-gnu-restarts-script.sh new file mode 100644 index 0000000000..02af3460b4 --- /dev/null +++ b/.gitlab/mom6-ci-run-gnu-restarts-script.sh @@ -0,0 +1,47 @@ +#!/bin/bash + +sect=none +clean_stats () { # fn to clean up stats files + find [oicl]* -name "*.stats.*[a-z][a-z][a-z]" -delete +} +section_start () { # fn to print fold-able banner in CI + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" + sect=$1 +} +section_end () { # fn to close fold-able banner in CI and clean up stats + echo -e "\e[0Ksection_end:`date +%s`:$sect\r\e[0K" + clean_stats +} +check_for_core_files () { + EXIT_CODE=0 + find [oilc]* -name core | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Make sure we have a clean start +clean_stats +find [oilc]* -name core -delete +rm -f .CI-GNU-RESTARTS-BATCH-SUCCESS + +set -e +set -v + +# Run symmetric gnu restart tests +section_start gnu_restarts "Running symmetric gnu restart tests" +time make -f tools/MRS/Makefile.restart gnu_ocean_only -s -j RESTART_STAGE=01 +time make -f tools/MRS/Makefile.restart gnu_ice_ocean_SIS2 -s -j RESTART_STAGE=01 +time make -f tools/MRS/Makefile.restart gnu_ocean_only -s -j RESTART_STAGE=02 +time make -f tools/MRS/Makefile.restart gnu_ice_ocean_SIS2 -s -j RESTART_STAGE=02 +time make -f tools/MRS/Makefile.restart gnu_ocean_only -s -j RESTART_STAGE=12 +time make -f tools/MRS/Makefile.restart gnu_ice_ocean_SIS2 -s -j RESTART_STAGE=12 +tar cf - `find [oilc]*/ -path "*/??.ignore/*" -name "ocean.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_restarts -xf - +check_for_core_files +find [oilc]* -name "*.ignore" -type d -prune -exec rm -rf {} \; +section_end + +# Indicate all went well +touch .CI-GNU-RESTARTS-BATCH-SUCCESS diff --git a/.gitlab/mom6-ci-run-gnu-script.sh b/.gitlab/mom6-ci-run-gnu-script.sh new file mode 100644 index 0000000000..8577eff6d2 --- /dev/null +++ b/.gitlab/mom6-ci-run-gnu-script.sh @@ -0,0 +1,71 @@ +#!/bin/bash + +sect=none +clean_stats () { # fn to clean up stats files + find [oicl]* -name "*.stats.*[a-z][a-z][a-z]" -delete +} +section_start () { # fn to print fold-able banner in CI + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" + sect=$1 +} +section_end () { # fn to close fold-able banner in CI and clean up stats + echo -e "\e[0Ksection_end:`date +%s`:$sect\r\e[0K" + clean_stats +} +check_for_core_files () { + EXIT_CODE=0 + find [oilc]* -name core | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Make sure we have a clean start +clean_stats +find [oilc]* -name core -delete +rm -f .CI-GNU-BATCH-SUCCESS + +set -e +set -v + +# Run symmetric gnu regressions +section_start gnu_all_sym "Running symmetric gnu" +time make -f tools/MRS/Makefile.run gnu_all -s -j +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_sym -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/gnu_params -xf - +check_for_core_files +section_end + +# Run non-symmetric gnu regressions +section_start gnu_all_nonsym "Running nonsymmetric gnu" +time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.gnu +time make -f tools/MRS/Makefile.run gnu_all -s -j MEMORY=dynamic_nonsymmetric +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_nonsym -xf - +check_for_core_files +section_end + +# Run symmetric gnu regressions with alternate layout +section_start gnu_all_layout "Running symmetric gnu with alternate layouts" +time make -f tools/MRS/Makefile.run gnu_all -s -j LAYOUT=alt +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_layout -xf - +check_for_core_files +section_end + +# Run symmetric gnu regressions with debug executable +section_start gnu_ocean_only_debug "Running symmetric gnu_ocean_only with debug executable" +time make -f tools/MRS/Makefile.run gnu_ocean_only -s -j MODE=debug +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_ocean_only_debug -xf - +check_for_core_files +section_end + +# Run symmetric static gnu regressions +section_start gnu_all_static "Running symmetric gnu with static executable" +time make -f tools/MRS/Makefile.run gnu_static_ocean_only MEMORY=static -s -j +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_static -xf - +check_for_core_files +section_end + +# Indicate all went well +touch .CI-GNU-BATCH-SUCCESS diff --git a/.gitlab/mom6-ci-run-intel-script.sh b/.gitlab/mom6-ci-run-intel-script.sh new file mode 100644 index 0000000000..875d60c191 --- /dev/null +++ b/.gitlab/mom6-ci-run-intel-script.sh @@ -0,0 +1,57 @@ +#!/bin/bash + +sect=none +clean_stats () { # fn to clean up stats files + find [oicl]* -name "*.stats.*[a-z][a-z][a-z]" -delete +} +section_start () { # fn to print fold-able banner in CI + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" + sect=$1 +} +section_end () { # fn to close fold-able banner in CI and clean up stats + echo -e "\e[0Ksection_end:`date +%s`:$sect\r\e[0K" + clean_stats +} +check_for_core_files () { + EXIT_CODE=0 + find [oilc]* -name core | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Make sure we have a clean start +clean_stats +find [oilc]* -name core -delete +rm -f .CI-INTEL-BATCH-SUCCESS + +set -e +set -v + +# Run symmetric intel regressions +section_start intel_all_sym "Running symmetric intel" +time make -f tools/MRS/Makefile.run intel_all -s -j +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/intel_all_sym -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/intel_params -xf - +check_for_core_files +section_end + +# Run non-symmetric intel regressions +section_start intel_all_nonsym "Running nonsymmetric intel" +time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.intel -s +time make -f tools/MRS/Makefile.run intel_all -s -j MEMORY=dynamic_nonsymmetric +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/intel_all_nonsym -xf - +check_for_core_files +section_end + +# Run symmetric intel regressions with alternate layout +section_start intel_all_layout "Running symmetric intel with alternate layouts" +time make -f tools/MRS/Makefile.run intel_all -s -j LAYOUT=alt +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/intel_all_layout -xf - +check_for_core_files +section_end + +# Indicate all went well +touch .CI-INTEL-BATCH-SUCCESS diff --git a/.gitlab/mom6-ci-run-pgi-script.sh b/.gitlab/mom6-ci-run-pgi-script.sh new file mode 100644 index 0000000000..27216e4a9f --- /dev/null +++ b/.gitlab/mom6-ci-run-pgi-script.sh @@ -0,0 +1,57 @@ +#!/bin/bash + +sect=none +clean_stats () { # fn to clean up stats files + find [oicl]* -name "*.stats.*[a-z][a-z][a-z]" -delete +} +section_start () { # fn to print fold-able banner in CI + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" + sect=$1 +} +section_end () { # fn to close fold-able banner in CI and clean up stats + echo -e "\e[0Ksection_end:`date +%s`:$sect\r\e[0K" + clean_stats +} +check_for_core_files () { + EXIT_CODE=0 + find [oilc]* -name core | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Make sure we have a clean start +clean_stats +find [oilc]* -name core -delete +rm -f .CI-PGI-BATCH-SUCCESS + +set -e +set -v + +# Run symmetric pgi regressions +section_start pgi_all_sym "Running symmetric pgi" +time make -f tools/MRS/Makefile.run pgi_all -s -j +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/pgi_all_sym -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/pgi_params -xf - +check_for_core_files +section_end + +# Run non-symmetric pgi regressions +section_start pgi_all_nonsym "Running nonsymmetric pgi" +time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.pgi -s +time make -f tools/MRS/Makefile.run pgi_all -s -j MEMORY=dynamic_nonsymmetric +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/pgi_all_nonsym -xf - +check_for_core_files +section_end + +# Run symmetric pgi regressions with alternate layout +section_start pgi_all_layout "Running symmetric pgi with alternate layouts" +time make -f tools/MRS/Makefile.run gnu_all -s -j LAYOUT=alt +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/pgi_all_layout -xf - +check_for_core_files +section_end + +# Indicate all went well +touch .CI-PGI-BATCH-SUCCESS diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh new file mode 100755 index 0000000000..d948b72008 --- /dev/null +++ b/.gitlab/pipeline-ci-tool.sh @@ -0,0 +1,453 @@ +#!/bin/bash + +# Environment variables set by gitlab (the CI environment) +if [ -z $JOB_DIR ]; then + echo Environment variable "$"JOB_DIR should be defined to point to a unique directory for these scripts to use. + echo '$JOB_DIR is derived from $CI_PIPELINE_ID in MOM6/.gitlab-ci.yml' + echo 'To use interactively try:' + echo ' JOB_DIR=tmp' $0 $@ + exit 911 +fi +if [ -z $CI_PROJECT_DIR ]; then + echo Environment variable "$"CI_PROJECT_DIR should be defined and point to where gitlab has cloned the MOM6 repository for this pipeline. + echo 'To use interactively try:' + echo ' CI_PROJECT_DIR=.' $0 $@ + exit 911 +else + CI_PROJECT_DIR=`realpath $CI_PROJECT_DIR` +fi +if [ -z $CI_COMMIT_SHA ]; then + echo Environment variable "$"CI_COMMIT_SHA should be defined and indicate the MOM6 commit to used in this pipeline. + echo 'To use interactively try:' + echo ' CI_COMMIT_SHA=`git rev-parse HEAD`' $0 $@ + exit 911 +fi + +# Use CI=true to enable the gitlab folding + +set -e # Stop if we encounter an error + +# Environment variables that can be set outside +STATS_REPO_URL="${STATS_REPO_URL:-https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git}" +STATS_REPO_BRANCH="${STATS_REPO_BRANCH:-dev/gfdl}" +CONFIGS_DIR="${CONFIGS_DIR:-MOM6-examples}" +CONFIGS_REPO_BRANCH="${CONFIGS_REPO_BRANCH:-$STATS_REPO_BRANCH}" + +# Global variables derived from the above +DRYRUN= +STATS_REPO=$(basename $STATS_REPO_URL) +STATS_REPO_DIR=$(basename $STATS_REPO .git) + +# Static variables +RED=$'\033[1;31m' +GRN=$'\033[1;32m' +OFF=$'\e[m' + +# Print the start of a fold in the log +section-start () { + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" +} + +# Print the start of a fold in the log but not collapsed +section-start-open () { + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=false]\r\e[0K$2" +} + +# Print the end of a fold in the log +section-end () { + echo -e "\e[0Ksection_end:`date +%s`:$1\r\e[0K" +} + +# Create $JOB_DIR and clean out any prior work-spaces +# Location: run in MOM6 directory +clean-job-dir () { + section-start clean-job-dir "Cleaning $JOB_DIR directory" + if [ ! $DRYRUN ] ; then + #NOT USED? cd $CI_PROJECT_DIR + #NOT USED? git submodule init ; git submodule update + echo Job directory set to $JOB_DIR + mkdir -p $JOB_DIR + cd $JOB_DIR + test -d $STATS_REPO_DIR && rm -rf $STATS_REPO_DIR # In case we are re-running this stage + fi + section-end clean-job-dir +} + +# Create the full work space starting at the regression repository (usually Gaea-stats-MOM6-examples) +# Location: run in MOM6 directory +create-job-dir () { + section-start create-job-dir "Creating and populating $JOB_DIR" + if [ ! $DRYRUN ] ; then + mkdir -p $JOB_DIR + cd $JOB_DIR + git clone $STATS_REPO_URL $STATS_REPO_DIR + cd $STATS_REPO_DIR + git checkout $STATS_REPO_BRANCH + git submodule update --init + cd $CONFIGS_DIR + git checkout $CONFIGS_REPO_BRANCH + git submodule init + git submodule set-url src/MOM6 $CI_PROJECT_DIR/.git + git submodule update --recursive --jobs 8 + (cd src/MOM6 ; git checkout $CI_COMMIT_SHA) # Get commit to be tested + (cd src/MOM6 ; git submodule update --recursive --init) + make -f tools/MRS/Makefile.clone clone_gfdl -j # Extras and link to datasets + bash tools/MRS/generate_manifest.sh . tools/MRS/excluded-expts.txt > manifest.mk + mkdir -p results + # Temporarily move build directory to $HOME to circumvent poor F5 performance + mkdir -p $HOME/ci/$CI_PIPELINE_ID/build + ln -s $HOME/ci/$CI_PIPELINE_ID/build build + # Builds need non-mangled access to src/. + ln -s "$(pwd)"/src $HOME/ci/$CI_PIPELINE_ID/src + # Static builds need access to ocean_only/ + ln -s "$(pwd)"/ocean_only $HOME/ci/$CI_PIPELINE_ID/ocean_only + fi + section-end create-job-dir +} + +# Create a copy of the configurations working directory +# Location: run in MOM6 directory +copy-test-space () { + if [ -z $1 ]; then echo "copy-test-space needs an argument" ; exit 911 ; fi + section-start copy-test-space-$1 "Copying $CONFIGS_DIR for $1" + if [ ! $DRYRUN ] ; then + COPIED_DIR=tmp-$CONFIGS_DIR-$1 + cd $JOB_DIR/$STATS_REPO_DIR + git clone -s $CONFIGS_DIR/.git $COPIED_DIR + cd $COPIED_DIR + ln -s ../$CONFIGS_DIR/{build,results,.datasets} . + cp ../$CONFIGS_DIR/manifest.mk . + fi + section-end copy-test-space-$1 +} + +# Build a group of executables using the tools/MRS/Makefile.build template +# Location: run in MOM6 directory +mrs-compile () { + if [ -z $1 ]; then echo "mrs-compile needs an argument" ; exit 911 ; fi + section-start mrs-compile-$1 "Compiling target $1" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + time make -f tools/MRS/Makefile.build $1 -s -j + fi + section-end mrs-compile-$1 +} + +# Build an ocean-only executable without intermediate libraries +# Location: run in MOM6 directory +nolibs-ocean-only-compile () { + if [ -z $1 ]; then echo "nolibs-ocean-only-compile needs an argument" ; exit 911 ; fi + section-start nolibs-ocean-only-compile-$1 "Compiling ocean-only $1 executable" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + mkdir -p build-ocean-only-nolibs-$1 + cd build-ocean-only-nolibs-$1 + make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. ENVIRON=../../environ -s + ../src/mkmf/bin/list_paths -l ../src/MOM6/config_src/{drivers/solo_driver,memory/dynamic_symmetric,infra/FMS1,ext*} ../src/MOM6/src ../src/FMS1 + sed -i '/FMS1\/.*\/test_/d' path_names + ../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc5-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names + (source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + fi + section-end nolibs-ocean-only-compile-$1 +} + +# Build an ocean-ice executable without intermediate libraries +# Location: run in MOM6 directory +nolibs-ocean-ice-compile () { + if [ -z $1 ]; then echo "nolibs-ocean-ice-compile needs an argument" ; exit 911 ; fi + section-start nolibs-ocean-ice-compile-$1 "Compiling ocean-ice $1 executable" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + mkdir -p build-ocean-ice-nolibs-$1 + cd build-ocean-ice-nolibs-$1 + make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. ENVIRON=../../environ -s + ../src/mkmf/bin/list_paths -l ../src/MOM6/config_src/{drivers/FMS_cap,memory/dynamic_symmetric,infra/FMS1,ext*} ../src/MOM6/src ../src/SIS2/*src ../src/icebergs/src ../src/{FMS1,coupler,ice_param,land_null,atmos_null} + sed -i '/FMS1\/.*\/test_/d' path_names + ../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc5-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names + (source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + fi + section-end nolibs-ocean-ice-compile-$1 +} + +# Internal function to clean up stats files +# Args: list of top level directories to scan +clean-stats () { + find $@ -name "*.stats.*[a-z][a-z][a-z]" -delete +} + +# Internal function to clean up param files +# Args: list of top level directories to scan +clean-params () { + find $@ -name "*_parameter_doc.*" -delete + find $@ -name "*available_diags*" -delete +} + +# Internal function to check for core files +# Args: list of top level directories to scan +check-for-core-files () { + EXIT_CODE=0 + find $@ -name core -type f | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Internal function to clean up core files (needed for re-running) +# Args: list of top level directories to scan +clean-core-files () { + find $@ -name core -type f -delete +} + +# Internal function to run a sub-suite and copy results to storage +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +# $2 is sub-suite (_all, _ocean_only, _static_ocean_only, ...) +# $3 is MEMORY macro (dynamic_symmetric, dynamic_nonsymmetric, static) +# $4 is MODE macro (repro, debug) +# $5 is LAYOUT macro (def, alt) +mrs-run-sub-suite () { + if [ "$#" -ne 5 ]; then echo "mrs-run-sub-suite needs 5 arguments" ; exit 911 ; fi + section-start mrs-run-sub-suite-$1-$2-$3-$4-$5 "Running target $1-$2-$3-$4-$5" + EXP_GROUPS=`grep / manifest.mk | sed 's:/.*::' | uniq` + clean-stats $EXP_GROUPS + clean-params $EXP_GROUPS + clean-core-files $EXP_GROUPS + if [[ "$3" == *"_nonsym"* ]]; then + set -e + time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.$1 MEMORY=${3/_nonsym/_sym} MODE=$4 LAYOUT=$5 -s -j + fi + set -e + time make -f tools/MRS/Makefile.run $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j + tar cf - `find $EXP_GROUPS -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/$1-$2-$3-$4-$5-stats -xf - + tar cf - `find $EXP_GROUPS -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/$1-$2-$3-$4-$5-params -xf - + check-for-core-files $EXP_GROUPS + section-end mrs-run-sub-suite-$1-$2-$3-$4-$5 +} + +# Internal function to run restarts on a sub-suite and copy results to storage +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +# $2 is sub-suite (_all, _ocean_only, _static_ocean_only, ...) +# $3 is MEMORY macro (dynamic_symmetric, dynamic_nonsymmetric, static) +# $4 is MODE macro (repro, debug) +# $5 is LAYOUT macro (def, alt) +mrs-run-restarts-sub-suite () { + if [ "$#" -ne 5 ]; then echo "mrs-run-restarts-sub-suite needs 5 arguments" ; exit 911 ; fi + section-start mrs-run-restarts-sub-suite-$1-$2-$3-$4-$5 "Running target $1-$2-$3-$4-$5" + clean-stats $2 + clean-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=01 + check-for-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=02 + check-for-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=12 + check-for-core-files $2 + section-end mrs-run-restarts-sub-suite-$1-$2-$3-$4-$5 +} + +# Run a suite of experiments +# $1 - compiler brand +# $2 - any combination of "SNLDTR" +# S = symmetric +# N = non-symmetric +# L = layout +# D = debug +# R = restarts +run-suite () { + if [ "$#" -ne 2 ]; then echo "run-suite needs 2 arguments" ; exit 911 ; fi + section-start run-suite-$1-$2 "Running suite for $1-$2" + WORK_DIR=tmp-$CONFIGS_DIR-$1 + rm -f $JOB_DIR/CI-BATCH-SUCCESS-$1-$2 + set -e + set -v + + pushd $JOB_DIR/$STATS_REPO_DIR/$WORK_DIR > /dev/null + if [[ "$2" =~ "S" ]]; then # Symmetric + mrs-run-sub-suite $1 all dynamic_symmetric repro def + fi + if [[ "$2" =~ "N" ]]; then # Non-symmetric + mrs-run-sub-suite $1 all dynamic_nonsymmetric repro def + fi + if [[ "$2" =~ "L" ]]; then # Layout + mrs-run-sub-suite $1 all dynamic_symmetric repro alt + fi + if [[ "$2" =~ "D" ]]; then # Debug + mrs-run-sub-suite $1 ocean_only dynamic_symmetric debug def + fi + if [[ "$2" =~ "T" ]]; then # sTatic + mrs-run-sub-suite $1 static_ocean_only static repro def + fi + popd > /dev/null + if [[ "$2" =~ "R" ]]; then # Restarts + pushd $JOB_DIR/$STATS_REPO_DIR/$WORK_DIR-rst > /dev/null + mrs-run-restarts-sub-suite $1 ocean_only dynamic_symmetric repro def + mrs-run-restarts-sub-suite $1 ice_ocean_SIS2 dynamic_symmetric repro def + popd > /dev/null + fi + + # Indicate all went well + touch $JOB_DIR/CI-BATCH-SUCCESS-$1-$2 + + section-end run-suite-$1-$2 +} + +# Test the value of stats files. All files in results/ are checked for in regressions/. It is assumed +# missing files are intended and failed runs were caught earlier in the CI process. +# Args: +# $1 is path of results to test (relative to $STATS_REPO_DIR) +# $2 is path of correct results to test against (relative to $STATS_REPO_DIR) +compare-stats () { + if [ "$#" -ne 2 ]; then echo "compare-stats needs 2 arguments" ; exit 911 ; fi + section-start-open compare-stats-$1-$2-$3-$4-$5 "Checking stats for '$1' against '$2'" + # This checks that any file in the results directory is exactly the same as in regressions/ + ( cd $JOB_DIR/$STATS_REPO_DIR/$1 ; md5sum `find * -type f` ) | ( cd $JOB_DIR/$STATS_REPO_DIR/$2 ; md5sum -c ) 2>&1 | sed "s/ OK/$GRN&$OFF/;s/ FAILED/$RED&$OFF/;s/WARNING/$RED&$OFF/" + FAIL=${PIPESTATUS[1]} + if [ ! $FAIL == 0 ]; then + exit 911 + fi + section-end compare-stats-$1-$2-$3-$4-$5 +} + +# Test the value of stats files for a class of run +# $1 - compiler brand +# $2 - any combination of "SNLDTR" +# S = symmetric +# N = non-symmetric +# L = layout +# D = debug +# T = static +# R = restarts +# +# Many tests are tested against the "dynamic_symmetric repro" suite which must also have been run. +# The "dynamic_symmetric repro" tests alone are checked against the regressions. This is so that +# the pipelines might separate errors that are internally inconsistent. +check-stats () { + if [ "$#" -ne 2 ]; then echo "check-stats needs 2 arguments" ; exit 911 ; fi + + if [[ "$2" =~ "S" ]]; then # Symmetric + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats regressions + fi + if [[ "$2" =~ "N" ]]; then # Non-symmetric + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_nonsymmetric-repro-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "L" ]]; then # Layout + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-alt-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "D" ]]; then # Debug + compare-stats $CONFIGS_DIR/results/$1-ocean_only-dynamic_symmetric-debug-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "T" ]]; then # sTatic + compare-stats $CONFIGS_DIR/results/$1-static_ocean_only-static-repro-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "R" ]]; then # Restarts + pushd $JOB_DIR/$STATS_REPO_DIR/tmp-$CONFIGS_DIR-$1-rst > /dev/null + make -f tools/MRS/Makefile.restart restart_$1_ocean_only restart_$1_ice_ocean_SIS2 -s -k + popd > /dev/null + fi + +} + +# Helper function to compare two files +# Args: +# $1 is source directory +# $2 is target directory +# $3- are file names that should exist relative to both $1 and $2 +# +# Operations for `compare-files src/ tgt/ file1 file2 file3`: +# 1. create the md5sum of file1, file2, and file3, in src/ and then run `md5sum-c` in tgt/ +# 2. if differences are detected, +# a. report the "OK" results first, then the "FAILED". +# b. report the "FAILED". +# c. for each failed file, show the `diff src/$f tgt/$f` +# 3. if no differences are detected, show `md5sum -c` output so the log lists all files that were checked +compare-files () { + SRC=$1 + TGT=$2 + shift; shift + FILES=$@ + ( cd $SRC ; md5sum $FILES ) | ( cd $TGT ; md5sum -c ) | sed -r "s/([A-Za-z0-9_\.\/\-]*): ([A-Z]*)/\2 \1/;s/OK /${GRN}PASS$OFF /;s/FAILED /${RED}FAILED$OFF /" + FAIL=${PIPESTATUS[1]} + if [ ! $FAIL == 0 ]; then + echo Differences follow: + # All is not well so re-order md5sum to summarize status + DFILES=$( ( cd $SRC ; md5sum $FILES ) | ( cd $TGT ; md5sum -c 2> /dev/null ) | grep ": FAILED" | sed 's/:.*//') + for f in $DFILES; do + echo diff $SRC/$f $TGT/$f | sed "s:$JOB_DIR/$STATS_REPO_DIR/::g;s:$CONFIGS_DIR/results/::" + diff $SRC/$f $TGT/$f || true + done + echo Files $DFILES had differences + exit 911 + fi +} + +# Test the value of param files. All files generated in results/ are looked for $CONFIGS_DIR +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +check-params () { + if [ "$#" -ne 1 ]; then echo "check-params needs 1 argument" ; exit 911 ; fi + section-start-open check-params-$1 "Checking params for $1" + SRC=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-params + FILES=$( cd $SRC ; find * -name "*parameter_doc*" -type f ) + compare-files $SRC $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR $FILES + section-end check-params-$1 +} + +# Test the value of available_diag files. Only those recorded in $CONFIGS_DIR are checked. +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +check-diags () { + if [ "$#" -ne 1 ]; then echo "check-diags needs 1 argument" ; exit 911 ; fi + section-start-open check-diags-$1 "Checking diagnostics for $1" + # This checks that any file in the results directory is exactly the same as in regressions/ + SRC=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-params + TGT=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + EXP_GROUPS=`grep / $TGT/manifest.mk | sed 's:/.*::' | uniq` + #FILES=$( cd $TGT ; find $EXP_GROUPS -name "*available_diags*" -type f ) + # The following option finds the intersection between all available_diags in both $TGT and $SRC because + # $SRC contains more than are recorded in $TGT but $TGT might have some that we no longer monitor + FILES=$( comm -12 <(cd $SRC; find $EXP_GROUPS -name '*available_diags*' -type f | sort) <(cd $TGT; find $EXP_GROUPS -name '*available_diags*' -type f | sort) ) + compare-files $SRC $TGT $FILES + section-end check-diags-$1 +} + +# Process command line +START_DIR=`pwd` +while [[ $# -gt 0 ]]; do # Loop through arguments + cd $START_DIR + arg=$1 + shift + case "$arg" in + -n | --norun) + DRYRUN=1; echo Dry-run enabled; continue ;; + +n | ++norun) + DRYRUN=; echo Dry-run disabled; continue ;; + -x) + set -x; continue ;; + +x) + set +x; continue ;; + clean-job-dir) + clean-job-dir; continue ;; + create-job-dir) + create-job-dir https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git dev/gfdl; continue ;; + copy-test-space) + copy-test-space $1; shift; continue ;; + mrs-compile) + mrs-compile $1; shift; continue ;; + nolibs-ocean-only-compile) + nolibs-ocean-only-compile $1; shift; continue ;; + nolibs-ocean-ice-compile) + nolibs-ocean-ice-compile $1; shift; continue ;; + run-suite) + run-suite $1 $2; shift; shift; continue ;; + check-stats) + check-stats $1 $2; shift; shift; continue ;; + check-params) + check-params $1; shift; continue ;; + check-diags) + check-diags $1; shift; continue ;; + *) + echo \"$arg\" is not a recognized argument! ; exit 9 ;; + esac +done diff --git a/.gitmodules b/.gitmodules index b499e43096..872100b62c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,12 +1,6 @@ [submodule "pkg/CVMix-src"] path = pkg/CVMix-src - url = https://github.com/CVMix/CVMix-src.git + url = https://github.com/mom-ocean/CVMix-src.git [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran - url = https://github.com/TEOS-10/GSW-Fortran.git -[submodule "pkg/MOM6_DA_hooks"] - path = pkg/MOM6_DA_hooks - url = https://github.com/MJHarrison-GFDL/MOM6_DA_hooks.git -[submodule "pkg/geoKdTree"] - path = pkg/geoKdTree - url = https://github.com/travissluka/geoKdTree.git + url = https://github.com/mom-ocean/GSW-Fortran.git diff --git a/.readthedocs.yml b/.readthedocs.yml index b95a9b901f..4fe8d6300d 100644 --- a/.readthedocs.yml +++ b/.readthedocs.yml @@ -1,11 +1,23 @@ -# don't build extra formats (like HTML zip) -formats: - - none +# Read the Docs configuration file for Sphinx projects +# See https://docs.readthedocs.io/en/stable/config-file/v2.html for details -# path to pip requirements file to bring in -# doxygen extensions -requirements_file: docs/requirements.txt +# Required +version: 2 + +build: + os: ubuntu-22.04 + tools: + python: "3.11" + +# Extra formats +# PDF generation is failing for now; disabled on 2020-12-02 +#formats: +# - pdf + +# Build documentation +sphinx: + configuration: docs/conf.py python: - # make sure we're using Python 3 - version: 3.5 + install: + - requirements: docs/requirements.txt diff --git a/.testing/.gitignore b/.testing/.gitignore new file mode 100644 index 0000000000..488edabfe8 --- /dev/null +++ b/.testing/.gitignore @@ -0,0 +1,6 @@ +# Test output +/config.mk +/build/ +/work/ +/results/ +/deps/ diff --git a/.testing/Makefile b/.testing/Makefile index ee561375a3..085fea2655 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -1,77 +1,831 @@ -# Makefile steps to run on Travis-CI -# e.g. make MEMORY_SHAPE=dynamic_symmetric REPRO=1 OPENMP=1 +# MOM6 Test suite Makefile +# +# Usage: +# make -j +# Build the FMS library and test executables +# +# make -j test +# Run the test suite, defined in the `tc` directores. +# +# make clean +# Delete the MOM6 test executables and dependency builds (FMS) +# +# make clean.build +# Delete only the MOM6 test executables +# +# +# Configuration: +# These settings can be provided as either command-line flags, or saved in a +# `config.mk` file. +# +# General test configuration: +# MPIRUN MPI job launcher (mpirun, srun, etc) +# DO_REPRO_TESTS Enable production ("repro") testing equivalence +# DO_REGRESSION_TESTS Enable regression tests (usually dev/gfdl) +# DO_COVERAGE Enable code coverage and generate .gcov reports +# DO_PROFILE Enable performance profiler comparison tests +# REQUIRE_CODECOV_UPLOAD Abort as error if upload to codecov.io fails. +# +# Compiler configuration: +# CC C compiler +# MPICC MPI C compiler +# FC Fortran compiler +# MPIFC MPI Fortran compiler +# (NOTE: These are environment variables and may be inherited from a shell.) +# +# Build configuration: +# FCFLAGS_DEBUG Testing ("debug") compiler flags +# FCFLAGS_REPRO Production ("repro") compiler flags +# FCFLAGS_OPT Aggressive optimization compiler flags +# FCFLAGS_INIT Variable initialization flags +# FCFLAGS_COVERAGE Code coverage flags +# FCFLAGS_FMS FMS build flags (default: FCFLAGS_DEBUG) +# +# LDFLAGS_COVERAGE Linker coverage flags +# LDFLAGS_USER User-defined linker flags (used for all MOM/FMS builds) +# +# Experiment Configuration: +# EXECS Executables to be built by `make` or `make all` +# CONFIGS Model configurations to test (default: `tc*`) +# DIMS Dimensional scaling tests +# TESTS Tests to run +# +# Regression repository ("target") configuration: +# MOM_TARGET_SLUG URL slug (minus domain) of the target repo +# MOM_TARGET_URL Full URL of the target repo +# MOM_TARGET_LOCAL_BRANCH Target branch name +# (NOTE: These would typically be configured by a CI.) +# +# Output paths: +# BUILD Compiled executables and libraries +# DEPS Compiled dependencies +# WORK Test model output -# Versions to use -FMS_COMMIT ?= xanadu -MKMF_COMMIT ?= master +# TODO: POSIX shell compatibility +SHELL = bash + +# No implicit rules, suffixes, or variables +MAKEFLAGS += -rR + +# Determine the MOM6 autoconf srcdir +AC_SRCDIR := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))../ac -# Where to clone from +# User-defined configuration +-include config.mk + +# Set the FMS library +FMS_COMMIT ?= 2023.03 FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -MKMF_URL ?= https://github.com/NOAA-GFDL/mkmf.git -CONFIGS_URL ?= https://github.com/NOAA-GFDL/MOM6-examples.git -REGRESSIONS_URL ?= https://github.com/adcroft/Gaea-stats-MOM6-examples +export FMS_COMMIT +export FMS_URL + +# Set the MPI launcher here +# TODO: This needs more automated configuration +MPIRUN ?= mpirun + +# Generic compiler variables are pass through to the builds +export CC +export MPICC +export FC +export MPIFC + +# Builds are distinguished by FCFLAGS +FCFLAGS_DEBUG ?= -g -O0 +FCFLAGS_REPRO ?= -g -O2 +FCFLAGS_OPT ?= -g -O3 -mavx -fno-omit-frame-pointer +FCFLAGS_INIT ?= +FCFLAGS_COVERAGE ?= -g -O0 -fbacktrace --coverage +FCFLAGS_FMS ?= $(FCFLAGS_DEBUG) +# Additional notes: +# - These default values are simple, minimalist flags, supported by nearly all +# compilers, and are somewhat analogous to GFDL's DEBUG and REPRO builds. +# +# - These flags can be configured outside of the Makefile, either with +# config.mk or as environment variables. + +LDFLAGS_COVERAGE ?= --coverage +LDFLAGS_USER ?= + +# Set to verify identical DEBUG and REPRO results +DO_REPRO_TESTS ?= + +# Enable profiling +DO_PROFILE ?= + +# Enable code coverage runs +DO_COVERAGE ?= + +# Enable unit tests +DO_UNIT_TESTS ?= + +# Check for regressions with target branch +DO_REGRESSION_TESTS ?= + +# Report failure if coverage report is not uploaded +REQUIRE_COVERAGE_UPLOAD ?= + +# Print logs if an error is encountered +REPORT_ERROR_LOGS ?= + +# Time measurement (configurable by the CI) +TIME ?= time + +# Legacy external work directory +#WORKSPACE ?= +WORKSPACE ?= . + +# Set directories for build/ and work/ +BUILD ?= $(WORKSPACE)/build +DEPS ?= $(BUILD)/deps +WORK ?= $(WORKSPACE)/work + +# Experiment configuration +EXECS ?= symmetric/MOM6 asymmetric/MOM6 openmp/MOM6 +CONFIGS ?= $(wildcard tc*) +DIMS ?= t l h z q r +TESTS ?= grid layout rotate restart openmp nan $(foreach d,$(DIMS),dim.$(d)) + +# Unit test executables +UNIT_EXECS ?= \ + $(basename $(notdir $(wildcard ../config_src/drivers/unit_tests/*.F90))) + +# Timing test executables +TIMING_EXECS ?= \ + $(basename $(notdir $(wildcard ../config_src/drivers/timing_tests/*.F90))) + + +#--- +# Test configuration + +# Set if either DO_COVERAGE or DO_UNIT_TESTS is set +run_unit_tests = + +# REPRO and DEBUG equivalence +ifdef DO_REPRO_TESTS + EXECS += repro/MOM6 + TESTS += repro +endif + +# Profiling +ifdef DO_PROFILE + EXECS += opt/MOM6 opt_target/MOM6 +endif + +# Coverage +ifdef DO_COVERAGE + EXECS += cov/MOM6 + run_unit_execs = yes +endif + +# Unit test executables +ifdef DO_UNIT_TESTS + run_unit_tests = yes +endif + +# If either coverage or unit tests are enabled, build the unit test execs +ifdef run_unit_tests + EXECS += $(foreach e, $(UNIT_EXECS), unit/$(e)) +endif + +# Regression testing +ifdef DO_REGRESSION_TESTS + EXECS += target/MOM6 + TESTS += regression + + MOM_TARGET_SLUG ?= NOAA-GFDL/MOM6 + MOM_TARGET_URL ?= https://github.com/$(MOM_TARGET_SLUG) + + MOM_TARGET_LOCAL_BRANCH ?= dev/gfdl + MOM_TARGET_BRANCH := origin/$(MOM_TARGET_LOCAL_BRANCH) -# Experiments to run -ifeq ($(MEMORY_SHAPE),"dynamic_symmetric") -EXPERIMENTS ?= unit_tests double_gyre flow_downslope/z CVmix_SCM_tests/cooling_only/EPBL circle_obcs + TARGET_CODEBASE = $(BUILD)/target_codebase else -EXPERIMENTS ?= unit_tests double_gyre flow_downslope/z CVmix_SCM_tests/cooling_only/EPBL + MOM_TARGET_URL = + MOM_TARGET_BRANCH = + TARGET_CODEBASE = endif -FMS_PACKAGES ?= platform,include,memutils,constants,mpp,fms,time_manager,diag_manager,data_override,coupler/coupler_types.F90,coupler/ensemble_manager.F90,axis_utils,horiz_interp,time_interp,astronomy,mosaic,random_numbers -TEMPLATE ?= .testing/linux-ubuntu-xenial-gnu.mk -MPIRUN ?= mpirun -# MEMORY_SHAPE must be defined for this Makefile to work -MEMORY_SHAPE ?= dynamic_symmetric +## Rules -# Everything above is above is "configurable" with environment variables -SHELL = bash +.PHONY: all build.regressions build.prof +all: $(foreach b,$(EXECS),$(BUILD)/$(b)) +build.regressions: $(foreach b,symmetric target,$(BUILD)/$(b)/MOM6) +build.prof: $(foreach b,opt opt_target,$(BUILD)/$(b)/MOM6) -# Path where executable will be built -BUILD_PATH = build -###/$(MEMORY_SHAPE)-$(EXEC_MODE) -# Root of configurations (MOM6-examples) -EXPERIMENTS_ROOT = experiments -# Regression results -REGRESSIONS_ROOT = answers +# Executable +.PRECIOUS: $(foreach b,$(EXECS),$(BUILD)/$(b)) -.PRECIOUS: %/ocean.stats -run: $(foreach e,$(EXPERIMENTS),$(EXPERIMENTS_ROOT)/ocean_only/$(e)/ocean.stats) +# Compiler flags -test: $(foreach e,$(EXPERIMENTS),$(REGRESSIONS_ROOT)/regressions/ocean_only/$(e)/ocean.stats.gnu) +# .testing dependencies +# TODO: We should probably build TARGET with the FMS that it was configured +# to use. But for now we use the same FMS over all builds. +FCFLAGS_DEPS = -I$(abspath $(DEPS)/include) +LDFLAGS_DEPS = -L$(abspath $(DEPS)/lib) +PATH_DEPS = PATH="${PATH}:$(abspath $(DEPS)/bin)" -compile: $(BUILD_PATH)/MOM6 -$(BUILD_PATH)/MOM6: FMS mkmf - mkdir -p $(@D) - cd $(@D); \ - ../mkmf/bin/list_paths -l ../FMS/{$(FMS_PACKAGES)} ../config_src/{$(MEMORY_SHAPE),solo_driver} ../src \ - && ../mkmf/bin/mkmf -t ../$(TEMPLATE) -c '-Duse_libMPI -Duse_netCDF -DSPMD -DUSE_LOG_DIAG_FIELD_INFO -DMAXFIELDMETHODS_=500' -p $(@F) path_names \ - && make -j NETCDF=3 $(@F) +# Define the build targets in terms of the traditional DEBUG/REPRO/etc labels +SYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" +ASYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" +REPRO_FCFLAGS := FCFLAGS="$(FCFLAGS_REPRO) $(FCFLAGS_DEPS)" +OPT_FCFLAGS := FCFLAGS="$(FCFLAGS_OPT) $(FCFLAGS_DEPS)" +OPENMP_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" +TARGET_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" +COV_FCFLAGS := FCFLAGS="$(FCFLAGS_COVERAGE) $(FCFLAGS_DEPS)" + +MOM_LDFLAGS := LDFLAGS="$(LDFLAGS_DEPS) $(LDFLAGS_USER)" +COV_LDFLAGS := LDFLAGS="$(LDFLAGS_COVERAGE) $(LDFLAGS_DEPS) $(LDFLAGS_USER)" + + +# Environment variable configuration +MOM_ENV := $(PATH_FMS) +$(BUILD)/symmetric/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/asymmetric/Makefile: MOM_ENV += $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) \ + MOM_MEMORY=$(AC_SRCDIR)/../config_src/memory/dynamic_nonsymmetric/MOM_memory.h +$(BUILD)/repro/Makefile: MOM_ENV += $(REPRO_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/openmp/Makefile: MOM_ENV += $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/target/Makefile: MOM_ENV += $(TARGET_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/opt/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/opt_target/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/coupled/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/nuopc/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/cov/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +$(BUILD)/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +$(BUILD)/timing/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) + +# Configure script flags +$(BUILD)/openmp/Makefile: MOM_ACFLAGS += --enable-openmp +$(BUILD)/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap +$(BUILD)/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap +$(BUILD)/unit/Makefile: MOM_ACFLAGS += --with-driver=unit_tests +$(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests + + +# Build executables +.NOTPARALLEL:$(foreach e,$(UNIT_EXECS),$(BUILD)/unit/$(e)) +$(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j +$(BUILD)/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) + +.NOTPARALLEL:$(foreach e,$(TIMING_EXECS),$(BUILD)/timing/$(e)) +$(BUILD)/timing/time_%: $(BUILD)/timing/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j +$(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) + +$(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j + +# Target codebase should use its own build system +$(BUILD)/target/MOM6: $(BUILD)/target FORCE | $(TARGET_CODEBASE) + $(MAKE) -C $(TARGET_CODEBASE)/.testing build/symmetric/MOM6 + +$(BUILD)/target: | $(TARGET_CODEBASE) + ln -s $(abspath $(TARGET_CODEBASE))/.testing/build/symmetric $@ + +FORCE: + + +## Use autoconf to construct the Makefile for each target +# TODO: This could all be moved to a top-level MOM6 Makefile +.PRECIOUS: $(BUILD)/%/Makefile +.PRECIOUS: $(BUILD)/%/Makefile.in +.PRECIOUS: $(BUILD)/%/configure +.PRECIOUS: $(BUILD)/%/config.status +.PRECIOUS: $(BUILD)/%/configure.ac +.PRECIOUS: $(BUILD)/%/m4/ + +$(BUILD)/%/Makefile: $(BUILD)/%/Makefile.in $(BUILD)/%/config.status + cd $(@D) && ./config.status + +$(BUILD)/%/config.status: $(BUILD)/%/configure $(DEPS)/lib/libFMS.a + cd $(@D) && $(MOM_ENV) ./configure -n --srcdir=$(AC_SRCDIR) $(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) + +ALL_EXECS = symmetric asymmetric repro openmp opt opt_target coupled nuopc \ + cov unit timing +$(foreach b,$(ALL_EXECS),$(BUILD)/$(b)/): + mkdir -p $@ + +# Fetch the regression target codebase +$(TARGET_CODEBASE): + git clone --recursive $(MOM_TARGET_URL) $@ + cd $@ && git checkout --recurse-submodules $(MOM_TARGET_BRANCH) + + +## FMS + +# Set up the FMS build environment variables +FMS_ENV = \ + PATH="${PATH}:$(realpath ../ac)" \ + FCFLAGS="$(FCFLAGS_FMS)" \ + 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 + +$(DEPS)/Makefile: ../ac/deps/Makefile | $(DEPS) + cp ../ac/deps/Makefile $(DEPS)/Makefile + +$(DEPS)/Makefile.fms.in: ../ac/deps/Makefile.fms.in | $(DEPS) + cp ../ac/deps/Makefile.fms.in $(DEPS)/Makefile.fms.in + +$(DEPS)/configure.fms.ac: ../ac/deps/configure.fms.ac | $(DEPS) + cp ../ac/deps/configure.fms.ac $(DEPS)/configure.fms.ac + +$(DEPS)/m4: ../ac/deps/m4 | $(DEPS) + cp -r ../ac/deps/m4 $(DEPS)/ + +$(DEPS): + mkdir -p $(DEPS) + +#--- +# Verify that the coupled model drivers can be compiled. This does not verify +# that they can be run, since it would require external submodels. + +# NUOPC driver +$(BUILD)/nuopc/mom_ocean_model_nuopc.o: $(BUILD)/nuopc/Makefile + cd $(@D) && make $(@F) +check_mom6_api_nuopc: $(BUILD)/nuopc/mom_ocean_model_nuopc.o + +# GFDL coupled driver +$(BUILD)/coupled/ocean_model_MOM.o: $(BUILD)/coupled/Makefile + cd $(@D) && make $(@F) +check_mom6_api_coupled: $(BUILD)/coupled/ocean_model_MOM.o + + +## Testing -$(EXPERIMENTS_ROOT)/%/ocean.stats: $(EXPERIMENTS_ROOT) +.PHONY: test +test: $(foreach t,$(TESTS),test.$(t)) + +# NOTE: We remove tc3 (OBC) from grid test since it cannot run asymmetric grids + +# NOTE: rotation diag chksum disabled since we cannot yet compare rotationally +# equivalent diagnostics + +# TODO: restart checksum comparison is not yet implemented + +.PHONY: $(foreach t,$(TESTS),test.$(t)) +test.grid: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(c).grid $(c).grid.diag) +test.layout: $(foreach c,$(CONFIGS),$(c).layout $(c).layout.diag) +test.rotate: $(foreach c,$(CONFIGS),$(c).rotate) +test.restart: $(foreach c,$(CONFIGS),$(c).restart) +test.repro: $(foreach c,$(CONFIGS),$(c).repro $(c).repro.diag) +test.openmp: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) +test.nan: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) +test.regression: $(foreach c,$(CONFIGS),$(c).regression $(c).regression.diag) +test.dim: $(foreach d,$(DIMS),test.dim.$(d)) +define TEST_DIM_RULE +test.dim.$(1): $(foreach c,$(CONFIGS),$(c).dim.$(1) $(c).dim.$(1).diag) +endef +$(foreach d,$(DIMS),$(eval $(call TEST_DIM_RULE,$(d)))) + +.PHONY: run.symmetric run.asymmetric run.nans run.openmp run.cov +run.symmetric: $(foreach c,$(CONFIGS),$(WORK)/$(c)/symmetric/ocean.stats) +run.asymmetric: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(CONFIGS),$(WORK)/$(c)/asymmetric/ocean.stats) +run.nan: $(foreach c,$(CONFIGS),$(WORK)/$(c)/nan/ocean.stats) +run.openmp: $(foreach c,$(CONFIGS),$(WORK)/$(c)/openmp/ocean.stats) +run.cov: $(foreach c,$(CONFIGS),$(WORK)/$(c)/cov/ocean.stats) + +# Configuration test rules +# $(1): Configuration name (tc1, tc2, &c.) +# $(2): Excluded tests +.PRECIOUS: $(foreach c,$(CONFIGS),$(c)) +define CONFIG_RULE +$(1): \ + $(foreach t,$(filter-out $(2),$(TESTS)),$(1).$(t)) \ + $(foreach t,$(filter-out $(2) rotate restart,$(TESTS)),$(1).$(t).diag) +endef +$(foreach c,$(filter-out tc3,$(CONFIGS)),$(eval $(call CONFIG_RULE,$(c),))) +# NOTE: tc3 uses OBCs and does not support asymmetric grid +$(eval $(call CONFIG_RULE,tc3,grid)) + +# Color highlights for test results +RED = \033[0;31m +GREEN = \033[0;32m +YELLOW = \033[0;33m +MAGENTA = \033[0;35m +RESET = \033[0m + +DONE = ${GREEN}DONE${RESET} +PASS = ${GREEN}PASS${RESET} +WARN = ${YELLOW}WARN${RESET} +FAIL = ${RED}FAIL${RESET} + +# Comparison rules +# $(1): Configuration (tc1, tc2, &c.) +# $(2): Test type (grid, layout, &c.) +# $(3): Comparison targets (symmetric asymmetric, symmetric layout, &c.) +define CMP_RULE +.PRECIOUS: $(foreach b,$(3),$(WORK)/$(1)/$(b)/ocean.stats) +$(1).$(2): $(foreach b,$(3),$(WORK)/$(1)/$(b)/ocean.stats) + @test "$$(shell ls -A $(WORK)/results/$(1) 2>/dev/null)" || rm -rf $(WORK)/results/$(1) + @cmp $$^ || !( \ + mkdir -p $(WORK)/results/$(1); \ + (diff $$^ | tee $(WORK)/results/$(1)/ocean.stats.$(2).diff | head -n 20) ; \ + echo -e "$(FAIL): Solutions $(1).$(2) have changed." \ + ) + @echo -e "$(PASS): Solutions $(1).$(2) agree." + +.PRECIOUS: $(foreach b,$(3),$(WORK)/$(1)/$(b)/chksum_diag) +$(1).$(2).diag: $(foreach b,$(3),$(WORK)/$(1)/$(b)/chksum_diag) + @cmp $$^ || !( \ + mkdir -p $(WORK)/results/$(1); \ + (diff $$^ | tee $(WORK)/results/$(1)/chksum_diag.$(2).diff | head -n 20) ; \ + echo -e "$(FAIL): Diagnostics $(1).$(2).diag have changed." \ + ) + @echo -e "$(PASS): Diagnostics $(1).$(2).diag agree." +endef + +$(foreach c,$(CONFIGS),$(eval $(call CMP_RULE,$(c),grid,symmetric asymmetric))) +$(foreach c,$(CONFIGS),$(eval $(call CMP_RULE,$(c),layout,symmetric layout))) +$(foreach c,$(CONFIGS),$(eval $(call CMP_RULE,$(c),rotate,symmetric rotate))) +$(foreach c,$(CONFIGS),$(eval $(call CMP_RULE,$(c),repro,symmetric repro))) +$(foreach c,$(CONFIGS),$(eval $(call CMP_RULE,$(c),openmp,symmetric openmp))) +$(foreach c,$(CONFIGS),$(eval $(call CMP_RULE,$(c),nan,symmetric nan))) +define CONFIG_DIM_RULE +$(1).dim: $(foreach d,$(DIMS),$(1).dim.$(d)) +$(foreach d,$(DIMS),$(eval $(call CMP_RULE,$(1),dim.$(d),symmetric dim.$(d)))) +endef +$(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) + + +# Custom comparison rules + +# Restart tests only compare the final stat record +.PRECIOUS: $(foreach b,symmetric restart target,$(WORK)/%/$(b)/ocean.stats) +%.restart: $(foreach b,symmetric restart,$(WORK)/%/$(b)/ocean.stats) + @test "$(shell ls -A $(WORK)/results/$* 2>/dev/null)" || rm -rf $(WORK)/results/$* + @cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ + || !( \ + mkdir -p $(WORK)/results/$*; \ + (diff $^ | tee $(WORK)/results/$*/chksum_diag.restart.diff | head -n 20) ; \ + echo -e "$(FAIL): Solutions $*.restart have changed." \ + ) + @echo -e "$(PASS): Solutions $*.restart agree." + +# TODO: chksum_diag parsing of restart files + +# stats rule is unchanged, but we cannot use CMP_RULE to generate it. +%.regression: $(foreach b,symmetric target,$(WORK)/%/$(b)/ocean.stats) + @test "$(shell ls -A $(WORK)/results/$* 2>/dev/null)" || rm -rf $(WORK)/results/$* + @cmp $^ || !( \ + mkdir -p $(WORK)/results/$*; \ + (diff $^ | tee $(WORK)/results/$*/ocean.stats.regression.diff | head -n 20) ; \ + echo -e "$(FAIL): Solutions $*.regression have changed." \ + ) + @echo -e "$(PASS): Solutions $*.regression agree." + +# Regression testing only checks for changes in existing diagnostics +.PRECIOUS: $(WORK)/%/target/chksum_diag +%.regression.diag: $(foreach b,symmetric target,$(WORK)/%/$(b)/chksum_diag) + @! diff $^ | grep "^[<>]" | grep "^>" > /dev/null \ + || ! (\ + mkdir -p $(WORK)/results/$*; \ + (diff $^ | tee $(WORK)/results/$*/chksum_diag.regression.diff | head -n 20) ; \ + echo -e "$(FAIL): Diagnostics $*.regression.diag have changed." \ + ) + @cmp $^ || ( \ + diff $^ | head -n 20; \ + echo -e "$(WARN): New diagnostics in $<" \ + ) + @echo -e "$(PASS): Diagnostics $*.regression.diag agree." + + +#--- +# Preprocessing +# NOTE: This only support tc4, but can be generalized over all tests. +.PHONY: preproc +preproc: tc4/Makefile + cd tc4 && $(MAKE) LAUNCHER="$(MPIRUN)" +preproc-compile: tc4/Makefile + cd tc4 && $(MAKE) executables + +tc4/Makefile: tc4/configure tc4/Makefile.in + cd $(@D) && ./configure || (cat config.log && false) + +tc4/configure: tc4/configure.ac + cd $(@D) && autoreconf -if + + +#--- +# Test run output files + +# Rule to build $(WORK)//{ocean.stats,chksum_diag}. +# $(1): Test configuration name +# $(2): Executable type +# $(3): Enable coverage flag +# $(4): MOM_override configuration +# $(5): Environment variables +# $(6): Number of MPI ranks + +define STAT_RULE +$(WORK)/%/$(1)/ocean.stats $(WORK)/%/$(1)/chksum_diag: $(BUILD)/$(2)/MOM6 | preproc + @echo "Running test $$*.$(1)..." + mkdir -p $$(@D) + cp -RL $$*/* $$(@D) + echo -e "$(4)" > $$(@D)/MOM_override + rm -f $(WORK)/results/$$*/std.$(1).{out,err} + cd $$(@D) \ + && $(TIME) $(5) $(MPIRUN) -n $(6) $$(abspath $$<) 2> std.err > std.out \ + || !( \ + mkdir -p ../../../results/$$*/ ; \ + cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 40 ; \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -n 40 ; \ + rm ocean.stats chksum_diag ; \ + echo -e "$(FAIL): $$*.$(1) failed at runtime." \ + ) + @echo -e "$(DONE): $$*.$(1); no runtime errors." + if [ $(3) ]; then \ + mkdir -p $(WORK)/results/$$* ; \ + cd $(BUILD)/$(2) ; \ + gcov -b *.gcda > gcov.$$*.$(1).out ; \ + find -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; ; \ + fi +endef + + +# Upload coverage reports +CODECOV_UPLOADER_URL ?= https://uploader.codecov.io/latest/linux/codecov +CODECOV_TOKEN ?= + +ifdef CODECOV_TOKEN + CODECOV_TOKEN_ARG = -t $(CODECOV_TOKEN) +else + CODECOV_TOKEN_ARG = +endif + +codecov: + curl -s $(CODECOV_UPLOADER_URL) -o $@ + chmod +x codecov + +.PHONY: report.cov +report.cov: run.cov codecov + ./codecov $(CODECOV_TOKEN_ARG) -R $(BUILD)/cov -Z -f "*.gcov" \ + > $(BUILD)/cov/codecov.out \ + 2> $(BUILD)/cov/codecov.err \ + && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ + || { \ + cat $(BUILD)/cov/codecov.err ; \ + echo -e "${RED}Failed to upload report.${RESET}" ; \ + if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ + } + +# Define $(,) as comma escape character +, := , + +$(eval $(call STAT_RULE,symmetric,symmetric,,,,1)) +$(eval $(call STAT_RULE,asymmetric,asymmetric,,,,1)) +$(eval $(call STAT_RULE,target,target,,,,1)) +$(eval $(call STAT_RULE,repro,repro,,,,1)) +$(eval $(call STAT_RULE,openmp,openmp,,,GOMP_CPU_AFFINITY=0,1)) +$(eval $(call STAT_RULE,layout,symmetric,,LAYOUT=2$(,)1,,2)) +$(eval $(call STAT_RULE,rotate,symmetric,,ROTATE_INDEX=True\nINDEX_TURNS=1,,1)) +$(eval $(call STAT_RULE,nan,symmetric,,,MALLOC_PERTURB_=1,1)) +$(eval $(call STAT_RULE,dim.t,symmetric,,T_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.l,symmetric,,L_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.h,symmetric,,H_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.q,symmetric,,Q_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.r,symmetric,,R_RESCALE_POWER=11,,1)) + +$(eval $(call STAT_RULE,cov,cov,true,,,1)) + +# Generate the half-period input namelist as follows: +# 1. Fetch DAYMAX and TIMEUNIT from MOM_input +# 2. Convert DAYMAX from TIMEUNIT to seconds +# 3. Apply seconds to `ocean_solo_nml` inside input.nml. +# NOTE: Assumes that runtime set by DAYMAX, will fail if set by input.nml +$(WORK)/%/restart/ocean.stats: $(BUILD)/symmetric/MOM6 | preproc + rm -rf $(@D) + mkdir -p $(@D) + cp -RL $*/* $(@D) mkdir -p $(@D)/RESTART - cd $(@D) ; $(MPIRUN) -n 1 $(PWD)/$(BUILD_PATH)/MOM6 + # Set the half-period + cd $(@D) \ + && daymax=$$(grep DAYMAX MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ + && timeunit=$$(grep TIMEUNIT MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ + && if [ -z "$${timeunit}" ]; then timeunit="8.64e4"; fi \ + && printf -v timeunit_int "%.f" "$${timeunit}" \ + && halfperiod=$$(awk -v t=$${daymax} -v dt=$${timeunit} 'BEGIN {printf "%.f", 0.5*t*dt}') \ + && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml + # Remove any previous archived output + rm -f $(WORK)/results/$*/std.restart{1,2}.{out,err} + # Run the first half-period + cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std1.err > std1.out \ + || !( \ + cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 40 ; \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 40 ; \ + echo -e "$(FAIL): $*.restart failed at runtime." \ + ) + # Setup the next inputs + cd $(@D) && rm -rf INPUT && mv RESTART INPUT + mkdir $(@D)/RESTART + cd $(@D) && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml + # Run the second half-period + cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std2.err > std2.out \ + || !( \ + cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 40 ; \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 40 ; \ + echo -e "$(FAIL): $*.restart failed at runtime." \ + ) + +# TODO: Restart checksum diagnostics -$(REGRESSIONS_ROOT)/regressions/%/ocean.stats.gnu: $(EXPERIMENTS_ROOT)/%/ocean.stats $(REGRESSIONS_ROOT) - cp $< $@ - cd $(@D) ; git status --porcelain $(@F) +#--- +# Not a true rule; only call this after `make test` to summarize test results. +.PHONY: test.summary +test.summary: + ./tools/report_test_results.sh $(WORK)/results -# Targets to clone repositories needed to build -FMS: - git clone -q $(FMS_URL) - cd $@ ; git checkout -q $(FMS_COMMIT) -mkmf: - git clone -q $(MKMF_URL) - cd $@ ; git checkout -q $(MKMF_COMMIT) +#--- +# Unit test -$(EXPERIMENTS_ROOT): +# NOTE: Using file parser gcov report as a proxy for test completion +.PHONY: run.cov.unit +run.cov.unit: $(BUILD)/unit/MOM_file_parser_tests.F90.gcov + +.PHONY: build.unit +build.unit: $(foreach f, $(UNIT_EXECS), $(BUILD)/unit/$(f)) +.PHONY: run.unit +run.unit: $(foreach f, $(UNIT_EXECS), work/unit/$(f).out) +.PHONY: build.timing +build.timing: $(foreach f, $(TIMING_EXECS), $(BUILD)/timing/$(f)) +.PHONY: run.timing +run.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).out) +.PHONY: show.timing +show.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).show) +$(WORK)/timing/%.show: + ./tools/disp_timing.py $(@:.show=.out) + + +# Invoke the above unit/timing rules for a "target" code +# Invoke with appropriate macros defines, i.e. +# make build.timing_target MOM_TARGET_URL=... MOM_TARGET_BRANCH=... TARGET_CODEBASE=$(BUILD)/target_codebase +# make run.timing_target TARGET_CODEBASE=$(BUILD)/target_codebase + +TIMING_TARGET_EXECS ?= $(basename $(notdir $(wildcard $(TARGET_CODEBASE)/config_src/drivers/timing_tests/*.F90) ) ) + +.PHONY: build.timing_target +build.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/$(BUILD)/timing/$(f)) +.PHONY: run.timing_target +run.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/work/timing/$(f).out) +.PHONY: compare.timing +compare.timing: $(foreach f, $(filter $(TIMING_EXECS),$(TIMING_TARGET_EXECS)), work/timing/$(f).compare) +$(WORK)/timing/%.compare: $(TARGET_CODEBASE) + ./tools/disp_timing.py -r $(TARGET_CODEBASE)/.testing/$(@:.compare=.out) $(@:.compare=.out) +$(TARGET_CODEBASE)/.testing/%: | $(TARGET_CODEBASE) + cd $(TARGET_CODEBASE)/.testing && make $* + + +# General rule to run a unit test executable +# Pattern is to run $(BUILD)/unit/executable and direct output to executable.out +$(WORK)/unit/%.out: $(BUILD)/unit/% + @mkdir -p $(@D) + cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> >(tee $*.err) > $*.out + +$(WORK)/unit/test_MOM_file_parser.out: $(BUILD)/unit/test_MOM_file_parser + if [ $(REPORT_COVERAGE) ]; then \ + find $(BUILD)/unit -name *.gcda -exec rm -f '{}' \; ; \ + fi + mkdir -p $(@D) + cd $(@D) \ + && rm -f input.nml logfile.0000*.out *_input MOM_parameter_doc.* \ + && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> test_MOM_file_parser.err > test_MOM_file_parser.out \ + || !( \ + cat test_MOM_file_parser.out | tail -n 100 ; \ + cat test_MOM_file_parser.err | tail -n 100 ; \ + ) + cd $(@D) \ + && $(TIME) $(MPIRUN) -n 2 $(abspath $<) 2> p2.test_MOM_file_parser.err > p2.test_MOM_file_parser.out \ + || !( \ + cat p2.test_MOM_file_parser.out | tail -n 100 ; \ + cat p2.test_MOM_file_parser.err | tail -n 100 ; \ + ) + +# NOTE: .gcov actually depends on .gcda, but .gcda is produced with std.out +# TODO: Replace $(WORK)/unit/std.out with *.gcda? +$(BUILD)/unit/MOM_file_parser_tests.F90.gcov: $(WORK)/unit/test_MOM_file_parser.out + cd $(@D) \ + && gcov -b *.gcda > gcov.unit.out + find $(@D) -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; + +.PHONY: report.cov.unit +report.cov.unit: $(BUILD)/unit/MOM_file_parser_tests.F90.gcov codecov + ./codecov $(CODECOV_TOKEN_ARG) -R $(BUILD)/unit -f "*.gcov" -Z -n "Unit tests" \ + > $(BUILD)/unit/codecov.out \ + 2> $(BUILD)/unit/codecov.err \ + && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ + || { \ + cat $(BUILD)/unit/codecov.err ; \ + echo -e "${RED}Failed to upload report.${RESET}" ; \ + if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ + } + +$(WORK)/timing/%.out: $(BUILD)/timing/% FORCE + @mkdir -p $(@D) + @echo Running $< in $(@D) + @cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> $*.err > $*.out + + +## Profiling based on FMS clocks + +PCONFIGS = p0 + +.PHONY: profile +profile: $(foreach p,$(PCONFIGS), prof.$(p)) + +.PHONY: prof.p0 +prof.p0: $(WORK)/p0/opt/clocks.json $(WORK)/p0/opt_target/clocks.json + python tools/compare_clocks.py $^ + +$(WORK)/p0/%/clocks.json: $(WORK)/p0/%/std.out + python tools/parse_fms_clocks.py -d $(@D) $^ > $@ \ + || !( rm $@ ) + +$(WORK)/p0/opt/std.out: $(BUILD)/opt/MOM6 +$(WORK)/p0/opt_target/std.out: $(BUILD)/opt_target/MOM6 + +$(WORK)/p0/%/std.out: mkdir -p $(@D) - cd $(@D) ; git clone --depth 1 $(CONFIGS_URL) experiments + cp -RL p0/* $(@D) + mkdir -p $(@D)/RESTART + echo -e "" > $(@D)/MOM_override + cd $(@D) \ + && $(MPIRUN) -n 1 $(abspath $<) 2> std.err > std.out + + +## Profiling based on perf output + +# TODO: This expects the -e flag, can I handle it in the command? +PERF_EVENTS ?= -$(REGRESSIONS_ROOT): +.PHONY: perf +perf: $(foreach p,$(PCONFIGS), perf.$(p)) + +.PHONY: prof.p0 +perf.p0: $(WORK)/p0/opt/profile.json $(WORK)/p0/opt_target/profile.json + python tools/compare_perf.py $^ + +$(WORK)/p0/%/profile.json: $(WORK)/p0/%/perf.data + python tools/parse_perf.py -f $< > $@ + +$(WORK)/p0/opt/perf.data: $(BUILD)/opt/MOM6 +$(WORK)/p0/opt_target/perf.data: $(BUILD)/opt_target/MOM6 + +$(WORK)/p0/%/perf.data: mkdir -p $(@D) - cd $(@D) ; git clone --depth 1 $(REGRESSIONS_URL) answers + cp -RL p0/* $(@D) + mkdir -p $(@D)/RESTART + echo -e "" > $(@D)/MOM_override + cd $(@D) \ + && perf record \ + -F 3999 \ + ${PERF_EVENTS} \ + ../../../$< 2> std.perf.err > std.perf.out \ + || cat std.perf.err + + +## Cleanup +# NOTE: These tests assert that we are in the .testing directory. + +.PHONY: clean +clean: clean.build clean.stats + rm -rf $(BUILD) + + +.PHONY: clean.build +clean.build: + @[ $$(basename $$(pwd)) = .testing ] + for b in $(ALL_EXECS); do \ + rm -rf $(BUILD)/$${b}; \ + done + + +.PHONY: clean.stats +clean.stats: + @[ $$(basename $$(pwd)) = .testing ] + rm -rf $(WORK) + + +.PHONY: clean.preproc +clean.preproc: + @if [ -f tc4/Makefile ] ; then \ + cd tc4 && make clean ; \ + fi diff --git a/.testing/README.md b/.testing/README.md deleted file mode 100644 index 46b154da14..0000000000 --- a/.testing/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# .testing - -This directory contains scripts used when evaluating commits on Travis-CI diff --git a/.testing/README.rst b/.testing/README.rst new file mode 100644 index 0000000000..a84eeea80e --- /dev/null +++ b/.testing/README.rst @@ -0,0 +1,384 @@ +=============== +MOM6 Test Suite +=============== + +This directory contains test configurations used to evaluate submissions to the +MOM6 codebase. The tests are designed to run either locally or in a CI +environment. + + +Usage +===== + +``make -j`` + Build the FMS library and test executables. + +``make -j test`` + Run the test suite, defined in the ``tc`` directores. + +``make clean.build`` + Delete only the MOM6 test executables. + +``make clean`` + Delete the MOM6 test executables and dependency builds (FMS). + +``make -j build.unit`` + Build the unit test programs in config_src/drivers/unit_tests + +``make -j run.unit`` + Run the unit test programs from config_src/drivers/unit_tests in $(WORKSPACE)/work/unit + +``make -j build.timing`` + Build the timing test programs in config_src/drivers/timing_tests + +``make -j run.timing`` + Run the timing test programs from config_src/drivers/timing_tests in $(WORKSPACE)/work/timing + +Configuration +============= + +The test suite includes many configuration flags and variables which can be +configured at either the command line, or can be stored in a ``config.mk`` +file. + +Several of the following may require configuration for particular systems. + +``MPIRUN`` (*default:* ``mpirun``) + Name of the MPI launcher. Often this is ``mpirun`` or ``mpiexec`` but may + all need to run through a scheduler, e.g. ``srun`` if using Slurm. + +``FMS_COMMIT`` (*default:* ``2023.03``) + Set the FMS version, either by tag or commit (as defined in ``FMS_URL``). + +``FMS_URL`` (*default*: ``https://github.com/NOAA-GFDL/FMS.git``) + Set the URL of the FMS repository. + +``DO_REPRO_TESTS`` (*default:* *none*) + Set to ``true`` to test the REPRO build and confirm equivalence of DEBUG and + REPRO builds. + + For compilers with aggressive optimization, DEBUG and REPRO may not produce + identical results and this test should not be used. + +``DO_REGRESSION_TESTS`` (*default:* *none*) + Set to ``true`` to compare output with a defined target branch, set by + ``MOM_TARGET_LOCAL_BRANCH``. (NOTE: This defaults to ``dev/gfdl``). + +``DO_COVERAGE`` (*default:* *none*) + Set to ``true`` to enable code coverage. Currently only configured for + ``gcov``. + +``REQUIRE_COVERAGE_UPLOAD`` (*default:* *none*) + Set to ``true`` if failure to upload the coverage report to codecov.io + should result in an error. This should only be enabled if codecov.io has + already been configured for the user, or by a supporting CI. + +``DO_PROFILE`` (*default:* *none*) + Set to ``true`` to enable performance profile monitoring. Models are + compiled using ``OPT_FCFLAGS`` (see below) and performance of various + functions are reported and compared to the target branch. + + Results from these tests should only be considered if the platform has been + configure for benchmarking. + + +Build configuration +------------------- + +Compilation is controlled with the following variables. Defaults are chosen +for the widest compatibility across platforms. Users should modify these to +reflect their own needs. + +``FCFLAGS_DEBUG`` (*default:* ``-g -O0``) + The "DEBUG" build, for rapid compilation and debugging. + +``FCFLAGS_REPRO`` (*default:* ``-g -O2``) + The "REPRO" build, for reproducible production runs. + +``FCFLAGS_OPT`` (*default:* ``-g -O3``) + The "OPT" build, for aggressive optimization and profiling. + +``FCFLAGS_COVERAGE`` (*default:* ``-g -O0 -fbacktrace --coverage``) + Flags used for producing code coverage reports. Defaults are for gcc, + although ``--coverage`` is relatively common across compilers. + +``FCFLAGS_INIT`` (*default:* *none*) + A placeholder flag for aggressive initialization testing. This is appended + to existing flags (usually ``FCFLAGS_DEBUG``). + +``FCFLAGS_FMS`` (*default:* ``FCFLAGS_DEBUG``) + Compiler flags used for the supporting FMS library. In most cases, it is + sufficient to use ``FCFLAGS_DEBUG``. + +``LDFLAGS_COVERAGE`` (*default:* ``--coverage``) + Linker flags to enable coverage. + +``LDFLAGS_USER`` (*default:* *none*) + A placeholder for supplemental linker flags, such as an external library not + configured by autoconf. + +The following flags are passed as environment variables to other Makefiles. + +``FC``, ``MPIFC`` + The Fortran compiler and its MPI wrapper. + +``CC``, ``MPICC`` + The C compiler and its MPI wrapper. This is primarily used by FMS, but may + be used in some MOM6 autoconf tests. + +If unset, these will be configured by autoconf or from the user's environment +variables. + +Additional settings for particular tasks are explained below. + + +Example ``config.mk`` +--------------------- + +An example config.mk file configured for GFortran is shown below.:: + + DO_REPRO_TESTS = true + DO_REGRESSION_TESTS = true + DO_COVERAGE = true + DO_PROFILE = true + + FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds + FCFLAGS_REPRO = -g -O2 -fbacktrace + FCFLAGS_OPT = -g -O3 -mavx -mfma + FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived + FCFLAGS_COVERAGE = --coverage + +The file follows Makefile syntax, so quotations are generally not required and +spaces are permitted between assignment operators (``=``). + + +Builds +====== + +Run ``make`` to build the test executables.:: + + $ make + +This will fetch external dependencies, compile the FMS framework library, and +compile the executables used in the test suite. + +The following executables will be created. + +``build/symmetric/MOM6`` + Use symmetric grids for model fields, using DEBUG flags. + + A symmetric grid is one where each finite-volume cell has grid points along + all faces. Often this results in a redundant row of points along each side + of a regular domain. + + This is the recommended production configuration, and is the reference build + for all tests in the suite. + +``build/asymmetric/MOM6`` + Use asymmetric grids for model fields. + + Asymmetric grids eliminate a redundant fields along western and southern + boundaries, which reduces the total number of points. They also ensure + that center, face, and vertex field arrays are the same size. + + The disadvantages are greater computational complexity along these + boundaries. They also do not support open boundary conditions. + + Asymmetric grids were traditionally used in many legacy ocean models. + +``build/repro/MOM6`` + Optimized build for doing reproducible runs, based REPRO flags. + + This is only built if ``DO_REPRO_TESTS`` is set to ``true``. + +``build/target/MOM6`` + A reference build for regression testing. + + The reference branch is set by ``MOM_TARGET_LOCAL_BRANCH``. This would + generally be configured by a CI to a pull request's target branch. This is + only built if ``DO_REGRESSION_TESTS`` is set to ``true``. + +``build/openmp/MOM6`` + A DEBUG build with OpenMP enabled. + + +Tests +===== + +The ``test`` rule will run all of the tests.:: + + $ make test + +Tests are based on configurations which are designed to give identical output. +When the output differs, the test reports a failure. + + +Test groups +----------- + +The tests are gathered into the following groups. + +``test.grid`` + Compare symmetric and nonsymmetric grids. + +``test.regression`` + Compare the current codebase to a target branch (e.g. ``dev/gfdl``). + +``test.layout`` + Compare a serial (one domain) and a parallel (two domain) simulation. + +``test.restart`` + Compare a single run to two runs separated by a restart. + +``test.repro`` + Compare the unoptimized (DEBUG) and optimized (REPRO) builds. + +``test.nan`` + Enable NaN-initialization of allocated (heap) arrays. + + This relies on internal features of glibc and may not work on other + platforms. + +``test.dim`` + Enable dimension rescaling tests. + +Each tests uses the symmetric build for its reference state. + +These rules can be used to run individual groups of tests.:: + + $ make test.grid + + +Test experiments +---------------- + +For each group, we test each of the following configurations, which represent +idealizations of various production experiments. + +``tc0`` + Unit testing of various model components, based on ``unit_tests`` + +``tc1`` + A low-resolution version of the ``benchmark`` configuration + + ``tc1.a`` + Use the un-split mode with Runge-Kutta 3 time integration + + ``tc1.b`` + Use the un-split mode with Runge-Kutta 2 time integration + +``tc2`` + An ALE configuration based on tc1 with tides + + ``tc2.a`` + Use sigma, PPM_H4 and no tides + +``tc3`` + An open-boundary condition (OBC) test based on ``circle_obcs`` + +``tc4`` + Sponges and initialization using I/O + + +Test procedure +-------------- + +The test suite checks for numerical consistency of the model output across +different model configurations when subjected to relevant numerical and +mathematical transformations, such as grid layout or dimensional rescaling. If +the model state is unchanged after each transformation, then the test is +reported as passing. Any discrepancy in the model state causes the test to +fail. + +Model state is currently defined by the ``ocean.stats`` output file, which +reports the total energy (per unit mass) at machine precision alongside similar +global metrics at lower precision, such as mass or mean sea level. + +Diagnostics are based on the MOM checksum function, which includes the mean, +minimum, and maximum values, alongside a bitcount checksum, in the physical +domain, which are saved in the ``chksum_diag`` output file. + + +Regression testing +================== + +When ``DO_REGRESSION_TESTS`` is enabled, the Makefile will check out a second +copy of the repository from a specified URL and branch given by +``MOM_TARGET_URL`` and ``MOM_TARGET_BRANCH``, respectively. The code is +checked out into the ``TARGET_CODEBASE`` directory. + +The default settings, with resolved values as comments, are shown below.:: + + MOM_TARGET_SLUG = NOAA-GFDL/MOM6 + MOM_TARGET_URL = https://github.com/$(MOM_TARGET_SLUG) + #= https://github.com/NOAA-GFDL/MOM6 + MOM_TARGET_LOCAL_BRANCH = dev/gfdl + MOM_TARGET_BRANCH = origin/$(MOM_TARGET_LOCAL_BRANCH) + #= origin/dev/gfdl + TARGET_CODEBASE = $(BUILD)/target_codebase + +These default values can be configured to target a particular development +branch. + +Currently the target can only be specified by branch name, rather than hash. + +New diagnostics do not report as a fail, and are not tracked by any CIs, but +the test will report a warning to the user. + + +Code coverage +============= + +Code coverage reports the lines of code which have been tested, and can be used +to determine if a particular section is untested. + +To enable code coverage, set ``DO_COVERAGE`` to ``true``. + +Reports are stored in the build directories. There is one report per source +file, and each ends in the ``.gcov`` suffix. Two sets of coverage reports are +generated. + +``build/cov`` + Test suite code coverage + +``build/unit`` + Unit test code coverage + +To upload the tests to codecov.io, use the following rules.:: + + $ make report.cov # Test suite + $ make report.cov.unit # Unit test + +Note that any uploads will require a valid CodeCov token. If uploading through +the CI, this can be set up through your GitHub account. + +Pull request coverage reports for the CI can be checked at +https://codecov.io/gh/NOAA-GFDL/MOM6 + + +CI configuration +================ + +Whenever code is pushed to GitHub or a pull request (PR) is created, the test +suite is run. + +When the tests are run on the CI, the following variables are re-defined: + +- ``DO_REPRO_TESTS`` is set to ``true`` for all tests. + +- ``DO_REGRESSION_TESTS`` is set to ``true`` for a PR submission, and is unset for + code pushes. + +- ``DO_COVERAGE`` is set to ``true``. + + - For pull requests, ``REQUIRE_COVERAGE_UPLOAD`` is set to ``true``. + +- ``MOM_TARGET_SLUG`` is set to the URL stub of the model to be built. + + For submissions to NOAA-GFDL, this will be set to ``NOAA-GFDL/MOM6`` and the + reference URL will be ``https://github.com/NOAA-GFDL/MOM6``. + +- ``MOM_TARGET_LOCAL_BRANCH`` + + For a code push, this is set to the name of the active branch at GitHub. For + a PR, this is the name of the branch which is receiving the PR. diff --git a/.testing/configure b/.testing/configure deleted file mode 100755 index 841635d6f4..0000000000 --- a/.testing/configure +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -echo "Configured!" $MAKEARGS -touch build/test_${MAKEARGS//\ /_} diff --git a/.testing/linux-ubuntu-xenial-gnu.mk b/.testing/linux-ubuntu-xenial-gnu.mk deleted file mode 100644 index 80abc4e48d..0000000000 --- a/.testing/linux-ubuntu-xenial-gnu.mk +++ /dev/null @@ -1,273 +0,0 @@ -# Template for the GNU Compiler Collection on Xenial version of Ubuntu Linux systems (used by Travis-CI) -# -# Typical use with mkmf -# mkmf -t linux-ubuntu-xenial-gnu.mk -c"-Duse_libMPI -Duse_netCDF" path_names /usr/local/include - -############ -# Commands Macors -FC = mpif90 -CC = mpicc -LD = mpif90 $(MAIN_PROGRAM) - -####################### -# Build target macros -# -# Macros that modify compiler flags used in the build. Target -# macrose are usually set on the call to make: -# -# make REPRO=on NETCDF=3 -# -# Most target macros are activated when their value is non-blank. -# Some have a single value that is checked. Others will use the -# value of the macro in the compile command. - -DEBUG = # If non-blank, perform a debug build (Cannot be - # mixed with REPRO or TEST) - -REPRO = # If non-blank, erform a build that guarentees - # reprodicuibilty from run to run. Cannot be used - # with DEBUG or TEST - -TEST = # If non-blank, use the compiler options defined in - # the FFLAGS_TEST and CFLAGS_TEST macros. Cannot be - # use with REPRO or DEBUG - -VERBOSE = # If non-blank, add additional verbosity compiler - # options - -OPENMP = # If non-blank, compile with openmp enabled - -NO_OVERRIDE_LIMITS = # If non-blank, do not use the -qoverride-limits - # compiler option. Default behavior is to compile - # with -qoverride-limits. - -NETCDF = # If value is '3' and CPPDEFS contains - # '-Duse_netCDF', then the additional cpp macro - # '-Duse_LARGEFILE' is added to the CPPDEFS macro. - -INCLUDES = # A list of -I Include directories to be added to the - # the compile command. - -SSE = # The SSE options to be used to compile. If blank, - # than use the default SSE settings for the host. - # Current default is to use SSE2. - -COVERAGE = # Add the code coverage compile options. - -# Need to use at least GNU Make version 3.81 -need := 3.81 -ok := $(filter $(need),$(firstword $(sort $(MAKE_VERSION) $(need)))) -ifneq ($(need),$(ok)) -$(error Need at least make version $(need). Load module gmake/3.81) -endif - -# REPRO, DEBUG and TEST need to be mutually exclusive of each other. -# Make sure the user hasn't supplied two at the same time -ifdef REPRO -ifneq ($(DEBUG),) -$(error Options REPRO and DEBUG cannot be used together) -else ifneq ($(TEST),) -$(error Options REPRO and TEST cannot be used together) -endif -else ifdef DEBUG -ifneq ($(TEST),) -$(error Options DEBUG and TEST cannot be used together) -endif -endif - -MAKEFLAGS += --jobs=$(shell grep '^processor' /proc/cpuinfo | wc -l) - -# Macro for Fortran preprocessor -FPPFLAGS := $(INCLUDES) -# Fortran Compiler flags for the NetCDF library -FPPFLAGS += $(shell nf-config --fflags) - -# Base set of Fortran compiler flags -FFLAGS := -fcray-pointer -fdefault-double-8 -fdefault-real-8 -Waliasing -ffree-line-length-none -fno-range-check - -# Flags based on perforance target (production (OPT), reproduction (REPRO), or debug (DEBUG) -FFLAGS_OPT = -O3 -FFLAGS_REPRO = -O2 -fbounds-check -FFLAGS_DEBUG = -O0 -g -W -fbounds-check -fbacktrace -ffpe-trap=invalid,zero,overflow - -# Flags to add additional build options -FFLAGS_OPENMP = -fopenmp -FFLAGS_VERBOSE = -FFLAGS_COVERAGE = - -# Macro for C preprocessor -CPPFLAGS = $(INCLUDES) -# C Compiler flags for the NetCDF library -CPPFLAGS += $(shell nf-config --cflags) - -# Base set of C compiler flags -CFLAGS := -D__IFC - -# Flags based on perforance target (production (OPT), reproduction (REPRO), or debug (DEBUG) -CFLAGS_OPT = -O2 -CFLAGS_REPRO = -O2 -CFLAGS_DEBUG = -O0 -g - -# Flags to add additional build options -CFLAGS_OPENMP = -fopenmp -CFLAGS_VERBOSE = -CFLAGS_COVERAGE = - -# Optional Testing compile flags. Mutually exclusive from DEBUG, REPRO, and OPT -# *_TEST will match the production if no new option(s) is(are) to be tested. -FFLAGS_TEST = $(FFLAGS_OPT) -CFLAGS_TEST = $(CFLAGS_OPT) - -# Linking flags -LDFLAGS := -LDFLAGS_OPENMP := -fopenmp -LDFLAGS_VERBOSE := -LDFLAGS_COVERAGE := - -# Start with a blank LIBS -LIBS = -# NetCDF library flags -LIBS += $(shell nf-config --flibs) - -# Get compile flags based on target macros. -ifdef REPRO -CFLAGS += $(CFLAGS_REPRO) -FFLAGS += $(FFLAGS_REPRO) -else ifdef DEBUG -CFLAGS += $(CFLAGS_DEBUG) -FFLAGS += $(FFLAGS_DEBUG) -else ifdef TEST -CFLAGS += $(CFLAGS_TEST) -FFLAGS += $(FFLAGS_TEST) -else -CFLAGS += $(CFLAGS_OPT) -FFLAGS += $(FFLAGS_OPT) -endif - -ifdef OPENMP -CFLAGS += $(CFLAGS_OPENMP) -FFLAGS += $(FFLAGS_OPENMP) -LDFLAGS += $(LDFLAGS_OPENMP) -endif - -ifdef SSE -CFLAGS += $(SSE) -FFLAGS += $(SSE) -endif - -ifdef NO_OVERRIDE_LIMITS -FFLAGS += $(FFLAGS_OVERRIDE_LIMITS) -endif - -ifdef VERBOSE -CFLAGS += $(CFLAGS_VERBOSE) -FFLAGS += $(FFLAGS_VERBOSE) -LDFLAGS += $(LDFLAGS_VERBOSE) -endif - -ifeq ($(NETCDF),3) - # add the use_LARGEFILE cppdef - ifneq ($(findstring -Duse_netCDF,$(CPPDEFS)),) - CPPDEFS += -Duse_LARGEFILE - endif -endif - -ifdef COVERAGE -ifdef BUILDROOT -PROF_DIR=-prof-dir=$(BUILDROOT) -endif -CFLAGS += $(CFLAGS_COVERAGE) $(PROF_DIR) -FFLAGS += $(FFLAGS_COVERAGE) $(PROF_DIR) -LDFLAGS += $(LDFLAGS_COVERAGE) $(PROF_DIR) -endif - -LDFLAGS += $(LIBS) - -#--------------------------------------------------------------------------- -# you should never need to change any lines below. - -# see the MIPSPro F90 manual for more details on some of the file extensions -# discussed here. -# this makefile template recognizes fortran sourcefiles with extensions -# .f, .f90, .F, .F90. Given a sourcefile ., where is one of -# the above, this provides a number of default actions: - -# make .opt create an optimization report -# make .o create an object file -# make .s create an assembly listing -# make .x create an executable file, assuming standalone -# source -# make .i create a preprocessed file (for .F) -# make .i90 create a preprocessed file (for .F90) - -# The macro TMPFILES is provided to slate files like the above for removal. - -RM = rm -f -TMPFILES = .*.m *.B *.L *.i *.i90 *.l *.s *.mod *.opt - -.SUFFIXES: .F .F90 .H .L .T .f .f90 .h .i .i90 .l .o .s .opt .x - -.f.L: - $(FC) $(FFLAGS) -c -listing $*.f -.f.opt: - $(FC) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.f -.f.l: - $(FC) $(FFLAGS) -c $(LIST) $*.f -.f.T: - $(FC) $(FFLAGS) -c -cif $*.f -.f.o: - $(FC) $(FFLAGS) -c $*.f -.f.s: - $(FC) $(FFLAGS) -S $*.f -.f.x: - $(FC) $(FFLAGS) -o $*.x $*.f *.o $(LDFLAGS) -.f90.L: - $(FC) $(FFLAGS) -c -listing $*.f90 -.f90.opt: - $(FC) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.f90 -.f90.l: - $(FC) $(FFLAGS) -c $(LIST) $*.f90 -.f90.T: - $(FC) $(FFLAGS) -c -cif $*.f90 -.f90.o: - $(FC) $(FFLAGS) -c $*.f90 -.f90.s: - $(FC) $(FFLAGS) -c -S $*.f90 -.f90.x: - $(FC) $(FFLAGS) -o $*.x $*.f90 *.o $(LDFLAGS) -.F.L: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -listing $*.F -.F.opt: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.F -.F.l: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $(LIST) $*.F -.F.T: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -cif $*.F -.F.f: - $(FC) $(CPPDEFS) $(FPPFLAGS) -EP $*.F > $*.f -.F.i: - $(FC) $(CPPDEFS) $(FPPFLAGS) -P $*.F -.F.o: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $*.F -.F.s: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -S $*.F -.F.x: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -o $*.x $*.F *.o $(LDFLAGS) -.F90.L: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -listing $*.F90 -.F90.opt: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.F90 -.F90.l: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $(LIST) $*.F90 -.F90.T: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -cif $*.F90 -.F90.f90: - $(FC) $(CPPDEFS) $(FPPFLAGS) -EP $*.F90 > $*.f90 -.F90.i90: - $(FC) $(CPPDEFS) $(FPPFLAGS) -P $*.F90 -.F90.o: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $*.F90 -.F90.s: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -S $*.F90 -.F90.x: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -o $*.x $*.F90 *.o $(LDFLAGS) diff --git a/.testing/p0/MOM_input b/.testing/p0/MOM_input new file mode 100644 index 0000000000..8f751d7bf1 --- /dev/null +++ b/.testing/p0/MOM_input @@ -0,0 +1,505 @@ +! This input file provides the adjustable run-time parameters for version 6 of the Modular Ocean Model (MOM6). +! Where appropriate, parameters use usually given in MKS units. + +! This particular file is for the example in benchmark. + +! This MOM_input file typically contains only the non-default values that are needed to reproduce this example. +! A full list of parameters for this example can be found in the corresponding MOM_parameter_doc.all file +! which is generated by the model at run-time. + +! === module MOM_domains === +NIGLOBAL = 32 ! + ! The total number of thickness grid points in the x-direction in the physical + ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +NJGLOBAL = 32 ! + ! The total number of thickness grid points in the y-direction in the physical + ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +LAYOUT = 1, 1 + ! The processor layout that was actually used. + +! === module MOM === +THICKNESSDIFFUSE = True ! [Boolean] default = False + ! If true, interface heights are diffused with a coefficient of KHTH. +THICKNESSDIFFUSE_FIRST = True ! [Boolean] default = False + ! If true, do thickness diffusion before dynamics. This is only used if + ! THICKNESSDIFFUSE is true. +DT = 900.0 ! [s] + ! The (baroclinic) dynamics time step. The time-step that is actually used will + ! be an integer fraction of the forcing time-step (DT_FORCING in ocean-only mode + ! or the coupling timestep in coupled mode.) +DT_THERM = 3600.0 ! [s] default = 900.0 + ! The thermodynamic and tracer advection time step. Ideally DT_THERM should be + ! an integer multiple of DT and less than the forcing or coupling time-step, + ! unless THERMO_SPANS_COUPLING is true, in which case DT_THERM can be an integer + ! multiple of the coupling timestep. By default DT_THERM is set to DT. +DTBT_RESET_PERIOD = 0.0 ! [s] default = 3600.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. The default + ! is set by DT_THERM. This is only used if SPLIT is true. +FRAZIL = True ! [Boolean] default = False + ! If true, water freezes if it gets too cold, and the accumulated heat deficit + ! is returned in the surface state. FRAZIL is only used if + ! ENABLE_THERMODYNAMICS is true. +C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 + ! The heat capacity of sea water, approximated as a constant. This is only used + ! if ENABLE_THERMODYNAMICS is true. The default value is from the TEOS-10 + ! definition of conservative temperature. +SAVE_INITIAL_CONDS = True ! [Boolean] default = False + ! If true, write the initial conditions to a file given by IC_OUTPUT_FILE. +IC_OUTPUT_FILE = "GOLD_IC" ! default = "MOM_IC" + ! The file into which to write the initial conditions. + +! === module MOM_fixed_initialization === +INPUTDIR = "INPUT" ! default = "." + ! The directory in which input files are found. + +! === module MOM_grid_init === +GRID_CONFIG = "cartesian" ! + ! A character string that determines the method for defining the horizontal + ! grid. Current options are: + ! mosaic - read the grid from a mosaic (supergrid) + ! file set by GRID_FILE. + ! cartesian - use a (flat) Cartesian grid. + ! spherical - use a simple spherical grid. + ! mercator - use a Mercator spherical grid. +SOUTHLAT = -41.0 ! [degrees] + ! The southern latitude of the domain. +LENLAT = 41.0 ! [degrees] + ! The latitudinal length of the domain. +LENLON = 90.0 ! [degrees] + ! The longitudinal length of the domain. +ISOTROPIC = True ! [Boolean] default = False + ! If true, an isotropic grid on a sphere (also known as a Mercator grid) is + ! used. With an isotropic grid, the meridional extent of the domain (LENLAT), + ! the zonal extent (LENLON), and the number of grid points in each direction are + ! _not_ independent. In MOM the meridional extent is determined to fit the zonal + ! extent and the number of grid points, while grid is perfectly isotropic. +TOPO_CONFIG = "benchmark" ! + ! This specifies how bathymetry is specified: + ! file - read bathymetric information from the file + ! specified by (TOPO_FILE). + ! flat - flat bottom set to MAXIMUM_DEPTH. + ! bowl - an analytically specified bowl-shaped basin + ! ranging between MAXIMUM_DEPTH and MINIMUM_DEPTH. + ! spoon - a similar shape to 'bowl', but with an vertical + ! wall at the southern face. + ! halfpipe - a zonally uniform channel with a half-sine + ! profile in the meridional direction. + ! bbuilder - build topography from list of functions. + ! benchmark - use the benchmark test case topography. + ! Neverworld - use the Neverworld test case topography. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! ISOMIP - use a slope and channel configuration for the + ! ISOMIP test case. + ! DOME2D - use a shelf and slope configuration for the + ! DOME2D gravity current/overflow test case. + ! Kelvin - flat but with rotated land mask. + ! seamount - Gaussian bump for spontaneous motion test case. + ! dumbbell - Sloshing channel with reservoirs on both ends. + ! shelfwave - exponential slope for shelfwave test case. + ! Phillips - ACC-like idealized topography used in the Phillips config. + ! dense - Denmark Strait-like dense water formation and overflow. + ! USER - call a user modified routine. + +! === module benchmark_initialize_topography === +MINIMUM_DEPTH = 1.0 ! [m] default = 0.0 + ! The minimum depth of the ocean. +MAXIMUM_DEPTH = 5500.0 ! [m] + ! The maximum depth of the ocean. + +! === module MOM_verticalGrid === +! Parameters providing information about the vertical grid. +NK = 75 ! [nondim] + ! The number of model layers. + +! === module MOM_EOS === + +! === module MOM_tracer_flow_control === +USE_IDEAL_AGE_TRACER = True ! [Boolean] default = False + ! If true, use the ideal_age_example tracer package. + +! === module ideal_age_example === + +! === module MOM_coord_initialization === +COORD_CONFIG = "ts_range" ! default = "none" + ! This specifies how layers are to be defined: + ! ALE or none - used to avoid defining layers in ALE mode + ! file - read coordinate information from the file + ! specified by (COORD_FILE). + ! BFB - Custom coords for buoyancy-forced basin case + ! based on SST_S, T_BOT and DRHO_DT. + ! linear - linear based on interfaces not layers + ! layer_ref - linear based on layer densities + ! ts_ref - use reference temperature and salinity + ! ts_range - use range of temperature and salinity + ! (T_REF and S_REF) to determine surface density + ! and GINT calculate internal densities. + ! gprime - use reference density (RHO_0) for surface + ! density and GINT calculate internal densities. + ! ts_profile - use temperature and salinity profiles + ! (read from COORD_FILE) to set layer densities. + ! USER - call a user modified routine. +TS_RANGE_T_LIGHT = 25.0 ! [degC] default = 10.0 + ! The initial temperature of the lightest layer when COORD_CONFIG is set to + ! ts_range. +TS_RANGE_T_DENSE = 3.0 ! [degC] default = 10.0 + ! The initial temperature of the densest layer when COORD_CONFIG is set to + ! ts_range. +TS_RANGE_RESOLN_RATIO = 5.0 ! [nondim] default = 1.0 + ! The ratio of density space resolution in the densest part of the range to that + ! in the lightest part of the range when COORD_CONFIG is set to ts_range. Values + ! greater than 1 increase the resolution of the denser water. + +! === module MOM_state_initialization === +THICKNESS_CONFIG = "benchmark" ! default = "uniform" + ! A string that determines how the initial layer thicknesses are specified for a + ! new run: + ! file - read interface heights from the file specified + ! thickness_file - read thicknesses from the file specified + ! by (THICKNESS_FILE). + ! coord - determined by ALE coordinate. + ! uniform - uniform thickness layers evenly distributed + ! between the surface and MAXIMUM_DEPTH. + ! list - read a list of positive interface depths. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! ISOMIP - use a configuration for the + ! ISOMIP test case. + ! benchmark - use the benchmark test case thicknesses. + ! Neverworld - use the Neverworld test case thicknesses. + ! search - search a density profile for the interface + ! densities. This is not yet implemented. + ! circle_obcs - the circle_obcs test case is used. + ! DOME2D - 2D version of DOME initialization. + ! adjustment2d - 2D lock exchange thickness ICs. + ! sloshing - sloshing gravity thickness ICs. + ! seamount - no motion test with seamount ICs. + ! dumbbell - sloshing channel ICs. + ! soliton - Equatorial Rossby soliton. + ! rossby_front - a mixed layer front in thermal wind balance. + ! USER - call a user modified routine. + +! === module benchmark_initialize_thickness === +TS_CONFIG = "benchmark" ! + ! A string that determines how the initial tempertures and salinities are + ! specified for a new run: + ! file - read velocities from the file specified + ! by (TS_FILE). + ! fit - find the temperatures that are consistent with + ! the layer densities and salinity S_REF. + ! TS_profile - use temperature and salinity profiles + ! (read from TS_FILE) to set layer densities. + ! benchmark - use the benchmark test case T & S. + ! linear - linear in logical layer space. + ! DOME2D - 2D DOME initialization. + ! ISOMIP - ISOMIP initialization. + ! adjustment2d - 2d lock exchange T/S ICs. + ! sloshing - sloshing mode T/S ICs. + ! seamount - no motion test with seamount ICs. + ! dumbbell - sloshing channel ICs. + ! rossby_front - a mixed layer front in thermal wind balance. + ! SCM_CVMix_tests - used in the SCM CVMix tests. + ! USER - call a user modified routine. + +! === module MOM_diag_mediator === + +! === module MOM_lateral_mixing_coeffs === +USE_VARIABLE_MIXING = True ! [Boolean] default = False + ! If true, the variable mixing code will be called. This allows diagnostics to + ! be created even if the scheme is not used. If KHTR_SLOPE_CFF>0 or + ! KhTh_Slope_Cff>0, this is set to true regardless of what is in the parameter + ! file. +USE_VISBECK = True ! [Boolean] default = False + ! If true, use the Visbeck et al. (1997) formulation for + ! thickness diffusivity. +RESOLN_SCALED_KH = True ! [Boolean] default = False + ! If true, the Laplacian lateral viscosity is scaled away when the first + ! baroclinic deformation radius is well resolved. +RESOLN_SCALED_KHTH = True ! [Boolean] default = False + ! If true, the interface depth diffusivity is scaled away when the first + ! baroclinic deformation radius is well resolved. +RESOLN_SCALED_KHTR = True ! [Boolean] default = False + ! If true, the epipycnal tracer diffusivity is scaled away when the first + ! baroclinic deformation radius is well resolved. +KHTH_SLOPE_CFF = 0.1 ! [nondim] default = 0.0 + ! The nondimensional coefficient in the Visbeck formula for the interface depth + ! diffusivity +KHTR_SLOPE_CFF = 0.1 ! [nondim] default = 0.0 + ! The nondimensional coefficient in the Visbeck formula for the epipycnal tracer + ! diffusivity +VARMIX_KTOP = 6 ! [nondim] default = 2 + ! The layer number at which to start vertical integration of S*N for purposes of + ! finding the Eady growth rate. +VISBECK_L_SCALE = 3.0E+04 ! [m] default = 0.0 + ! The fixed length scale in the Visbeck formula. + +! === module MOM_set_visc === +PRANDTL_TURB = 0.0 ! [nondim] default = 1.0 + ! The turbulent Prandtl number applied to shear instability. +DYNAMIC_VISCOUS_ML = True ! [Boolean] default = False + ! If true, use a bulk Richardson number criterion to determine the mixed layer + ! thickness for viscosity. +ML_OMEGA_FRAC = 1.0 ! [nondim] default = 0.0 + ! 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). +HBBL = 10.0 ! [m] + ! The thickness of a bottom boundary layer with a viscosity of KVBBL if + ! BOTTOMDRAGLAW is not defined, or the thickness over which near-bottom + ! velocities are averaged for the drag law if BOTTOMDRAGLAW is defined but + ! LINEAR_DRAG is not. +DRAG_BG_VEL = 0.1 ! [m s-1] default = 0.0 + ! DRAG_BG_VEL is either the assumed bottom velocity (with LINEAR_DRAG) or an + ! unresolved velocity that is combined with the resolved velocity to estimate + ! the velocity magnitude. DRAG_BG_VEL is only used when BOTTOMDRAGLAW is + ! defined. +BBL_THICK_MIN = 0.1 ! [m] default = 0.0 + ! The minimum bottom boundary layer thickness that can be used with + ! BOTTOMDRAGLAW. This might be Kv/(cdrag*drag_bg_vel) to give Kv as the minimum + ! near-bottom viscosity. +KV = 1.0E-04 ! [m2 s-1] + ! The background kinematic viscosity in the interior. The molecular value, ~1e-6 + ! m2 s-1, may be used. + +! === module MOM_thickness_diffuse === +KHTH = 1.0 ! [m2 s-1] default = 0.0 + ! The background horizontal thickness diffusivity. +KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 + ! The maximum horizontal thickness diffusivity. + +! === module MOM_dynamics_split_RK2 === + +! === module MOM_continuity === + +! === module MOM_continuity_PPM === +ETA_TOLERANCE = 1.0E-06 ! [m] default = 1.1E-09 + ! The tolerance for the differences between the barotropic and baroclinic + ! estimates of the sea surface height due to the fluxes through each face. The + ! total tolerance for SSH is 4 times this value. The default is + ! 0.5*NK*ANGSTROM, and this should not be set less than about + ! 10^-15*MAXIMUM_DEPTH. +VELOCITY_TOLERANCE = 0.001 ! [m s-1] default = 3.0E+08 + ! The tolerance for barotropic velocity discrepancies between the barotropic + ! solution and the sum of the layer thicknesses. + +! === module MOM_CoriolisAdv === +BOUND_CORIOLIS = True ! [Boolean] default = False + ! If true, the Coriolis terms at u-points are bounded by the four estimates of + ! (f+rv)v from the four neighboring v-points, and similarly at v-points. This + ! option would have no effect on the SADOURNY Coriolis scheme if it were + ! possible to use centered difference thickness fluxes. + +! === module MOM_PressureForce === + +! === module MOM_PressureForce_AFV === + +! === module MOM_hor_visc === +AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 + ! The velocity scale which is multiplied by the cube of the grid spacing to + ! calculate the biharmonic viscosity. The final viscosity is the largest of this + ! scaled viscosity, the Smagorinsky and Leith viscosities, and AH. +SMAGORINSKY_AH = True ! [Boolean] default = False + ! If true, use a biharmonic Smagorinsky nonlinear eddy viscosity. +SMAG_BI_CONST = 0.06 ! [nondim] default = 0.0 + ! The nondimensional biharmonic Smagorinsky constant, typically 0.015 - 0.06. + +! === module MOM_vert_friction === +MAXVEL = 10.0 ! [m s-1] default = 3.0E+08 + ! The maximum velocity allowed before the velocity components are truncated. + +! === module MOM_barotropic === +BOUND_BT_CORRECTION = True ! [Boolean] default = False + ! If true, the corrective pseudo mass-fluxes into the barotropic solver are + ! limited to values that require less than maxCFL_BT_cont to be accommodated. +NONLINEAR_BT_CONTINUITY = True ! [Boolean] default = False + ! If true, use nonlinear transports in the barotropic continuity equation. This + ! does not apply if USE_BT_CONT_TYPE is true. +BT_PROJECT_VELOCITY = True ! [Boolean] default = False + ! If true, step the barotropic velocity first and project out the velocity + ! tendency by 1+BEBT when calculating the transport. The default (false) is to + ! use a predictor continuity step to find the pressure field, and then to do a + ! corrector continuity step using a weighted average of the old and new + ! velocities, with weights of (1-BEBT) and BEBT. +BEBT = 0.2 ! [nondim] default = 0.1 + ! BEBT determines whether the barotropic time stepping uses the forward-backward + ! time-stepping scheme or a backward Euler scheme. BEBT is valid in the range + ! from 0 (for a forward-backward treatment of nonrotating gravity waves) to 1 + ! (for a backward Euler treatment). In practice, BEBT must be greater than about + ! 0.05. +DTBT = -0.95 ! [s or nondim] default = -0.98 + ! The barotropic time step, in s. DTBT is only used with the split explicit time + ! stepping. To set the time step automatically based the maximum stable value + ! use 0, or a negative value gives the fraction of the stable value. Setting + ! DTBT to 0 is the same as setting it to -0.98. The value of DTBT that will + ! actually be used is an integer fraction of DT, rounding down. + +! === module MOM_mixed_layer_restrat === +MIXEDLAYER_RESTRAT = True ! [Boolean] default = False + ! If true, a density-gradient dependent re-stratifying flow is imposed in the + ! mixed layer. Can be used in ALE mode without restriction but in layer mode can + ! only be used if BULKMIXEDLAYER is true. +FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 + ! A nondimensional coefficient that is proportional to the ratio of the + ! deformation radius to the dominant lengthscale of the submesoscale mixed layer + ! instabilities, times the minimum of the ratio of the mesoscale eddy kinetic + ! energy to the large-scale geostrophic kinetic energy or 1 plus the square of + ! the grid spacing over the deformation radius, as detailed by Fox-Kemper et al. + ! (2010) + +! === module MOM_diagnostics === + +! === module MOM_diabatic_driver === +! The following parameters are used for diabatic processes. + +! === module MOM_entrain_diffusive === +MAX_ENT_IT = 20 ! default = 5 + ! The maximum number of iterations that may be used to calculate the interior + ! diapycnal entrainment. +TOLERANCE_ENT = 1.0E-05 ! [m] default = 1.341640786499874E-05 + ! The tolerance with which to solve for entrainment values. + +! === module MOM_set_diffusivity === + +! === module MOM_bkgnd_mixing === +! Adding static vertical background mixing coefficients +KD = 2.0E-05 ! [m2 s-1] default = 0.0 + ! The background diapycnal diffusivity of density in the interior. Zero or the + ! molecular value, ~1e-7 m2 s-1, may be used. + +! === module MOM_kappa_shear === +! Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008 +USE_JACKSON_PARAM = True ! [Boolean] default = False + ! If true, use the Jackson-Hallberg-Legg (JPO 2008) shear mixing + ! parameterization. +MAX_RINO_IT = 25 ! [nondim] default = 50 + ! The maximum number of iterations that may be used to estimate the Richardson + ! number driven mixing. + +! === module MOM_diabatic_aux === +! The following parameters are used for auxiliary diabatic processes. +RECLAIM_FRAZIL = False ! [Boolean] default = True + ! If true, try to use any frazil heat deficit to cool any overlying layers down + ! to the freezing point, thereby avoiding the creation of thin ice when the SST + ! is above the freezing point. + +! === module MOM_mixed_layer === +MSTAR = 0.3 ! [nondim] default = 1.2 + ! The ratio of the friction velocity cubed to the TKE input to the mixed layer. +BULK_RI_ML = 0.05 ! [nondim] + ! The efficiency with which mean kinetic energy released by mechanically forced + ! entrainment of the mixed layer is converted to turbulent kinetic energy. +ABSORB_ALL_SW = True ! [Boolean] default = False + ! If true, all shortwave radiation is absorbed by the ocean, instead of passing + ! through to the bottom mud. +TKE_DECAY = 10.0 ! [nondim] default = 2.5 + ! TKE_DECAY relates the vertical rate of decay of the TKE available for + ! mechanical entrainment to the natural Ekman depth. +HMIX_MIN = 2.0 ! [m] default = 0.0 + ! The minimum mixed layer depth if the mixed layer depth is determined + ! dynamically. +LIMIT_BUFFER_DETRAIN = True ! [Boolean] default = False + ! If true, limit the detrainment from the buffer layers to not be too different + ! from the neighbors. +DEPTH_LIMIT_FLUXES = 0.1 ! [m] default = 0.2 + ! The surface fluxes are scaled away when the total ocean depth is less than + ! DEPTH_LIMIT_FLUXES. +CORRECT_ABSORPTION_DEPTH = True ! [Boolean] default = False + ! If true, the average depth at which penetrating shortwave radiation is + ! absorbed is adjusted to match the average heating depth of an exponential + ! profile by moving some of the heating upward in the water column. + +! === module MOM_opacity === +PEN_SW_SCALE = 15.0 ! [m] default = 0.0 + ! The vertical absorption e-folding depth of the penetrating shortwave + ! radiation. +PEN_SW_FRAC = 0.42 ! [nondim] default = 0.0 + ! The fraction of the shortwave radiation that penetrates below the surface. + +! === module MOM_tracer_advect === + +! === module MOM_tracer_hor_diff === +KHTR = 1.0 ! [m2 s-1] default = 0.0 + ! The background along-isopycnal tracer diffusivity. +KHTR_MAX = 900.0 ! [m2 s-1] default = 0.0 + ! The maximum along-isopycnal tracer diffusivity. +DIFFUSE_ML_TO_INTERIOR = True ! [Boolean] default = False + ! If true, enable epipycnal mixing between the surface boundary layer and the + ! interior. +ML_KHTR_SCALE = 0.0 ! [nondim] default = 1.0 + ! With Diffuse_ML_interior, the ratio of the truly horizontal diffusivity in the + ! mixed layer to the epipycnal diffusivity. The valid range is 0 to 1. + +! === module MOM_sum_output === +MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 + ! The run will be stopped, and the day set to a very large value if the velocity + ! is truncated more than MAXTRUNC times between energy saves. Set MAXTRUNC to 0 + ! to stop if there is any truncation of velocities. +ENERGYSAVEDAYS = 0.25 ! [days] default = 1.0 + ! The interval in units of TIMEUNIT between saves of the energies of the run and + ! other globally summed diagnostics. + +! === module MOM_surface_forcing === +BUOY_CONFIG = "linear" ! default = "zero" + ! The character string that indicates how buoyancy forcing is specified. Valid + ! options include (file), (zero), (linear), (USER), (BFB) and (NONE). +WIND_CONFIG = "gyres" ! default = "zero" + ! The character string that indicates how wind forcing is specified. Valid + ! options include (file), (2gyre), (1gyre), (gyres), (zero), and (USER). +TAUX_SIN_AMP = 0.1 ! [Pa] default = 0.0 + ! With the gyres wind_config, the sine amplitude in the zonal wind stress + ! profile: B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L). +TAUX_N_PIS = 1.0 ! [nondim] default = 0.0 + ! With the gyres wind_config, the number of gyres in the zonal wind stress + ! profile: n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L). +RESTOREBUOY = True ! [Boolean] default = False + ! If true, the buoyancy fluxes drive the model back toward some specified + ! surface state with a rate given by FLUXCONST. +FLUXCONST = 0.5 ! [m day-1] default = 0.0 + ! The constant that relates the restoring surface fluxes to the relative surface + ! anomalies (akin to a piston velocity). Note the non-MKS units. +SST_NORTH = 27.0 ! [deg C] default = 0.0 + ! With buoy_config linear, the sea surface temperature at the northern end of + ! the domain toward which to to restore. +SST_SOUTH = 3.0 ! [deg C] default = 0.0 + ! With buoy_config linear, the sea surface temperature at the southern end of + ! the domain toward which to to restore. +GUST_CONST = 0.02 ! [Pa] default = 0.0 + ! The background gustiness in the winds. + +! === module MOM_main (MOM_driver) === +DT_FORCING = 3600.0 ! [s] default = 900.0 + ! The time step for changing forcing, coupling with other components, or + ! potentially writing certain diagnostics. The default value is given by DT. +DAYMAX = 3.0 ! [days] + ! The final time of the whole simulation, in units of TIMEUNIT seconds. This + ! also sets the potential end time of the present run segment if the end time is + ! not set via ocean_solo_nml in input.nml. +RESTART_CONTROL = 3 ! default = 1 + ! An integer whose bits encode which restart files are written. Add 2 (bit 1) + ! for a time-stamped file, and odd (bit 0) for a non-time-stamped file. A + ! non-time-stamped restart file is saved at the end of the run segment for any + ! non-negative value. +RESTINT = 365.0 ! [days] default = 0.0 + ! The interval between saves of the restart file in units of TIMEUNIT. Use 0 + ! (the default) to not save incremental restart files at all. + +! === module MOM_write_cputime === +MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 + ! The maximum amount of cpu time per processor for which MOM should run before + ! saving a restart file and quitting with a return value that indicates that a + ! further run is required to complete the simulation. If automatic restarts are + ! not desired, use a negative value for MAXCPU. MAXCPU has units of wall-clock + ! seconds, so the actual CPU time used is larger by a factor of the number of + ! processors used. + +! Debugging parameters set to non-default values +U_TRUNC_FILE = "U_velocity_truncations" ! default = "" + ! The absolute path to a file into which the accelerations leading to zonal + ! velocity truncations are written. Undefine this for efficiency if this + ! diagnostic is not needed. +V_TRUNC_FILE = "V_velocity_truncations" ! default = "" + ! The absolute path to a file into which the accelerations leading to meridional + ! velocity truncations are written. Undefine this for efficiency if this + ! diagnostic is not needed. diff --git a/.testing/p0/MOM_override b/.testing/p0/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/p0/diag_table b/.testing/p0/diag_table new file mode 100644 index 0000000000..68c71dd2c4 --- /dev/null +++ b/.testing/p0/diag_table @@ -0,0 +1,91 @@ +"MOM benchmark Experiment" +1 1 1 0 0 0 +"prog", 1,"days",1,"days","time", +#"ave_prog", 5,"days",1,"days","Time",365,"days" +#"cont", 5,"days",1,"days","Time",365,"days" + +#This is the field section of the diag_table. + +# Prognostic Ocean fields: +#========================= + +"ocean_model","u","u","prog","all",.false.,"none",2 +"ocean_model","v","v","prog","all",.false.,"none",2 +"ocean_model","h","h","prog","all",.false.,"none",1 +"ocean_model","e","e","prog","all",.false.,"none",2 +"ocean_model","temp","temp","prog","all",.false.,"none",2 +#"ocean_model","salt","salt","prog","all",.false.,"none",2 + +#"ocean_model","u","u","ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","v","v","ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","h","h","ave_prog_%4yr_%3dy","all",.true.,"none",1 +#"ocean_model","e","e","ave_prog_%4yr_%3dy","all",.true.,"none",2 + +# Auxilary Tracers: +#================== +#"ocean_model","vintage","vintage","prog_%4yr_%3dy","all",.false.,"none",2 +#"ocean_model","age","age","prog_%4yr_%3dy","all",.false.,"none",2 + +# Continuity Equation Terms: +#=========================== +#"ocean_model","dhdt","dhdt","cont_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","wd","wd","cont_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","uh","uh","cont_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","vh","vh","cont_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","h_rho","h_rho","cont_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","uh_rho","uh_rho","cont_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","vh_rho","vh_rho","cont_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","uhGM_rho","uhGM_rho","cont_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","vhGM_rho","vhGM_rho","cont_%4yr_%3dy","all",.true.,"none",2 + +# +# Tracer Fluxes: +#================== +#"ocean_model","T_adx", "T_adx", "ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","T_ady", "T_ady", "ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","T_diffx","T_diffx","ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","T_diffy","T_diffy","ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","S_adx", "S_adx", "ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","S_ady", "S_ady", "ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","S_diffx","S_diffx","ave_prog_%4yr_%3dy","all",.true.,"none",2 +#"ocean_model","S_diffy","S_diffy","ave_prog_%4yr_%3dy","all",.true.,"none",2 + +# testing +# ======= +#"ocean_model","Kv_u","Kv_u","prog","all",.false.,"none",2 +#"ocean_model","Kv_v","Kv_v","prog","all",.false.,"none",2 + +#============================================================================================= +# +#===- This file can be used with diag_manager/v2.0a (or higher) ==== +# +# +# FORMATS FOR FILE ENTRIES (not all input values are used) +# ------------------------ +# +#"file_name", output_freq, "output_units", format, "time_units", "time_long_name", ... +# (opt) new_file_frequecy, (opt) "new_file_freq_units", "new_file_start_date" +# +# +#output_freq: > 0 output frequency in "output_units" +# = 0 output frequency every time step +# =-1 output frequency at end of run +# +#output_units = units used for output frequency +# (years, months, days, minutes, hours, seconds) +# +#time_units = units used to label the time axis +# (days, minutes, hours, seconds) +# +# +# FORMAT FOR FIELD ENTRIES (not all input values are used) +# ------------------------ +# +#"module_name", "field_name", "output_name", "file_name" "time_sampling", time_avg, "other_opts", packing +# +#time_avg = .true. or .false. +# +#packing = 1 double precision +# = 2 float +# = 4 packed 16-bit integers +# = 8 packed 1-byte (not tested?) diff --git a/.testing/p0/input.nml b/.testing/p0/input.nml new file mode 100644 index 0000000000..41555b8822 --- /dev/null +++ b/.testing/p0/input.nml @@ -0,0 +1,22 @@ + &MOM_input_nml + output_directory = './', + input_filename = 'n' + restart_input_dir = 'INPUT/', + restart_output_dir = 'RESTART/', + parameter_filename = 'MOM_input', + 'MOM_override' / + + &diag_manager_nml + / + + &fms_nml + clock_grain='ROUTINE' + clock_flags='SYNC' + !domains_stack_size = 955296 + domains_stack_size = 14256000 + stack_size =0 / + +!&ocean_solo_nml +! hours = 1 +! !days = 1 +!/ diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input new file mode 100644 index 0000000000..e4d1694e72 --- /dev/null +++ b/.testing/tc0/MOM_input @@ -0,0 +1,238 @@ +! This file was written by the model and records the non-default parameters used at run-time. + +! === module MOM === +DO_UNIT_TESTS = True ! [Boolean] default = False + ! If True, exercises unit tests at model start up. +SPLIT = False ! [Boolean] default = True + ! Use the split time stepping if true. +ENABLE_THERMODYNAMICS = False ! [Boolean] default = True + ! If true, Temperature and salinity are used as state + ! variables. +ADIABATIC = True ! [Boolean] default = False + ! There are no diapycnal mass fluxes if ADIABATIC is + ! true. This assumes that KD = KDML = 0.0 and that + ! there is no buoyancy forcing, but makes the model + ! faster by eliminating subroutine calls. +DT = 8.64E+04 ! [s] + ! The (baroclinic) dynamics time step. The time-step that + ! is actually used will be an integer fraction of the + ! forcing time-step (DT_FORCING in ocean-only mode or the + ! coupling timestep in coupled mode.) + +! === module MOM_domains === +NIGLOBAL = 4 ! + ! The total number of thickness grid points in the + ! x-direction in the physical domain. With STATIC_MEMORY_ + ! this is set in MOM_memory.h at compile time. +NJGLOBAL = 4 ! + ! The total number of thickness grid points in the + ! y-direction in the physical domain. With STATIC_MEMORY_ + ! this is set in MOM_memory.h at compile time. + +! === module MOM_hor_index === +! Sets the horizontal array index types. + +! === module MOM_verticalGrid === +! Parameters providing information about the vertical grid. +NK = 1 ! [nondim] + ! The number of model layers. + +! === module MOM_tracer_registry === + +! === module MOM_restart === + +! === module MOM_tracer_flow_control === + +! === module MOM_fixed_initialization === + +! === module MOM_grid_init === +GRID_CONFIG = "cartesian" ! + ! A character string that determines the method for + ! defining the horizontal grid. Current options are: + ! mosaic - read the grid from a mosaic (supergrid) + ! file set by GRID_FILE. + ! cartesian - use a (flat) Cartesian grid. + ! spherical - use a simple spherical grid. + ! mercator - use a Mercator spherical grid. +SOUTHLAT = 0.0 ! [degrees] + ! The southern latitude of the domain or the equivalent + ! starting value for the y-axis. +LENLAT = 1.0 ! [degrees] + ! The latitudinal or y-direction length of the domain. +LENLON = 1.0 ! [degrees] + ! The longitudinal or x-direction length of the domain. +TOPO_CONFIG = "flat" ! + ! This specifies how bathymetry is specified: + ! file - read bathymetric information from the file + ! specified by (TOPO_FILE). + ! flat - flat bottom set to MAXIMUM_DEPTH. + ! bowl - an analytically specified bowl-shaped basin + ! ranging between MAXIMUM_DEPTH and MINIMUM_DEPTH. + ! spoon - a similar shape to 'bowl', but with an vertical + ! wall at the southern face. + ! halfpipe - a zonally uniform channel with a half-sine + ! profile in the meridional direction. + ! benchmark - use the benchmark test case topography. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! ISOMIP - use a slope and channel configuration for the + ! ISOMIP test case. + ! DOME2D - use a shelf and slope configuration for the + ! DOME2D gravity current/overflow test case. + ! seamount - Gaussian bump for spontaneous motion test case. + ! Phillips - ACC-like idealized topography used in the Phillips config. + ! USER - call a user modified routine. +MAXIMUM_DEPTH = 100.0 ! [m] + ! The maximum depth of the ocean. + +! === module MOM_open_boundary === +! Controls where open boundaries are located, what kind of boundary condition to impose, and what data to apply, if any. + +! === module MOM_coord_initialization === +COORD_CONFIG = "none" ! + ! This specifies how layers are to be defined: + ! file - read coordinate information from the file + ! specified by (COORD_FILE). + ! BFB - Custom coords for buoyancy-forced basin case + ! based on SST_S, T_BOT and DRHO_DT. + ! linear - linear based on interfaces not layers + ! layer_ref - linear based on layer densities + ! ts_ref - use reference temperature and salinity + ! ts_range - use range of temperature and salinity + ! (T_REF and S_REF) to determine surface density + ! and GINT calculate internal densities. + ! gprime - use reference density (RHO_0) for surface + ! density and GINT calculate internal densities. + ! ts_profile - use temperature and salinity profiles + ! (read from COORD_FILE) to set layer densities. + ! USER - call a user modified routine. + +! === module MOM_grid === +! Parameters providing information about the lateral grid. + +! === module MOM_state_initialization === +THICKNESS_CONFIG = "uniform" ! + ! A string that determines how the initial layer + ! thicknesses are specified for a new run: + ! file - read interface heights from the file specified + ! thickness_file - read thicknesses from the file specified + ! by (THICKNESS_FILE). + ! coord - determined by ALE coordinate. + ! uniform - uniform thickness layers evenly distributed + ! between the surface and MAXIMUM_DEPTH. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! ISOMIP - use a configuration for the + ! ISOMIP test case. + ! benchmark - use the benchmark test case thicknesses. + ! search - search a density profile for the interface + ! densities. This is not yet implemented. + ! circle_obcs - the circle_obcs test case is used. + ! DOME2D - 2D version of DOME initialization. + ! adjustment2d - TBD AJA. + ! sloshing - TBD AJA. + ! seamount - TBD AJA. + ! soliton - Equatorial Rossby soliton. + ! rossby_front - a mixed layer front in thermal wind balance. + ! USER - call a user modified routine. + +! === module MOM_diag_mediator === + +USE_GRID_SPACE_DIAG_COORDINATE_AXES = True ! [Boolean] default = False + ! If true, use a grid index coordinate convention for diagnostic axes. + +! === module MOM_MEKE === + +! === module MOM_lateral_mixing_coeffs === + +! === module MOM_set_visc === +BOTTOMDRAGLAW = False ! [Boolean] default = True + ! If true, the bottom stress is calculated with a drag + ! law of the form c_drag*|u|*u. The velocity magnitude + ! may be an assumed value or it may be based on the + ! actual velocity in the bottommost HBBL, depending on + ! LINEAR_DRAG. +HBBL = 1.0 ! [m] + ! The thickness of a bottom boundary layer with a + ! viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or + ! the thickness over which near-bottom velocities are + ! averaged for the drag law if BOTTOMDRAGLAW is defined + ! but LINEAR_DRAG is not. +KV = 1.0 ! [m2 s-1] + ! The background kinematic viscosity in the interior. + ! The molecular value, ~1e-6 m2 s-1, may be used. + +! === module MOM_continuity === + +! === module MOM_continuity_PPM === +SIMPLE_2ND_PPM_CONTINUITY = True ! [Boolean] default = False + ! If true, CONTINUITY_PPM uses a simple 2nd order + ! (arithmetic mean) interpolation of the edge values. + ! This may give better PV conservation propterties. While + ! it formally reduces the accuracy of the continuity + ! solver itself in the strongly advective limit, it does + ! not reduce the overall order of accuracy of the dynamic + ! core. + +! === module MOM_CoriolisAdv === + +! === module MOM_PressureForce === + +! === module MOM_PressureForce_AFV === + +! === module MOM_hor_visc === + +! === module MOM_vert_friction === +HMIX_FIXED = 1.0 ! [m] + ! The prescribed depth over which the near-surface + ! viscosity and diffusivity are elevated when the bulk + ! mixed layer is not used. + +! === module MOM_thickness_diffuse === + +! === module MOM_mixed_layer_restrat === + +! === module MOM_diabatic_driver === +! The following parameters are used for diabatic processes. + +! === module MOM_tracer_advect === + +! === module MOM_tracer_hor_diff === + +! === module MOM_neutral_diffusion === +! This module implements neutral diffusion of tracers + +! === module MOM_surface_forcing === +BUOY_CONFIG = "zero" ! + ! The character string that indicates how buoyancy forcing + ! is specified. Valid options include (file), (zero), + ! (linear), (USER), (BFB) and (NONE). +WIND_CONFIG = "zero" ! + ! The character string that indicates how wind forcing + ! is specified. Valid options include (file), (2gyre), + ! (1gyre), (gyres), (zero), and (USER). + +! === module MOM_restart === + +! === module MOM_sum_output === + +! === module MOM_write_cputime === + +! === module MOM_main (MOM_driver) === +DAYMAX = 2.0 ! [days] + ! The final time of the whole simulation, in units of + ! TIMEUNIT seconds. This also sets the potential end + ! time of the present run segment if the end time is + ! not set via ocean_solo_nml in input.nml. +ENERGYSAVEDAYS = 1.0 + +! === module MOM_file_parser === + +DIAG_AS_CHKSUM = True +DEBUG = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +USE_GM_WORK_BUG = True ! [Boolean] default = True +FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc0/MOM_override b/.testing/tc0/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc0/diag_table b/.testing/tc0/diag_table new file mode 100644 index 0000000000..091dc46933 --- /dev/null +++ b/.testing/tc0/diag_table @@ -0,0 +1,2 @@ +"MOM test configuration 0" +1 1 1 0 0 0 diff --git a/.testing/tc0/input.nml b/.testing/tc0/input.nml new file mode 100644 index 0000000000..961963ea8e --- /dev/null +++ b/.testing/tc0/input.nml @@ -0,0 +1,20 @@ +&MOM_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT' + restart_output_dir = 'RESTART' + parameter_filename = + 'MOM_input', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + domains_stack_size = 710000 + stack_size = 0 +/ + +&ocean_domains_nml +/ diff --git a/.testing/tc1.a/MOM_input b/.testing/tc1.a/MOM_input new file mode 120000 index 0000000000..dca928737e --- /dev/null +++ b/.testing/tc1.a/MOM_input @@ -0,0 +1 @@ +../tc1/MOM_input \ No newline at end of file diff --git a/.testing/tc1.a/MOM_override b/.testing/tc1.a/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc1.a/MOM_tc_variant b/.testing/tc1.a/MOM_tc_variant new file mode 100644 index 0000000000..26407baf50 --- /dev/null +++ b/.testing/tc1.a/MOM_tc_variant @@ -0,0 +1,2 @@ +#override SPLIT=False +#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1.a/diag_table b/.testing/tc1.a/diag_table new file mode 120000 index 0000000000..bf2ad677b6 --- /dev/null +++ b/.testing/tc1.a/diag_table @@ -0,0 +1 @@ +../tc1/diag_table \ No newline at end of file diff --git a/.testing/tc1.a/input.nml b/.testing/tc1.a/input.nml new file mode 100644 index 0000000000..3c7dcf7bea --- /dev/null +++ b/.testing/tc1.a/input.nml @@ -0,0 +1,20 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_tc_variant', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + clock_grain = 'ROUTINE' + clock_flags = 'SYNC' + domains_stack_size = 955296 + stack_size = 0 +/ diff --git a/.testing/tc1.b/MOM_input b/.testing/tc1.b/MOM_input new file mode 120000 index 0000000000..dca928737e --- /dev/null +++ b/.testing/tc1.b/MOM_input @@ -0,0 +1 @@ +../tc1/MOM_input \ No newline at end of file diff --git a/.testing/tc1.b/MOM_override b/.testing/tc1.b/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc1.b/MOM_tc_variant b/.testing/tc1.b/MOM_tc_variant new file mode 100644 index 0000000000..173196f164 --- /dev/null +++ b/.testing/tc1.b/MOM_tc_variant @@ -0,0 +1,3 @@ +#override SPLIT=False +#override USE_RK2=True +#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1.b/diag_table b/.testing/tc1.b/diag_table new file mode 120000 index 0000000000..bf2ad677b6 --- /dev/null +++ b/.testing/tc1.b/diag_table @@ -0,0 +1 @@ +../tc1/diag_table \ No newline at end of file diff --git a/.testing/tc1.b/input.nml b/.testing/tc1.b/input.nml new file mode 100644 index 0000000000..3c7dcf7bea --- /dev/null +++ b/.testing/tc1.b/input.nml @@ -0,0 +1,20 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_tc_variant', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + clock_grain = 'ROUTINE' + clock_flags = 'SYNC' + domains_stack_size = 955296 + stack_size = 0 +/ diff --git a/.testing/tc1/MOM_input b/.testing/tc1/MOM_input new file mode 100644 index 0000000000..151c093ff9 --- /dev/null +++ b/.testing/tc1/MOM_input @@ -0,0 +1,588 @@ +/* This input file provides the adjustable run-time parameters for version 6 of + the Modular Ocean Model (MOM6), a numerical ocean model developed at NOAA-GFDL. + Where appropriate, parameters use usually given in MKS units. + + This particular file is for the example in benchmark. + + This MOM_input file typically contains only the non-default values that are + needed to reproduce this example. A full list of parameters for this example + can be found in the corresponding MOM_parameter_doc.all file which is + generated by the model at run-time. */ + +!SYMMETRIC_MEMORY_ = False ! [Boolean] + ! If defined, the velocity point data domain includes + ! every face of the thickness points. In other words, + ! some arrays are larger than others, depending on where + ! they are on the staggered grid. Also, the starting + ! index of the velocity-point arrays is usually 0, not 1. + ! This can only be set at compile time. +!STATIC_MEMORY_ = False ! [Boolean] + ! If STATIC_MEMORY_ is defined, the principle variables + ! will have sizes that are statically determined at + ! compile time. Otherwise the sizes are not determined + ! until run time. The STATIC option is substantially + ! faster, but does not allow the PE count to be changed + ! at run time. This can only be set at compile time. +NIHALO = 4 ! default = 2 + ! The number of halo points on each side in the + ! x-direction. With STATIC_MEMORY_ this is set as NIHALO_ + ! in MOM_memory.h at compile time; without STATIC_MEMORY_ + ! the default is NIHALO_ in MOM_memory.h (if defined) or 2. +NJHALO = 4 ! default = 2 + ! The number of halo points on each side in the + ! y-direction. With STATIC_MEMORY_ this is set as NJHALO_ + ! in MOM_memory.h at compile time; without STATIC_MEMORY_ + ! the default is NJHALO_ in MOM_memory.h (if defined) or 2. +NIGLOBAL = 10 ! + ! The total number of thickness grid points in the + ! x-direction in the physical domain. With STATIC_MEMORY_ + ! this is set in MOM_memory.h at compile time. +NJGLOBAL = 8 ! + ! The total number of thickness grid points in the + ! y-direction in the physical domain. With STATIC_MEMORY_ + ! this is set in MOM_memory.h at compile time. +!NIPROC = 12 ! + ! The number of processors in the x-direction. With + ! STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +!NJPROC = 6 ! + ! The number of processors in the x-direction. With + ! STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +!LAYOUT = 12, 6 ! + ! The processor layout that was acutally used. +IO_LAYOUT = 1, 1 ! default = 0 + ! The processor layout to be used, or 0,0 to automatically + ! set the io_layout to be the same as the layout. + +! === module MOM_grid === +! Parameters providing information about the vertical grid. +NK = 8 ! [nondim] + ! The number of model layers. + +! === module MOM_verticalGrid === +! Parameters providing information about the vertical grid. + +! === module MOM === +THICKNESSDIFFUSE = True ! [Boolean] default = False + ! If true, interfaces or isopycnal surfaces are diffused, + ! depending on the value of FULL_THICKNESSDIFFUSE. +THICKNESSDIFFUSE_FIRST = True ! [Boolean] default = False + ! If true, do thickness diffusion before dynamics. + ! This is only used if THICKNESSDIFFUSE is true. +MIXEDLAYER_RESTRAT = True ! [Boolean] default = False + ! If true, a density-gradient dependent re-stratifying + ! flow is imposed in the mixed layer. + ! This is only used if BULKMIXEDLAYER is true. +DT = 900.0 ! [s] + ! The (baroclinic) dynamics time step. The time-step that + ! is actually used will be an integer fraction of the + ! forcing time-step (DT_FORCING in ocean-only mode or the + ! coupling timestep in coupled mode.) +DT_THERM = 3600.0 ! [s] default = 900.0 + ! The thermodynamic and tracer advection time step. + ! Ideally DT_THERM should be an integer multiple of DT + ! and less than the forcing or coupling time-step. + ! By default DT_THERM is set to DT. +DTBT_RESET_PERIOD = 0.0 ! [s] default = 3600.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 + ! dynamic, DTBT will be set at least every forcing time + ! step, and if 0, every dynamics time step. The default is + ! set by DT_THERM. This is only used if SPLIT is true. +FRAZIL = True ! [Boolean] default = False + ! If true, water freezes if it gets too cold, and the + ! the accumulated heat deficit is returned in the + ! surface state. FRAZIL is only used if + ! ENABLE_THERMODYNAMICS is true. +C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 + ! The heat capacity of sea water, approximated as a + ! constant. This is only used if ENABLE_THERMODYNAMICS is + ! true. The default value is from the TEOS-10 definition + ! of conservative temperature. +SAVE_INITIAL_CONDS = True ! [Boolean] default = False + ! If true, write the initial conditions to a file given + ! by IC_OUTPUT_FILE. +IC_OUTPUT_FILE = "GOLD_IC" ! default = "MOM_IC" + ! The file into which to write the initial conditions. + +! === module MOM_tracer_registry === + +! === module MOM_tracer_flow_control === +USE_IDEAL_AGE_TRACER = True ! [Boolean] default = False + ! If true, use the ideal_age_example tracer package. + +! === module ideal_age_example === +INPUTDIR = "INPUT" ! default = "." + ! The directory in which input files are found. +COORD_CONFIG = "ts_range" ! + ! This specifies how layers are to be defined: + ! file - read coordinate information from the file + ! specified by (COORD_FILE). + ! linear - linear based on interfaces not layesrs. + ! ts_ref - use reference temperature and salinity + ! ts_range - use range of temperature and salinity + ! (T_REF and S_REF) to determine surface density + ! and GINT calculate internal densities. + ! gprime - use reference density (RHO_0) for surface + ! density and GINT calculate internal densities. + ! ts_profile - use temperature and salinity profiles + ! (read from COORD_FILE) to set layer densities. + ! USER - call a user modified routine. +TS_RANGE_T_LIGHT = 25.0 ! [degC] default = 10.0 + ! The initial temperature of the lightest layer when + ! COORD_CONFIG is set to ts_range. +TS_RANGE_T_DENSE = 3.0 ! [degC] default = 10.0 + ! The initial temperature of the densest layer when + ! COORD_CONFIG is set to ts_range. +TS_RANGE_RESOLN_RATIO = 5.0 ! [nondim] default = 1.0 + ! The ratio of density space resolution in the densest + ! part of the range to that in the lightest part of the + ! range when COORD_CONFIG is set to ts_range. Values + ! greater than 1 increase the resolution of the denser water. + +! === module MOM_grid_init === +GRID_CONFIG = "mercator" ! + ! A character string that determines the method for + ! defining the horizontal grid. Current options are: + ! mosaic - read the grid from a mosaic (supergrid) + ! file set by GRID_FILE. + ! cartesian - use a (flat) Cartesian grid. + ! spherical - use a simple spherical grid. + ! mercator - use a Mercator spherical grid. +SOUTHLAT = -41.0 ! [degrees] + ! The southern latitude of the domain. +LENLAT = 41.0 ! [degrees] + ! The latitudinal length of the domain. +LENLON = 90.0 ! [degrees] + ! The longitudinal length of the domain. +ISOTROPIC = True ! [Boolean] default = False + ! If true, an isotropic grid on a sphere (also known as + ! a Mercator grid) is used. With an isotropic grid, the + ! meridional extent of the domain (LENLAT), the zonal + ! extent (LENLON), and the number of grid points in each + ! direction are _not_ independent. In MOM the meridional + ! extent is determined to fit the zonal extent and the + ! number of grid points, while grid is perfectly isotropic. +TOPO_CONFIG = "benchmark" ! + ! This specifies how bathymetry is specified: + ! file - read bathymetric information from the file + ! specified by (TOPO_FILE). + ! flat - flat bottom set to MAXIMUM_DEPTH. + ! bowl - an analytically specified bowl-shaped basin + ! ranging between MAXIMUM_DEPTH and MINIMUM_DEPTH. + ! spoon - a similar shape to 'bowl', but with an vertical + ! wall at the southern face. + ! halfpipe - a zonally uniform channel with a half-sine + ! profile in the meridional direction. + ! benchmark - use the benchmark test case topography. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! DOME2D - use a shelf and slope configuration for the + ! DOME2D gravity current/overflow test case. + ! seamount - Gaussian bump for spontaneous motion test case. + ! USER - call a user modified routine. + +! === module benchmark_initialize_topography === +MINIMUM_DEPTH = 1.0 ! [m] default = 0.0 + ! The minimum depth of the ocean. +MAXIMUM_DEPTH = 5500.0 ! [m] + ! The maximum depth of the ocean. +THICKNESS_CONFIG = "benchmark" ! + ! A string that determines how the initial layer + ! thicknesses are specified for a new run: + ! file - read interface heights from the file specified + ! thickness_file - read thicknesses from the file specified + ! by (THICKNESS_FILE). + ! uniform - uniform thickness layers evenly distributed + ! between the surface and MAXIMUM_DEPTH. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! benchmark - use the benchmark test case thicknesses. + ! search - search a density profile for the interface + ! densities. This is not yet implemented. + ! circle_obcs - the circle_obcs test case is used. + ! DOME2D - 2D version of DOME initialization. + ! adjustment2d - TBD AJA. + ! sloshing - TBD AJA. + ! seamount - TBD AJA. + ! USER - call a user modified routine. +TS_CONFIG = "benchmark" ! + ! A string that determines how the initial tempertures + ! and salinities are specified for a new run: + ! file - read velocities from the file specified + ! by (TS_FILE). + ! fit - find the temperatures that are consistent with + ! the layer densities and salinity S_REF. + ! TS_profile - use temperature and salinity profiles + ! (read from TS_FILE) to set layer densities. + ! benchmark - use the benchmark test case T & S. + ! linear - linear in logical layer space. + ! DOME2D - 2D DOME initialization. + ! adjustment2d - TBD AJA. + ! sloshing - TBD AJA. + ! seamount - TBD AJA. + ! USER - call a user modified routine. + +! === module MOM_MEKE === + +! === module MOM_lateral_mixing_coeffs === +USE_VARIABLE_MIXING = True ! [Boolean] default = False + ! If true, the variable mixing code will be called. This + ! allows diagnostics to be created even if the scheme is + ! not used. If KHTR_SLOPE_CFF>0 or KhTh_Slope_Cff>0, + ! this is set to true regardless of what is in the + ! parameter file. +USE_VISBECK = True ! [Boolean] default = False + ! If true, use the Visbeck et al. (1997) formulation for + ! thickness diffusivity. +RESOLN_SCALED_KH = True ! [Boolean] default = False + ! If true, the Laplacian lateral viscosity is scaled away + ! when the first baroclinic deformation radius is well + ! resolved. +RESOLN_SCALED_KHTH = True ! [Boolean] default = False + ! If true, the interface depth diffusivity is scaled away + ! when the first baroclinic deformation radius is well + ! resolved. +RESOLN_SCALED_KHTR = True ! [Boolean] default = False + ! If true, the epipycnal tracer diffusivity is scaled + ! away when the first baroclinic deformation radius is + ! well resolved. +KHTH_SLOPE_CFF = 0.1 ! [nondim] default = 0.0 + ! The nondimensional coefficient in the Visbeck formula + ! for the interface depth diffusivity +KHTR_SLOPE_CFF = 0.1 ! [nondim] default = 0.0 + ! The nondimensional coefficient in the Visbeck formula + ! for the epipycnal tracer diffusivity +VARMIX_KTOP = 6 ! [nondim] default = 2 + ! The layer number at which to start vertical integration + ! of S*N for purposes of finding the Eady growth rate. +VISBECK_L_SCALE = 3.0E+04 ! [m] default = 0.0 + ! The fixed length scale in the Visbeck formula. + +! === module MOM_wave_speed === +ETA_TOLERANCE = 1.0E-06 ! [m] default = 1.1E-09 + ! The tolerance for the differences between the + ! barotropic and baroclinic estimates of the sea surface + ! height due to the fluxes through each face. The total + ! tolerance for SSH is 4 times this value. The default + ! is 0.5*NK*ANGSTROM, and this should not be set less x + ! than about 10^-15*MAXIMUM_DEPTH. +VELOCITY_TOLERANCE = 0.001 ! [m s-1] default = 3.0E+08 + ! The tolerance for barotropic velocity discrepancies + ! between the barotropic solution and the sum of the + ! layer thicknesses. +BOUND_CORIOLIS = True ! [Boolean] default = False + ! If true, the Coriolis terms at u-points are bounded by + ! the four estimates of (f+rv)v from the four neighboring + ! v-points, and similarly at v-points. This option would + ! have no effect on the SADOURNY Coriolis scheme if it + ! were possible to use centered difference thickness fluxes. + +! === module MOM_hor_visc === +AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 + ! The velocity scale which is multiplied by the cube of + ! the grid spacing to calculate the Laplacian viscosity. + ! The final viscosity is the largest of this scaled + ! viscosity, the Smagorinsky viscosity and AH. +SMAGORINSKY_AH = True ! [Boolean] default = False + ! If true, use a biharmonic Smagorinsky nonlinear eddy + ! viscosity. +SMAG_BI_CONST = 0.06 ! [nondim] default = 0.0 + ! The nondimensional biharmonic Smagorinsky constant, + ! typically 0.015 - 0.06. + +! === module MOM_vert_friction === +PRANDTL_TURB = 0.0 ! [nondim] default = 1.0 + ! The turbulent Prandtl number applied to shear + ! instability. +DYNAMIC_VISCOUS_ML = True ! [Boolean] default = False + ! If true, use a bulk Richardson number criterion to + ! determine the mixed layer thickness for viscosity. +U_TRUNC_FILE = "U_velocity_truncations" ! default = "" + ! The absolute path to a file into which the accelerations + ! leading to zonal velocity truncations are written. + ! Undefine this for efficiency if this diagnostic is not + ! needed. +V_TRUNC_FILE = "V_velocity_truncations" ! default = "" + ! The absolute path to a file into which the accelerations + ! leading to meridional velocity truncations are written. + ! Undefine this for efficiency if this diagnostic is not + ! needed. +KV = 1.0E-04 ! [m2 s-1] + ! The background kinematic viscosity in the interior. + ! The molecular value, ~1e-6 m2 s-1, may be used. +HBBL = 10.0 ! [m] + ! The thickness of a bottom boundary layer with a + ! viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or + ! the thickness over which near-bottom velocities are + ! averaged for the drag law if BOTTOMDRAGLAW is defined + ! but LINEAR_DRAG is not. +MAXVEL = 10.0 ! [m s-1] default = 3.0E+08 + ! The maximum velocity allowed before the velocity + ! components are truncated. + +! === module MOM_PointAccel === + +! === module MOM_set_visc === +USE_JACKSON_PARAM = True ! [Boolean] default = False + ! If true, use the Jackson-Hallberg-Legg (JPO 2008) + ! shear mixing parameterization. +ML_OMEGA_FRAC = 1.0 ! [nondim] default = 0.0 + ! 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). +DRAG_BG_VEL = 0.1 ! [m s-1] default = 0.0 + ! DRAG_BG_VEL is either the assumed bottom velocity (with + ! LINEAR_DRAG) or an unresolved velocity that is + ! combined with the resolved velocity to estimate the + ! velocity magnitude. DRAG_BG_VEL is only used when + ! BOTTOMDRAGLAW is defined. +BBL_THICK_MIN = 0.1 ! [m] default = 0.0 + ! The minimum bottom boundary layer thickness that can be + ! used with BOTTOMDRAGLAW. This might be + ! Kv / (cdrag * drag_bg_vel) to give Kv as the minimum + ! near-bottom viscosity. + +! === module MOM_barotropic === +BOUND_BT_CORRECTION = True ! [Boolean] default = False + ! If true, the corrective pseudo mass-fluxes into the + ! barotropic solver are limited to values that require + ! less than 0.1*MAXVEL to be accommodated. +!BT x-halo = 0 ! + ! The barotropic x-halo size that is actually used. +!BT y-halo = 0 ! + ! The barotropic y-halo size that is actually used. +NONLINEAR_BT_CONTINUITY = True ! [Boolean] default = False + ! If true, use nonlinear transports in the barotropic + ! continuity equation. This does not apply if + ! USE_BT_CONT_TYPE is true. +BT_PROJECT_VELOCITY = True ! [Boolean] default = False + ! If true, step the barotropic velocity first and project + ! out the velocity tendancy by 1+BEBT when calculating the + ! transport. The default (false) is to use a predictor + ! continuity step to find the pressure field, and then + ! to do a corrector continuity step using a weighted + ! average of the old and new velocities, with weights + ! of (1-BEBT) and BEBT. +BT_THICK_SCHEME = "FROM_BT_CONT" ! default = "HYBRID" + ! A string describing the scheme that is used to set the + ! open face areas used for barotropic transport and the + ! relative weights of the accelerations. Valid values are: + ! ARITHMETIC - arithmetic mean layer thicknesses + ! HARMONIC - harmonic mean layer thicknesses + ! HYBRID (the default) - use arithmetic means for + ! layers above the shallowest bottom, the harmonic + ! mean for layers below, and a weighted average for + ! layers that straddle that depth + ! FROM_BT_CONT - use the average thicknesses kept + ! in the h_u and h_v fields of the BT_cont_type +BEBT = 0.2 ! [nondim] default = 0.1 + ! BEBT determines whether the barotropic time stepping + ! uses the forward-backward time-stepping scheme or a + ! backward Euler scheme. BEBT is valid in the range from + ! 0 (for a forward-backward treatment of nonrotating + ! gravity waves) to 1 (for a backward Euler treatment). + ! In practice, BEBT must be greater than about 0.05. +DTBT = -0.95 ! [s or nondim] default = -0.98 + ! The barotropic time step, in s. DTBT is only used with + ! the split explicit time stepping. To set the time step + ! automatically based the maximum stable value use 0, or + ! a negative value gives the fraction of the stable value. + ! Setting DTBT to 0 is the same as setting it to -0.98. + ! The value of DTBT that will actually be used is an + ! integer fraction of DT, rounding down. + +! === module MOM_thickness_diffuse === +KHTH = 1.0 ! [m2 s-1] default = 0.0 + ! The background horizontal thickness diffusivity. +KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 + ! The maximum horizontal thickness diffusivity. + +! === module MOM_mixed_layer_restrat === +FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 + ! A nondimensional coefficient that is proportional to + ! the ratio of the deformation radius to the dominant + ! lengthscale of the submesoscale mixed layer + ! instabilities, times the minimum of the ratio of the + ! mesoscale eddy kinetic energy to the large-scale + ! geostrophic kinetic energy or 1 plus the square of the + ! grid spacing over the deformation radius, as detailed + ! by Fox-Kemper et al. (2010) + +! === module MOM_diabatic_driver === +! The following parameters are used for diabatic processes. +RECLAIM_FRAZIL = False ! [Boolean] default = True + ! If true, try to use any frazil heat deficit to cool any + ! overlying layers down to the freezing point, thereby + ! avoiding the creation of thin ice when the SST is above + ! the freezing point. +KD = 2.0E-05 ! [m2 s-1] + ! The background diapycnal diffusivity of density in the + ! interior. Zero or the molecular value, ~1e-7 m2 s-1, + ! may be used. + +! === module MOM_KPP === +! This is the MOM wrapper to CVmix:KPP +! See http://code.google.com/p/cvmix/ +KPP% +%KPP + +! === module MOM_diffConvection === +! This module implements enhanced diffusivity as a +! function of static stability, N^2. +CONVECTION% +%CONVECTION + +! === module MOM_entrain_diffusive === +MAX_ENT_IT = 20 ! default = 5 + ! The maximum number of iterations that may be used to + ! calculate the interior diapycnal entrainment. +TOLERANCE_ENT = 1.0E-05 ! [m] default = 1.341640786499874E-05 + ! The tolerance with which to solve for entrainment values. + +! === module MOM_kappa_shear === +MAX_RINO_IT = 25 ! [nondim] default = 50 + ! The maximum number of iterations that may be used to + ! estimate the Richardson number driven mixing. + +! === module MOM_mixed_layer === +BULK_RI_ML = 0.05 ! [nondim] + ! The efficiency with which mean kinetic energy released + ! by mechanically forced entrainment of the mixed layer + ! is converted to turbulent kinetic energy. +ABSORB_ALL_SW = True ! [Boolean] default = False + ! If true, all shortwave radiation is absorbed by the + ! ocean, instead of passing through to the bottom mud. +MSTAR = 0.3 ! [units=nondim] default = 1.2 + ! The ratio of the friction velocity cubed to the TKE + ! input to the mixed layer. +TKE_DECAY = 10.0 ! [nondim] default = 2.5 + ! TKE_DECAY relates the vertical rate of decay of the + ! TKE available for mechanical entrainment to the natural + ! Ekman depth. +HMIX_MIN = 2.0 ! [m] default = 0.0 + ! The minimum mixed layer depth if the mixed layer depth + ! is determined dynamically. +LIMIT_BUFFER_DETRAIN = True ! [Boolean] default = False + ! If true, limit the detrainment from the buffer layers + ! to not be too different from the neighbors. +DEPTH_LIMIT_FLUXES = 0.1 ! [m] default = 0.2 + ! The surface fluxes are scaled away when the total ocean + ! depth is less than DEPTH_LIMIT_FLUXES. +CORRECT_ABSORPTION_DEPTH = True ! [Boolean] default = False + ! If true, the depth at which penetrating shortwave + ! radiation is absorbed is corrected by moving some of + ! the heating upward in the water column. + +! === module MOM_regularize_layers === + +! === module MOM_opacity === +PEN_SW_SCALE = 15.0 ! [m] default = 0.0 + ! The vertical absorption e-folding depth of the + ! penetrating shortwave radiation. +PEN_SW_FRAC = 0.42 ! [nondim] default = 0.0 + ! The fraction of the shortwave radiation that penetrates + ! below the surface. + +! === module MOM_tracer_advect === + +! === module MOM_tracer_hor_diff === +KHTR = 1.0 ! [m2 s-1] default = 0.0 + ! The background along-isopycnal tracer diffusivity. +KHTR_MAX = 900.0 ! [m2 s-1] default = 0.0 + ! The maximum along-isopycnal tracer diffusivity. +DIFFUSE_ML_TO_INTERIOR = True ! [Boolean] default = False + ! If true, enable epipycnal mixing between the surface + ! boundary layer and the interior. +ML_KHTR_SCALE = 0.0 ! [nondim] default = 1.0 + ! With Diffuse_ML_interior, the ratio of the truly + ! horizontal diffusivity in the mixed layer to the + ! epipycnal diffusivity. The valid range is 0 to 1. + +! === module MOM_surface_forcing === +BUOY_CONFIG = "linear" ! + ! The character string that indicates how buoyancy forcing + ! is specified. Valid options include (file), (zero), + ! (linear), (USER), and (NONE). +WIND_CONFIG = "gyres" ! + ! The character string that indicates how wind forcing + ! is specified. Valid options include (file), (2gyre), + ! (1gyre), (gyres), (zero), and (USER). +TAUX_SIN_AMP = 0.1 ! [Pa] default = 0.0 + ! With the gyres wind_config, the sine amplitude in the + ! zonal wind stress profile: + ! B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L). +TAUX_N_PIS = 1.0 ! [nondim] default = 0.0 + ! With the gyres wind_config, the number of gyres in + ! the zonal wind stress profile: + ! n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L). +RESTOREBUOY = True ! [Boolean] default = False + ! If true, the buoyancy fluxes drive the model back + ! toward some specified surface state with a rate + ! given by FLUXCONST. +FLUXCONST = 0.5 ! [m day-1] + ! The constant that relates the restoring surface fluxes + ! to the relative surface anomalies (akin to a piston + ! velocity). Note the non-MKS units. +SST_NORTH = 27.0 ! [deg C] default = 0.0 + ! With buoy_config linear, the sea surface temperature + ! at the northern end of the domain toward which to + ! to restore. +SST_SOUTH = 3.0 ! [deg C] default = 0.0 + ! With buoy_config linear, the sea surface temperature + ! at the southern end of the domain toward which to + ! to restore. + +! === module MOM_sum_output === +MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 + ! The run will be stopped, and the day set to a very + ! large value if the velocity is truncated more than + ! MAXTRUNC times between energy saves. Set MAXTRUNC to 0 + ! to stop if there is any truncation of velocities. +MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 + ! The maximum amount of cpu time per processor for which + ! MOM should run before saving a restart file and + ! quitting with a return value that indicates that a + ! further run is required to complete the simulation. + ! If automatic restarts are not desired, use a negative + ! value for MAXCPU. MAXCPU has units of wall-clock + ! seconds, so the actual CPU time used is larger by a + ! factor of the number of processors used. + +! === module MOM_main (MOM_driver) === +DT_FORCING = 3600.0 ! [s] default = 900.0 + ! The time step for changing forcing, coupling with other + ! components, or potentially writing certain diagnostics. + ! The default value is given by DT. +DAYMAX = 0.25 ! [days] + ! The final time of the whole simulation, in units of + ! TIMEUNIT seconds. This also sets the potential end + ! time of the present run segment if the end time is + ! not set (as it was here) via ocean_solo_nml in input.nml. +RESTART_CONTROL = 3 ! default = 1 + ! An integer whose bits encode which restart files are + ! written. Add 2 (bit 1) for a time-stamped file, and odd + ! (bit 0) for a non-time-stamped file. A non-time-stamped + ! restart file is saved at the end of the run segment + ! for any non-negative value. +RESTINT = 365.0 ! [days] default = 0.0 + ! The interval between saves of the restart file in units + ! of TIMEUNIT. Use 0 (the default) to not save + ! incremental restart files at all. +ENERGYSAVEDAYS = 0.125 ! [days] default = 3600.0 + ! The interval in units of TIMEUNIT between saves of the + ! energies of the run and other globally summed diagnostics. +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 diff --git a/.testing/tc1/MOM_override b/.testing/tc1/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc1/diag_table b/.testing/tc1/diag_table new file mode 100644 index 0000000000..220d65d34f --- /dev/null +++ b/.testing/tc1/diag_table @@ -0,0 +1,10 @@ +"MOM test configuration 1" +1 1 1 0 0 0 +"prog", 1,"days",1,"days","time", + +# Prognostic Ocean fields: +"ocean_model","u","u","prog","all",.false.,"none",2 +"ocean_model","v","v","prog","all",.false.,"none",2 +"ocean_model","h","h","prog","all",.false.,"none",1 +"ocean_model","e","e","prog","all",.false.,"none",2 +"ocean_model","temp","temp","prog","all",.false.,"none",2 diff --git a/.testing/tc1/input.nml b/.testing/tc1/input.nml new file mode 100644 index 0000000000..54b26920b1 --- /dev/null +++ b/.testing/tc1/input.nml @@ -0,0 +1,19 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + clock_grain = 'ROUTINE' + clock_flags = 'SYNC' + domains_stack_size = 955296 + stack_size = 0 +/ diff --git a/.testing/tc2.a/MOM_input b/.testing/tc2.a/MOM_input new file mode 120000 index 0000000000..b0cf8cd51c --- /dev/null +++ b/.testing/tc2.a/MOM_input @@ -0,0 +1 @@ +../tc2/MOM_input \ No newline at end of file diff --git a/.testing/tc2.a/MOM_override b/.testing/tc2.a/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc2.a/MOM_tc_variant b/.testing/tc2.a/MOM_tc_variant new file mode 100644 index 0000000000..5a85c21aed --- /dev/null +++ b/.testing/tc2.a/MOM_tc_variant @@ -0,0 +1,9 @@ +#override TOPO_CONFIG = "spoon" +#override REMAPPING_SCHEME = "PPM_H4" +#override REGRIDDING_COORDINATE_MODE = "SIGMA" +MLE_USE_PBL_MLD = True +MLE%USE_BODNER23 = True +MLE%BLD_DECAYING_TFILTER = 86400. +MLE%MLD_DECAYING_TFILTER = 259200. +MLE%BLD_GROWING_TFILTER = 300. +MLE%MLD_GROWING_TFILTER = 3600. diff --git a/.testing/tc2.a/diag_table b/.testing/tc2.a/diag_table new file mode 120000 index 0000000000..fcf2284f5f --- /dev/null +++ b/.testing/tc2.a/diag_table @@ -0,0 +1 @@ +../tc2/diag_table \ No newline at end of file diff --git a/.testing/tc2.a/input.nml b/.testing/tc2.a/input.nml new file mode 100644 index 0000000000..3c7dcf7bea --- /dev/null +++ b/.testing/tc2.a/input.nml @@ -0,0 +1,20 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_tc_variant', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + clock_grain = 'ROUTINE' + clock_flags = 'SYNC' + domains_stack_size = 955296 + stack_size = 0 +/ diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input new file mode 100644 index 0000000000..c7d2a35aa6 --- /dev/null +++ b/.testing/tc2/MOM_input @@ -0,0 +1,621 @@ +/* This input file provides the adjustable run-time parameters for version 6 of + the Modular Ocean Model (MOM6), a numerical ocean model developed at NOAA-GFDL. + Where appropriate, parameters use usually given in MKS units. + + This particular file is for the example in benchmark. + + This MOM_input file typically contains only the non-default values that are + needed to reproduce this example. A full list of parameters for this example + can be found in the corresponding MOM_parameter_doc.all file which is + generated by the model at run-time. */ + +!SYMMETRIC_MEMORY_ = False ! [Boolean] + ! If defined, the velocity point data domain includes + ! every face of the thickness points. In other words, + ! some arrays are larger than others, depending on where + ! they are on the staggered grid. Also, the starting + ! index of the velocity-point arrays is usually 0, not 1. + ! This can only be set at compile time. +!STATIC_MEMORY_ = False ! [Boolean] + ! If STATIC_MEMORY_ is defined, the principle variables + ! will have sizes that are statically determined at + ! compile time. Otherwise the sizes are not determined + ! until run time. The STATIC option is substantially + ! faster, but does not allow the PE count to be changed + ! at run time. This can only be set at compile time. +NIHALO = 4 ! default = 2 + ! The number of halo points on each side in the + ! x-direction. With STATIC_MEMORY_ this is set as NIHALO_ + ! in MOM_memory.h at compile time; without STATIC_MEMORY_ + ! the default is NIHALO_ in MOM_memory.h (if defined) or 2. +NJHALO = 4 ! default = 2 + ! The number of halo points on each side in the + ! y-direction. With STATIC_MEMORY_ this is set as NJHALO_ + ! in MOM_memory.h at compile time; without STATIC_MEMORY_ + ! the default is NJHALO_ in MOM_memory.h (if defined) or 2. +NIGLOBAL = 10 ! + ! The total number of thickness grid points in the + ! x-direction in the physical domain. With STATIC_MEMORY_ + ! this is set in MOM_memory.h at compile time. +NJGLOBAL = 8 ! + ! The total number of thickness grid points in the + ! y-direction in the physical domain. With STATIC_MEMORY_ + ! this is set in MOM_memory.h at compile time. +!NIPROC = 12 ! + ! The number of processors in the x-direction. With + ! STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +!NJPROC = 6 ! + ! The number of processors in the x-direction. With + ! STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +!LAYOUT = 12, 6 ! + ! The processor layout that was acutally used. +IO_LAYOUT = 1, 1 ! default = 0 + ! The processor layout to be used, or 0,0 to automatically + ! set the io_layout to be the same as the layout. + +! === module MOM_grid === +! Parameters providing information about the vertical grid. +NK = 8 ! [nondim] + ! The number of model layers. + +USE_REGRIDDING = True ! [Boolean] default = False + ! If True, use the ALE algorithm (regridding/remapping). If False, use the + +! === module MOM_verticalGrid === +! Parameters providing information about the vertical grid. + +! === module MOM === +THICKNESSDIFFUSE = True ! [Boolean] default = False + ! If true, interfaces or isopycnal surfaces are diffused, + ! depending on the value of FULL_THICKNESSDIFFUSE. +THICKNESSDIFFUSE_FIRST = True ! [Boolean] default = False + ! If true, do thickness diffusion before dynamics. + ! This is only used if THICKNESSDIFFUSE is true. +MIXEDLAYER_RESTRAT = True ! [Boolean] default = False + ! If true, a density-gradient dependent re-stratifying + ! flow is imposed in the mixed layer. + ! This is only used if BULKMIXEDLAYER is true. +DT = 3600.0 ! [s] + ! The (baroclinic) dynamics time step. The time-step that + ! is actually used will be an integer fraction of the + ! forcing time-step (DT_FORCING in ocean-only mode or the + ! coupling timestep in coupled mode.) +DT_THERM = 7200.0 ! [s] default = 900.0 + ! The thermodynamic and tracer advection time step. + ! Ideally DT_THERM should be an integer multiple of DT + ! and less than the forcing or coupling time-step. + ! By default DT_THERM is set to DT. +DTBT_RESET_PERIOD = -.98 ! [s] default = 3600.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 + ! dynamic, DTBT will be set at least every forcing time + ! step, and if 0, every dynamics time step. The default is + ! set by DT_THERM. This is only used if SPLIT is true. +FRAZIL = True ! [Boolean] default = False + ! If true, water freezes if it gets too cold, and the + ! the accumulated heat deficit is returned in the + ! surface state. FRAZIL is only used if + ! ENABLE_THERMODYNAMICS is true. +C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 + ! The heat capacity of sea water, approximated as a + ! constant. This is only used if ENABLE_THERMODYNAMICS is + ! true. The default value is from the TEOS-10 definition + ! of conservative temperature. +SAVE_INITIAL_CONDS = True ! [Boolean] default = False + ! If true, write the initial conditions to a file given + ! by IC_OUTPUT_FILE. +IC_OUTPUT_FILE = "GOLD_IC" ! default = "MOM_IC" + ! The file into which to write the initial conditions. + +! === module MOM_tracer_registry === + +! === module MOM_tracer_flow_control === +USE_IDEAL_AGE_TRACER = True ! [Boolean] default = False + ! If true, use the ideal_age_example tracer package. + +! === module ideal_age_example === +INPUTDIR = "INPUT" ! default = "." + ! The directory in which input files are found. +COORD_CONFIG = "ALE" ! + ! This specifies how layers are to be defined: + ! file - read coordinate information from the file + ! specified by (COORD_FILE). + ! linear - linear based on interfaces not layesrs. + ! ts_ref - use reference temperature and salinity + ! ts_range - use range of temperature and salinity + ! (T_REF and S_REF) to determine surface density + ! and GINT calculate internal densities. + ! gprime - use reference density (RHO_0) for surface + ! density and GINT calculate internal densities. + ! ts_profile - use temperature and salinity profiles + ! (read from COORD_FILE) to set layer densities. + ! USER - call a user modified routine. +REGRIDDING_COORDINATE_MODE = "Z*" ! default = "LAYER" + ! Coordinate mode for vertical regridding. Choose among the following + ! possibilities: LAYER - Isopycnal or stacked shallow water layers + ! ZSTAR, Z* - stretched geopotential z* + ! SIGMA_SHELF_ZSTAR - stretched geopotential z* ignoring shelf + ! SIGMA - terrain following coordinates + ! RHO - continuous isopycnal + ! HYCOM1 - HyCOM-like hybrid coordinate + ! SLIGHT - stretched coordinates above continuous isopycnal + ! ADAPTIVE - optimize for smooth neutral density surfaces +REMAPPING_SCHEME = "PPM_IH4" ! default = "PLM" + ! This sets the reconstruction scheme used for vertical remapping for all + ! variables. It can be one of the following schemes: PCM (1st-order + ! accurate) + ! PLM (2nd-order accurate) + ! PPM_H4 (3rd-order accurate) + ! PPM_IH4 (3rd-order accurate) + ! PQM_IH4IH3 (4th-order accurate) + ! PQM_IH6IH5 (5th-order accurate) + +! === module MOM_grid_init === +GRID_CONFIG = "spherical" ! + ! A character string that determines the method for + ! defining the horizontal grid. Current options are: + ! mosaic - read the grid from a mosaic (supergrid) + ! file set by GRID_FILE. + ! cartesian - use a (flat) Cartesian grid. + ! spherical - use a simple spherical grid. + ! mercator - use a Mercator spherical grid. +SOUTHLAT = -21.0 ! [degrees] + ! The southern latitude of the domain. +LENLAT = 42.0 ! [degrees] + ! The latitudinal length of the domain. +LENLON = 90.0 ! [degrees] + ! The longitudinal length of the domain. +TOPO_CONFIG = "halfpipe" ! + ! This specifies how bathymetry is specified: + ! file - read bathymetric information from the file + ! specified by (TOPO_FILE). + ! flat - flat bottom set to MAXIMUM_DEPTH. + ! bowl - an analytically specified bowl-shaped basin + ! ranging between MAXIMUM_DEPTH and MINIMUM_DEPTH. + ! spoon - a similar shape to 'bowl', but with an vertical + ! wall at the southern face. + ! halfpipe - a zonally uniform channel with a half-sine + ! profile in the meridional direction. + ! benchmark - use the benchmark test case topography. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! DOME2D - use a shelf and slope configuration for the + ! DOME2D gravity current/overflow test case. + ! seamount - Gaussian bump for spontaneous motion test case. + ! USER - call a user modified routine. + +! === module benchmark_initialize_topography === +MINIMUM_DEPTH = 1.0 ! [m] default = 0.0 + ! The minimum depth of the ocean. +MAXIMUM_DEPTH = 4500.0 ! [m] + ! The maximum depth of the ocean. +THICKNESS_CONFIG = "uniform" ! + ! A string that determines how the initial layer + ! thicknesses are specified for a new run: + ! file - read interface heights from the file specified + ! thickness_file - read thicknesses from the file specified + ! by (THICKNESS_FILE). + ! uniform - uniform thickness layers evenly distributed + ! between the surface and MAXIMUM_DEPTH. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! benchmark - use the benchmark test case thicknesses. + ! search - search a density profile for the interface + ! densities. This is not yet implemented. + ! circle_obcs - the circle_obcs test case is used. + ! DOME2D - 2D version of DOME initialization. + ! adjustment2d - TBD AJA. + ! sloshing - TBD AJA. + ! seamount - TBD AJA. + ! USER - call a user modified routine. +TS_CONFIG = "benchmark" ! + ! A string that determines how the initial tempertures + ! and salinities are specified for a new run: + ! file - read velocities from the file specified + ! by (TS_FILE). + ! fit - find the temperatures that are consistent with + ! the layer densities and salinity S_REF. + ! TS_profile - use temperature and salinity profiles + ! (read from TS_FILE) to set layer densities. + ! benchmark - use the benchmark test case T & S. + ! linear - linear in logical layer space. + ! DOME2D - 2D DOME initialization. + ! adjustment2d - TBD AJA. + ! sloshing - TBD AJA. + ! seamount - TBD AJA. + ! USER - call a user modified routine. + +! === module MOM_MEKE === +USE_MEKE = True ! [Boolean] default = False + ! If true, turns on the MEKE scheme which calculates a sub-grid mesoscale eddy + ! kinetic energy budget. +MEKE_GMCOEFF = 1.0 ! [nondim] default = -1.0 + ! The efficiency of the conversion of potential energy into MEKE by the + ! thickness mixing parameterization. If MEKE_GMCOEFF is negative, this + ! conversion is not used or calculated. +MEKE_BGSRC = 1.0E-13 ! [W kg-1] default = 0.0 + ! A background energy source for MEKE. +MEKE_KHTH_FAC = 0.5 ! [nondim] default = 0.0 + ! A factor that maps MEKE%Kh to KhTh. +MEKE_KHTR_FAC = 0.5 ! [nondim] default = 0.0 + ! A factor that maps MEKE%Kh to KhTr. +MEKE_KHMEKE_FAC = 1.0 ! [nondim] default = 0.0 + ! A factor that maps MEKE%Kh to Kh for MEKE itself. +MEKE_VISCOSITY_COEFF_KU = 1.0 ! [nondim] default = 0.0 + ! If non-zero, is the scaling coefficient in the expression forviscosity used to + ! parameterize harmonic lateral momentum mixing byunresolved eddies represented + ! by MEKE. Can be negative torepresent backscatter from the unresolved eddies. +MEKE_ALPHA_RHINES = 0.15 ! [nondim] default = 0.05 + ! If positive, is a coefficient weighting the Rhines scale in the expression for + ! mixing length used in MEKE-derived diffusivity. +MEKE_ALPHA_EADY = 0.15 ! [nondim] default = 0.05 + ! If positive, is a coefficient weighting the Eady length scale in the + ! expression for mixing length used in MEKE-derived diffusivity. + +! === module MOM_lateral_mixing_coeffs === +USE_VARIABLE_MIXING = True ! [Boolean] default = False + ! If true, the variable mixing code will be called. This + ! allows diagnostics to be created even if the scheme is + ! not used. If KHTR_SLOPE_CFF>0 or KhTh_Slope_Cff>0, + ! this is set to true regardless of what is in the + ! parameter file. +USE_VISBECK = False ! [Boolean] default = False + ! If true, use the Visbeck et al. (1997) formulation for + ! thickness diffusivity. +RESOLN_SCALED_KH = False ! [Boolean] default = False + ! If true, the Laplacian lateral viscosity is scaled away + ! when the first baroclinic deformation radius is well + ! resolved. +RESOLN_SCALED_KHTH = False ! [Boolean] default = False + ! If true, the interface depth diffusivity is scaled away + ! when the first baroclinic deformation radius is well + ! resolved. +RESOLN_SCALED_KHTR = False ! [Boolean] default = False + ! If true, the epipycnal tracer diffusivity is scaled + ! away when the first baroclinic deformation radius is + ! well resolved. +USE_STORED_SLOPES = True ! [Boolean] default = False + ! If true, the isopycnal slopes are calculated once and stored for re-use. This + ! uses more memory but avoids calling the equation of state more times than + +! === module MOM_wave_speed === +ETA_TOLERANCE = 1.0E-06 ! [m] default = 1.1E-09 + ! The tolerance for the differences between the + ! barotropic and baroclinic estimates of the sea surface + ! height due to the fluxes through each face. The total + ! tolerance for SSH is 4 times this value. The default + ! is 0.5*NK*ANGSTROM, and this should not be set less x + ! than about 10^-15*MAXIMUM_DEPTH. +VELOCITY_TOLERANCE = 0.001 ! [m s-1] default = 3.0E+08 + ! The tolerance for barotropic velocity discrepancies + ! between the barotropic solution and the sum of the + ! layer thicknesses. +BOUND_CORIOLIS = True ! [Boolean] default = False + ! If true, the Coriolis terms at u-points are bounded by + ! the four estimates of (f+rv)v from the four neighboring + ! v-points, and similarly at v-points. This option would + ! have no effect on the SADOURNY Coriolis scheme if it + ! were possible to use centered difference thickness fluxes. +PGF_STANLEY_T2_DET_COEFF = -1.0 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley form of the Brankart + ! correction. Negative values disable the scheme. + +! === module MOM_hor_visc === +LAPLACIAN = True +KH_VEL_SCALE = 0.05 +SMAGORINSKY_KH = True ! [Boolean] default = False +SMAG_LAP_CONST = 0.06 ! [nondim] default = 0.0 +AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 + ! The velocity scale which is multiplied by the cube of + ! the grid spacing to calculate the Laplacian viscosity. + ! The final viscosity is the largest of this scaled + ! viscosity, the Smagorinsky viscosity and AH. +SMAGORINSKY_AH = True ! [Boolean] default = False + ! If true, use a biharmonic Smagorinsky nonlinear eddy + ! viscosity. +SMAG_BI_CONST = 0.06 ! [nondim] default = 0.0 + ! The nondimensional biharmonic Smagorinsky constant, + ! typically 0.015 - 0.06. + +! === module MOM_vert_friction === +ENERGETICS_SFC_PBL = True +DO_GEOTHERMAL = True +GEOTHERMAL_SCALE = 0.05 +USE_NEUTRAL_DIFFUSION = True +DYNAMIC_VISCOUS_ML = True ! [Boolean] default = False + ! If true, use a bulk Richardson number criterion to + ! determine the mixed layer thickness for viscosity. +U_TRUNC_FILE = "U_velocity_truncations" ! default = "" + ! The absolute path to a file into which the accelerations + ! leading to zonal velocity truncations are written. + ! Undefine this for efficiency if this diagnostic is not + ! needed. +V_TRUNC_FILE = "V_velocity_truncations" ! default = "" + ! The absolute path to a file into which the accelerations + ! leading to meridional velocity truncations are written. + ! Undefine this for efficiency if this diagnostic is not + ! needed. +KV = 1.0E-04 ! [m2 s-1] + ! The background kinematic viscosity in the interior. + ! The molecular value, ~1e-6 m2 s-1, may be used. +HMIX_FIXED = 0.5 ! [m] + ! The prescribed depth over which the near-surface viscosity and diffusivity are + ! elevated when the bulk mixed layer is not used. +CHANNEL_DRAG = True ! [Boolean] default = False +HBBL = 10.0 ! [m] + ! The thickness of a bottom boundary layer with a + ! viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or + ! the thickness over which near-bottom velocities are + ! averaged for the drag law if BOTTOMDRAGLAW is defined + ! but LINEAR_DRAG is not. +MAXVEL = 10.0 ! [m s-1] default = 3.0E+08 + ! The maximum velocity allowed before the velocity + ! components are truncated. + +! === module MOM_PointAccel === + +! === module MOM_set_visc === +USE_JACKSON_PARAM = True ! [Boolean] default = False + ! If true, use the Jackson-Hallberg-Legg (JPO 2008) + ! shear mixing parameterization. +ML_OMEGA_FRAC = 1.0 ! [nondim] default = 0.0 + ! 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). +DRAG_BG_VEL = 0.1 ! [m s-1] default = 0.0 + ! DRAG_BG_VEL is either the assumed bottom velocity (with + ! LINEAR_DRAG) or an unresolved velocity that is + ! combined with the resolved velocity to estimate the + ! velocity magnitude. DRAG_BG_VEL is only used when + ! BOTTOMDRAGLAW is defined. +BBL_THICK_MIN = 0.1 ! [m] default = 0.0 + ! The minimum bottom boundary layer thickness that can be + ! used with BOTTOMDRAGLAW. This might be + ! Kv / (cdrag * drag_bg_vel) to give Kv as the minimum + ! near-bottom viscosity. + +! === module MOM_barotropic === +BOUND_BT_CORRECTION = True ! [Boolean] default = False + ! If true, the corrective pseudo mass-fluxes into the + ! barotropic solver are limited to values that require + ! less than 0.1*MAXVEL to be accommodated. +!BT x-halo = 0 ! + ! The barotropic x-halo size that is actually used. +!BT y-halo = 0 ! + ! The barotropic y-halo size that is actually used. +NONLINEAR_BT_CONTINUITY = True ! [Boolean] default = False + ! If true, use nonlinear transports in the barotropic + ! continuity equation. This does not apply if + ! USE_BT_CONT_TYPE is true. +BT_PROJECT_VELOCITY = True ! [Boolean] default = False + ! If true, step the barotropic velocity first and project + ! out the velocity tendancy by 1+BEBT when calculating the + ! transport. The default (false) is to use a predictor + ! continuity step to find the pressure field, and then + ! to do a corrector continuity step using a weighted + ! average of the old and new velocities, with weights + ! of (1-BEBT) and BEBT. +BT_THICK_SCHEME = "FROM_BT_CONT" ! default = "HYBRID" + ! A string describing the scheme that is used to set the + ! open face areas used for barotropic transport and the + ! relative weights of the accelerations. Valid values are: + ! ARITHMETIC - arithmetic mean layer thicknesses + ! HARMONIC - harmonic mean layer thicknesses + ! HYBRID (the default) - use arithmetic means for + ! layers above the shallowest bottom, the harmonic + ! mean for layers below, and a weighted average for + ! layers that straddle that depth + ! FROM_BT_CONT - use the average thicknesses kept + ! in the h_u and h_v fields of the BT_cont_type +BEBT = 0.2 ! [nondim] default = 0.1 + ! BEBT determines whether the barotropic time stepping + ! uses the forward-backward time-stepping scheme or a + ! backward Euler scheme. BEBT is valid in the range from + ! 0 (for a forward-backward treatment of nonrotating + ! gravity waves) to 1 (for a backward Euler treatment). + ! In practice, BEBT must be greater than about 0.05. +DTBT = -0.95 ! [s or nondim] default = -0.98 + ! The barotropic time step, in s. DTBT is only used with + ! the split explicit time stepping. To set the time step + ! automatically based the maximum stable value use 0, or + ! a negative value gives the fraction of the stable value. + ! Setting DTBT to 0 is the same as setting it to -0.98. + ! The value of DTBT that will actually be used is an + ! integer fraction of DT, rounding down. + +! === module MOM_thickness_diffuse === +KHTH = 1.0 ! [m2 s-1] default = 0.0 + ! The background horizontal thickness diffusivity. +KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 + ! The maximum horizontal thickness diffusivity. +STANLEY_PRM_DET_COEFF = -1.0 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley parameterization. Negative + ! values disable the scheme. + +! === module MOM_mixed_layer_restrat === +FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 + ! A nondimensional coefficient that is proportional to + ! the ratio of the deformation radius to the dominant + ! lengthscale of the submesoscale mixed layer + ! instabilities, times the minimum of the ratio of the + ! mesoscale eddy kinetic energy to the large-scale + ! geostrophic kinetic energy or 1 plus the square of the + ! grid spacing over the deformation radius, as detailed + ! by Fox-Kemper et al. (2010) + +! === module MOM_diabatic_driver === +! The following parameters are used for diabatic processes. +RECLAIM_FRAZIL = False ! [Boolean] default = True + ! If true, try to use any frazil heat deficit to cool any + ! overlying layers down to the freezing point, thereby + ! avoiding the creation of thin ice when the SST is above + ! the freezing point. +KD = 2.0E-05 ! [m2 s-1] + ! The background diapycnal diffusivity of density in the + ! interior. Zero or the molecular value, ~1e-7 m2 s-1, + ! may be used. + +! === module MOM_KPP === +! This is the MOM wrapper to CVmix:KPP +! See http://code.google.com/p/cvmix/ +KPP% +%KPP + +! === module MOM_diffConvection === +! This module implements enhanced diffusivity as a +! function of static stability, N^2. +CONVECTION% +%CONVECTION + +! === module MOM_entrain_diffusive === +MAX_ENT_IT = 20 ! default = 5 + ! The maximum number of iterations that may be used to + ! calculate the interior diapycnal entrainment. +TOLERANCE_ENT = 1.0E-05 ! [m] default = 1.341640786499874E-05 + ! The tolerance with which to solve for entrainment values. + +! === module MOM_kappa_shear === +MAX_RINO_IT = 25 ! [nondim] default = 50 + ! The maximum number of iterations that may be used to + ! estimate the Richardson number driven mixing. + +! === module MOM_mixed_layer === +BULK_RI_ML = 0.05 ! [nondim] + ! The efficiency with which mean kinetic energy released + ! by mechanically forced entrainment of the mixed layer + ! is converted to turbulent kinetic energy. +ABSORB_ALL_SW = True ! [Boolean] default = False + ! If true, all shortwave radiation is absorbed by the + ! ocean, instead of passing through to the bottom mud. +MSTAR = 0.3 ! [units=nondim] default = 1.2 + ! The ratio of the friction velocity cubed to the TKE + ! input to the mixed layer. +TKE_DECAY = 10.0 ! [nondim] default = 2.5 + ! TKE_DECAY relates the vertical rate of decay of the + ! TKE available for mechanical entrainment to the natural + ! Ekman depth. +HMIX_MIN = 2.0 ! [m] default = 0.0 + ! The minimum mixed layer depth if the mixed layer depth + ! is determined dynamically. +LIMIT_BUFFER_DETRAIN = True ! [Boolean] default = False + ! If true, limit the detrainment from the buffer layers + ! to not be too different from the neighbors. +DEPTH_LIMIT_FLUXES = 0.1 ! [m] default = 0.2 + ! The surface fluxes are scaled away when the total ocean + ! depth is less than DEPTH_LIMIT_FLUXES. +CORRECT_ABSORPTION_DEPTH = True ! [Boolean] default = False + ! If true, the depth at which penetrating shortwave + ! radiation is absorbed is corrected by moving some of + ! the heating upward in the water column. + +! === module MOM_regularize_layers === + +! === module MOM_opacity === +PEN_SW_SCALE = 15.0 ! [m] default = 0.0 + ! The vertical absorption e-folding depth of the + ! penetrating shortwave radiation. +PEN_SW_FRAC = 0.42 ! [nondim] default = 0.0 + ! The fraction of the shortwave radiation that penetrates + ! below the surface. + +! === module MOM_tracer_advect === + +! === module MOM_tracer_hor_diff === +KHTR = 1.0 ! [m2 s-1] default = 0.0 + ! The background along-isopycnal tracer diffusivity. +KHTR_MAX = 900.0 ! [m2 s-1] default = 0.0 + ! The maximum along-isopycnal tracer diffusivity. +ML_KHTR_SCALE = 0.0 ! [nondim] default = 1.0 + ! With Diffuse_ML_interior, the ratio of the truly + ! horizontal diffusivity in the mixed layer to the + ! epipycnal diffusivity. The valid range is 0 to 1. + +! === module MOM_surface_forcing === +BUOY_CONFIG = "linear" ! + ! The character string that indicates how buoyancy forcing + ! is specified. Valid options include (file), (zero), + ! (linear), (USER), and (NONE). +WIND_CONFIG = "gyres" ! + ! The character string that indicates how wind forcing + ! is specified. Valid options include (file), (2gyre), + ! (1gyre), (gyres), (zero), and (USER). +TAUX_SIN_AMP = 0.1 ! [Pa] default = 0.0 + ! With the gyres wind_config, the sine amplitude in the + ! zonal wind stress profile: + ! B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L). +TAUX_N_PIS = 1.0 ! [nondim] default = 0.0 + ! With the gyres wind_config, the number of gyres in + ! the zonal wind stress profile: + ! n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L). +RESTOREBUOY = True ! [Boolean] default = False + ! If true, the buoyancy fluxes drive the model back + ! toward some specified surface state with a rate + ! given by FLUXCONST. +FLUXCONST = 0.5 ! [m day-1] + ! The constant that relates the restoring surface fluxes + ! to the relative surface anomalies (akin to a piston + ! velocity). Note the non-MKS units. +SST_NORTH = 27.0 ! [deg C] default = 0.0 + ! With buoy_config linear, the sea surface temperature + ! at the northern end of the domain toward which to + ! to restore. +SST_SOUTH = 3.0 ! [deg C] default = 0.0 + ! With buoy_config linear, the sea surface temperature + ! at the southern end of the domain toward which to + ! to restore. + +! === module MOM_sum_output === +MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 + ! The run will be stopped, and the day set to a very + ! large value if the velocity is truncated more than + ! MAXTRUNC times between energy saves. Set MAXTRUNC to 0 + ! to stop if there is any truncation of velocities. +MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 + ! The maximum amount of cpu time per processor for which + ! MOM should run before saving a restart file and + ! quitting with a return value that indicates that a + ! further run is required to complete the simulation. + ! If automatic restarts are not desired, use a negative + ! value for MAXCPU. MAXCPU has units of wall-clock + ! seconds, so the actual CPU time used is larger by a + ! factor of the number of processors used. + +! === module MOM_main (MOM_driver) === +DT_FORCING = 10800.0 ! [s] default = 900.0 + ! The time step for changing forcing, coupling with other + ! components, or potentially writing certain diagnostics. + ! The default value is given by DT. +DAYMAX = 1.0 ! [days] + ! The final time of the whole simulation, in units of + ! TIMEUNIT seconds. This also sets the potential end + ! time of the present run segment if the end time is + ! not set (as it was here) via ocean_solo_nml in input.nml. +RESTART_CONTROL = 3 ! default = 1 + ! An integer whose bits encode which restart files are + ! written. Add 2 (bit 1) for a time-stamped file, and odd + ! (bit 0) for a non-time-stamped file. A non-time-stamped + ! restart file is saved at the end of the run segment + ! for any non-negative value. +RESTINT = 365.0 ! [days] default = 0.0 + ! The interval between saves of the restart file in units + ! of TIMEUNIT. Use 0 (the default) to not save + ! incremental restart files at all. +ENERGYSAVEDAYS = 0.5 ! [days] default = 3600.0 + ! The interval in units of TIMEUNIT between saves of the + ! 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 diff --git a/.testing/tc2/MOM_override b/.testing/tc2/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc2/MOM_tc_variant b/.testing/tc2/MOM_tc_variant new file mode 100644 index 0000000000..8cdbf69de8 --- /dev/null +++ b/.testing/tc2/MOM_tc_variant @@ -0,0 +1,12 @@ +TIDES = True +TIDE_M2 = True +TIDE_S2 = True +TIDE_N2 = True +TIDE_K2 = True +TIDE_K1 = True +TIDE_O1 = True +TIDE_P1 = True +TIDE_Q1 = True +TIDE_MF = True +TIDE_MM = True +TIDE_SAL_SCALAR_VALUE = 1. diff --git a/.testing/tc2/diag_table b/.testing/tc2/diag_table new file mode 100644 index 0000000000..941b9c0c15 --- /dev/null +++ b/.testing/tc2/diag_table @@ -0,0 +1,2 @@ +"MOM test configuration 2" +1 1 1 0 0 0 diff --git a/.testing/tc2/input.nml b/.testing/tc2/input.nml new file mode 100644 index 0000000000..3c7dcf7bea --- /dev/null +++ b/.testing/tc2/input.nml @@ -0,0 +1,20 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_tc_variant', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + clock_grain = 'ROUTINE' + clock_flags = 'SYNC' + domains_stack_size = 955296 + stack_size = 0 +/ diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input new file mode 100644 index 0000000000..6963feee98 --- /dev/null +++ b/.testing/tc3/MOM_input @@ -0,0 +1,479 @@ +/* This input file provides the adjustable run-time parameters for version 6 of + the Modular Ocean Model (MOM6), a numerical ocean model developed at NOAA-GFDL. + Where appropriate, parameters use usually given in MKS units. + + This particular file is for the example in circle_obcs. + + This MOM_input file typically contains only the non-default values that are + needed to reproduce this example. A full list of parameters for this example + can be found in the corresponding MOM_parameter_doc.all file which is + generated by the model at run-time. */ + +REENTRANT_X = False ! [Boolean] default = True + ! If true, the domain is zonally reentrant. +!SYMMETRIC_MEMORY_ = True ! [Boolean] + ! If defined, the velocity point data domain includes + ! every face of the thickness points. In other words, + ! some arrays are larger than others, depending on where + ! they are on the staggered grid. Also, the starting + ! index of the velocity-point arrays is usually 0, not 1. + ! This can only be set at compile time. +!STATIC_MEMORY_ = False ! [Boolean] + ! If STATIC_MEMORY_ is defined, the principle variables + ! will have sizes that are statically determined at + ! compile time. Otherwise the sizes are not determined + ! until run time. The STATIC option is substantially + ! faster, but does not allow the PE count to be changed + ! at run time. This can only be set at compile time. +NIHALO = 4 ! default = 2 + ! The number of halo points on each side in the + ! x-direction. With STATIC_MEMORY_ this is set as NIHALO_ + ! in MOM_memory.h at compile time; without STATIC_MEMORY_ + ! the default is NIHALO_ in MOM_memory.h (if defined) or 2. +NJHALO = 4 ! default = 2 + ! The number of halo points on each side in the + ! y-direction. With STATIC_MEMORY_ this is set as NJHALO_ + ! in MOM_memory.h at compile time; without STATIC_MEMORY_ + ! the default is NJHALO_ in MOM_memory.h (if defined) or 2. +NIGLOBAL = 10 ! + ! The total number of thickness grid points in the + ! x-direction in the physical domain. With STATIC_MEMORY_ + ! this is set in MOM_memory.h at compile time. +NJGLOBAL = 8 ! + ! The total number of thickness grid points in the + ! y-direction in the physical domain. With STATIC_MEMORY_ + ! this is set in MOM_memory.h at compile time. +!NIPROC = 1 ! + ! The number of processors in the x-direction. With + ! STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +!NJPROC = 2 ! + ! The number of processors in the x-direction. With + ! STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +!LAYOUT = 1, 2 ! + ! The processor layout that was acutally used. +IO_LAYOUT = 1, 1 ! default = 0 + ! The processor layout to be used, or 0,0 to automatically + ! set the io_layout to be the same as the layout. + +! === module MOM_grid === +! Parameters providing information about the vertical grid. +RHO_0 = 1031.0 ! [kg m-3] default = 1035.0 + ! The mean ocean density used with BOUSSINESQ true to + ! calculate accelerations and the mass for conservation + ! properties, or with BOUSSINSEQ false to convert some + ! parameters from vertical units of m to kg m-2. +NK = 10 ! [nondim] + ! The number of model layers. + +! === module MOM_verticalGrid === +! Parameters providing information about the vertical grid. + +! === module MOM === +ENABLE_THERMODYNAMICS = False ! [Boolean] default = True + ! If true, Temperature and salinity are used as state + ! variables. +DT = 120.0 ! [s] + ! The (baroclinic) dynamics time step. The time-step that + ! is actually used will be an integer fraction of the + ! forcing time-step (DT_FORCING in ocean-only mode or the + ! coupling timestep in coupled mode.) +DTBT_RESET_PERIOD = -1.0 ! [s] default = 120.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 + ! dynamic, DTBT will be set at least every forcing time + ! step, and if 0, every dynamics time step. The default is + ! set by DT_THERM. This is only used if SPLIT is true. +SAVE_INITIAL_CONDS = True ! [Boolean] default = False + ! If true, write the initial conditions to a file given + ! by IC_OUTPUT_FILE. +IC_OUTPUT_FILE = "GOLD_IC" ! default = "MOM_IC" + ! The file into which to write the initial conditions. + +! === module MOM_tracer_registry === + +! === module MOM_tracer_flow_control === +USE_DOME_TRACER = True ! [Boolean] default = False + ! If true, use the DOME_tracer tracer package. + +! === module DOME_tracer === +INPUTDIR = "INPUT" ! default = "." + ! The directory in which input files are found. +COORD_CONFIG = "layer_ref" ! + ! This specifies how layers are to be defined: + ! file - read coordinate information from the file + ! specified by (COORD_FILE). + ! linear - linear based on interfaces not layesrs. + ! ts_ref - use reference temperature and salinity + ! ts_range - use range of temperature and salinity + ! (T_REF and S_REF) to determine surface density + ! and GINT calculate internal densities. + ! gprime - use reference density (RHO_0) for surface + ! density and GINT calculate internal densities. + ! ts_profile - use temperature and salinity profiles + ! (read from COORD_FILE) to set layer densities. + ! USER - call a user modified routine. +LIGHTEST_DENSITY = 1030.0 ! [kg m-3] default = 1031.0 + ! The reference potential density used for layer 1. + +! === module MOM_grid_init === +GRID_CONFIG = "cartesian" ! + ! A character string that determines the method for + ! defining the horizontal grid. Current options are: + ! mosaic - read the grid from a mosaic (supergrid) + ! file set by GRID_FILE. + ! cartesian - use a (flat) Cartesian grid. + ! spherical - use a simple spherical grid. + ! mercator - use a Mercator spherical grid. +AXIS_UNITS = "k" ! default = "degrees" + ! The units for the Cartesian axes. Valid entries are: + ! degrees - degrees of latitude and longitude + ! m - meters + ! k - kilometers +SOUTHLAT = 0.0 ! [k] + ! The southern latitude of the domain or the equivalent + ! starting value for the y-axis. +LENLAT = 100.0 ! [k] + ! The latitudinal or y-direction length of the domain. +LENLON = 100.0 ! [k] + ! The longitudinal or x-direction length of the domain. +TOPO_CONFIG = "flat" ! + ! This specifies how bathymetry is specified: + ! file - read bathymetric information from the file + ! specified by (TOPO_FILE). + ! flat - flat bottom set to MAXIMUM_DEPTH. + ! bowl - an analytically specified bowl-shaped basin + ! ranging between MAXIMUM_DEPTH and MINIMUM_DEPTH. + ! spoon - a similar shape to 'bowl', but with an vertical + ! wall at the southern face. + ! halfpipe - a zonally uniform channel with a half-sine + ! profile in the meridional direction. + ! benchmark - use the benchmark test case topography. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! DOME2D - use a shelf and slope configuration for the + ! DOME2D gravity current/overflow test case. + ! seamount - Gaussian bump for spontaneous motion test case. + ! USER - call a user modified routine. +MINIMUM_DEPTH = 1.0 ! [m] default = 0.0 + ! The minimum depth of the ocean. +MAXIMUM_DEPTH = 600.0 ! [m] + ! The maximum depth of the ocean. +! === module MOM_open_boundary === +! Controls where open boundaries are located, what kind of boundary condition to impose, and what data to apply, if any. +OBC_NUMBER_OF_SEGMENTS = 4 ! default = 0 + ! The number of open boundary segments. +OBC_FREESLIP_VORTICITY = True ! [Boolean] default = False + ! If true, sets the normal gradient of tangential velocity to + ! zero in the relative vorticity on open boundaries. This cannot + ! be true if OBC_ZERO_VORTICITY is True. +OBC_FREESLIP_STRAIN = True ! [Boolean] default = False + ! 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 OBC_ZERO_STRAIN is True. +OBC_ZERO_BIHARMONIC = True ! [Boolean] default = False + ! If true, zeros the Laplacian of flow on open boundaries in the biharmonic + ! viscosity term. +OBC_SEGMENT_001 = "J=N,I=N:0,FLATHER,ORLANSKI" ! + ! Documentation needs to be dynamic????? +OBC_SEGMENT_002 = "J=0,I=0:N,FLATHER,ORLANSKI" ! + ! Documentation needs to be dynamic????? +OBC_SEGMENT_003 = "I=N,J=0:N,FLATHER,ORLANSKI" ! + ! Documentation needs to be dynamic????? +OBC_SEGMENT_004 = "I=0,J=N:0,FLATHER,ORLANSKI" ! + ! Documentation needs to be dynamic????? +OBC_SEGMENT_001_DATA = "U=value:0.0,V=value:0.0,SSH=value:0.0" +OBC_SEGMENT_002_DATA = "U=value:0.0,V=value:0.0,SSH=value:0.0" +OBC_SEGMENT_003_DATA = "U=value:0.0,V=value:0.0,SSH=value:0.0" +OBC_SEGMENT_004_DATA = "U=value:0.0,V=value:0.0,SSH=value:0.0" + +ROTATION = "beta" ! default = "2omegasinlat" + ! This specifies how the Coriolis parameter is specified: + ! 2omegasinlat - Use twice the planetary rotation rate + ! times the sine of latitude. + ! betaplane - Use a beta-plane or f-plane. + ! USER - call a user modified routine. +THICKNESS_CONFIG = "circle_obcs" ! + ! A string that determines how the initial layer + ! thicknesses are specified for a new run: + ! file - read interface heights from the file specified + ! thickness_file - read thicknesses from the file specified + ! by (THICKNESS_FILE). + ! uniform - uniform thickness layers evenly distributed + ! between the surface and MAXIMUM_DEPTH. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! benchmark - use the benchmark test case thicknesses. + ! search - search a density profile for the interface + ! densities. This is not yet implemented. + ! circle_obcs - the circle_obcs test case is used. + ! DOME2D - 2D version of DOME initialization. + ! adjustment2d - TBD AJA. + ! sloshing - TBD AJA. + ! seamount - TBD AJA. + ! USER - call a user modified routine. + +! === module circle_obcs_initialize_thickness === +DISK_RADIUS = 24.0 ! [k] + ! The radius of the initially elevated disk in the + ! circle_obcs test case. + +! === module MOM_MEKE === +CDRAG = 0.002 ! [nondim] default = 0.003 + ! CDRAG is the drag coefficient relating the magnitude of + ! the velocity field to the bottom stress. + +! === module MOM_lateral_mixing_coeffs === +BOUND_CORIOLIS = True ! [Boolean] default = False + ! If true, the Coriolis terms at u-points are bounded by + ! the four estimates of (f+rv)v from the four neighboring + ! v-points, and similarly at v-points. This option would + ! have no effect on the SADOURNY Coriolis scheme if it + ! were possible to use centered difference thickness fluxes. + +! === module MOM_hor_visc === +LAPLACIAN = True ! [Boolean] default = False + ! If true, use a Laplacian horizontal viscosity. +KH = 25.0 ! [m2 s-1] default = 0.0 + ! The background Laplacian horizontal viscosity. +KH_VEL_SCALE = 0.003 ! [m s-1] default = 0.0 + ! The velocity scale which is multiplied by the grid + ! spacing to calculate the Laplacian viscosity. + ! The final viscosity is the largest of this scaled + ! viscosity, the Smagorinsky viscosity and KH. +SMAGORINSKY_KH = True ! [Boolean] default = False + ! If true, use a Smagorinsky nonlinear eddy viscosity. +SMAG_LAP_CONST = 0.15 ! [nondim] default = 0.0 + ! The nondimensional Laplacian Smagorinsky constant, + ! often 0.15. +AH_VEL_SCALE = 0.003 ! [m s-1] default = 0.0 + ! The velocity scale which is multiplied by the cube of + ! the grid spacing to calculate the Laplacian viscosity. + ! The final viscosity is the largest of this scaled + ! viscosity, the Smagorinsky viscosity and AH. +SMAGORINSKY_AH = True ! [Boolean] default = False + ! If true, use a biharmonic Smagorinsky nonlinear eddy + ! viscosity. +SMAG_BI_CONST = 0.06 ! [nondim] default = 0.0 + ! The nondimensional biharmonic Smagorinsky constant, + ! typically 0.015 - 0.06. + +! === module MOM_vert_friction === +DIRECT_STRESS = True ! [Boolean] default = False + ! If true, the wind stress is distributed over the + ! topmost HMIX_STRESS of fluid (like in HYCOM), and KVML + ! may be set to a very small value. +U_TRUNC_FILE = "U_velocity_truncations" ! default = "" + ! The absolute path to a file into which the accelerations + ! leading to zonal velocity truncations are written. + ! Undefine this for efficiency if this diagnostic is not + ! needed. +V_TRUNC_FILE = "V_velocity_truncations" ! default = "" + ! The absolute path to a file into which the accelerations + ! leading to meridional velocity truncations are written. + ! Undefine this for efficiency if this diagnostic is not + ! needed. +HARMONIC_VISC = True ! [Boolean] default = False + ! If true, use the harmonic mean thicknesses for + ! calculating the vertical viscosity. +HMIX_FIXED = 20.0 ! [m] + ! The prescribed depth over which the near-surface + ! viscosity and diffusivity are elevated when the bulk + ! mixed layer is not used. +KV = 1.0E-04 ! [m2 s-1] + ! The background kinematic viscosity in the interior. + ! The molecular value, ~1e-6 m2 s-1, may be used. +KV_ML_INVZ2 = 0.01 ! [m2 s-1] default = 0.0 + ! An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, with + ! the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the distance + ! from the surface, to allow for finite wind stresses to be transmitted through. +HBBL = 10.0 ! [m] + ! The thickness of a bottom boundary layer with a + ! viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or + ! the thickness over which near-bottom velocities are + ! averaged for the drag law if BOTTOMDRAGLAW is defined + ! but LINEAR_DRAG is not. +MAXVEL = 10.0 ! [m s-1] default = 3.0E+08 + ! The maximum velocity allowed before the velocity + ! components are truncated. + +! === module MOM_PointAccel === + +! === module MOM_set_visc === +USE_JACKSON_PARAM = True ! [Boolean] default = False + ! If true, use the Jackson-Hallberg-Legg (JPO 2008) + ! shear mixing parameterization. +DRAG_BG_VEL = 0.05 ! [m s-1] default = 0.0 + ! DRAG_BG_VEL is either the assumed bottom velocity (with + ! LINEAR_DRAG) or an unresolved velocity that is + ! combined with the resolved velocity to estimate the + ! velocity magnitude. DRAG_BG_VEL is only used when + ! BOTTOMDRAGLAW is defined. +BBL_THICK_MIN = 0.1 ! [m] default = 0.0 + ! The minimum bottom boundary layer thickness that can be + ! used with BOTTOMDRAGLAW. This might be + ! Kv / (cdrag * drag_bg_vel) to give Kv as the minimum + ! near-bottom viscosity. + +! === module MOM_barotropic === +BOUND_BT_CORRECTION = True ! [Boolean] default = False + ! If true, the corrective pseudo mass-fluxes into the + ! barotropic solver are limited to values that require + ! less than 0.1*MAXVEL to be accommodated. +!BT x-halo = 0 ! + ! The barotropic x-halo size that is actually used. +!BT y-halo = 0 ! + ! The barotropic y-halo size that is actually used. +NONLINEAR_BT_CONTINUITY = True ! [Boolean] default = False + ! If true, use nonlinear transports in the barotropic + ! continuity equation. This does not apply if + ! USE_BT_CONT_TYPE is true. +BT_PROJECT_VELOCITY = True ! [Boolean] default = False + ! If true, step the barotropic velocity first and project + ! out the velocity tendancy by 1+BEBT when calculating the + ! transport. The default (false) is to use a predictor + ! continuity step to find the pressure field, and then + ! to do a corrector continuity step using a weighted + ! average of the old and new velocities, with weights + ! of (1-BEBT) and BEBT. +BT_THICK_SCHEME = "FROM_BT_CONT" ! default = "HYBRID" + ! A string describing the scheme that is used to set the + ! open face areas used for barotropic transport and the + ! relative weights of the accelerations. Valid values are: + ! ARITHMETIC - arithmetic mean layer thicknesses + ! HARMONIC - harmonic mean layer thicknesses + ! HYBRID (the default) - use arithmetic means for + ! layers above the shallowest bottom, the harmonic + ! mean for layers below, and a weighted average for + ! layers that straddle that depth + ! FROM_BT_CONT - use the average thicknesses kept + ! in the h_u and h_v fields of the BT_cont_type +BT_STRONG_DRAG = False ! [Boolean] default = True + ! If true, use a stronger estimate of the retarding + ! effects of strong bottom drag, by making it implicit + ! with the barotropic time-step instead of implicit with + ! the baroclinic time-step and dividing by the number of + ! barotropic steps. +BEBT = 0.2 ! [nondim] default = 0.1 + ! BEBT determines whether the barotropic time stepping + ! uses the forward-backward time-stepping scheme or a + ! backward Euler scheme. BEBT is valid in the range from + ! 0 (for a forward-backward treatment of nonrotating + ! gravity waves) to 1 (for a backward Euler treatment). + ! In practice, BEBT must be greater than about 0.05. +DTBT = -0.95 ! [s or nondim] default = -0.98 + ! The barotropic time step, in s. DTBT is only used with + ! the split explicit time stepping. To set the time step + ! automatically based the maximum stable value use 0, or + ! a negative value gives the fraction of the stable value. + ! Setting DTBT to 0 is the same as setting it to -0.98. + ! The value of DTBT that will actually be used is an + ! integer fraction of DT, rounding down. + +! === module MOM_thickness_diffuse === + +! === module MOM_diabatic_driver === +! The following parameters are used for diabatic processes. +KD = 1.0E-04 ! [m2 s-1] + ! The background diapycnal diffusivity of density in the + ! interior. Zero or the molecular value, ~1e-7 m2 s-1, + ! may be used. + +! === module MOM_KPP === +! This is the MOM wrapper to CVmix:KPP +! See http://code.google.com/p/cvmix/ +KPP% +%KPP + +! === module MOM_diffConvection === +! This module implements enhanced diffusivity as a +! function of static stability, N^2. +CONVECTION% +%CONVECTION + +! === module MOM_entrain_diffusive === +MAX_ENT_IT = 20 ! default = 5 + ! The maximum number of iterations that may be used to + ! calculate the interior diapycnal entrainment. +TOLERANCE_ENT = 1.0E-05 ! [m] default = 1.095445115010332E-05 + ! The tolerance with which to solve for entrainment values. + +! === module MOM_kappa_shear === +MAX_RINO_IT = 25 ! [nondim] default = 50 + ! The maximum number of iterations that may be used to + ! estimate the Richardson number driven mixing. + +! === module MOM_regularize_layers === + +! === module MOM_tracer_advect === + +! === module MOM_tracer_hor_diff === + +! === module MOM_surface_forcing === +VARIABLE_WINDS = False ! [Boolean] default = True + ! If true, the winds vary in time after the initialization. +VARIABLE_BUOYFORCE = False ! [Boolean] default = True + ! If true, the buoyancy forcing varies in time after the + ! initialization of the model. +BUOY_CONFIG = "zero" ! + ! The character string that indicates how buoyancy forcing + ! is specified. Valid options include (file), (zero), + ! (linear), (USER), and (NONE). +WIND_CONFIG = "zero" ! + ! The character string that indicates how wind forcing + ! is specified. Valid options include (file), (2gyre), + ! (1gyre), (gyres), (zero), and (USER). + +! === module MOM_sum_output === +MAXTRUNC = 10 ! [truncations save_interval-1] default = 0 + ! The run will be stopped, and the day set to a very + ! large value if the velocity is truncated more than + ! MAXTRUNC times between energy saves. Set MAXTRUNC to 0 + ! to stop if there is any truncation of velocities. +DATE_STAMPED_STDOUT = False ! [Boolean] default = True + ! If true, use dates (not times) in messages to stdout +TIMEUNIT = 120.0 ! [s] default = 8.64E+04 + ! The time unit in seconds a number of input fields +MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 + ! The maximum amount of cpu time per processor for which + ! MOM should run before saving a restart file and + ! quitting with a return value that indicates that a + ! further run is required to complete the simulation. + ! If automatic restarts are not desired, use a negative + ! value for MAXCPU. MAXCPU has units of wall-clock + ! seconds, so the actual CPU time used is larger by a + ! factor of the number of processors used. + +! === module MOM_main (MOM_driver) === +DT_FORCING = 360.0 ! [s] default = 120.0 + ! The time step for changing forcing, coupling with other + ! components, or potentially writing certain diagnostics. + ! The default value is given by DT. +DAYMAX = 6.0 ! [hours] + ! The final time of the whole simulation, in units of + ! TIMEUNIT seconds. This also sets the potential end + ! time of the present run segment if the end time is + ! not set (as it was here) via ocean_solo_nml in input.nml. +RESTART_CONTROL = 3 ! default = 1 + ! An integer whose bits encode which restart files are + ! written. Add 2 (bit 1) for a time-stamped file, and odd + ! (bit 0) for a non-time-stamped file. A non-time-stamped + ! restart file is saved at the end of the run segment + ! for any non-negative value. +RESTINT = 10.0 ! [hours] default = 0.0 + ! The interval between saves of the restart file in units + ! of TIMEUNIT. Use 0 (the default) to not save + ! incremental restart files at all. +ENERGYSAVEDAYS = 3.0 ! [hours] default = 1.44E+04 + ! The interval in units of TIMEUNIT between saves of the + ! energies of the run and other globally summed diagnostics. +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 diff --git a/.testing/tc3/MOM_override b/.testing/tc3/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc3/diag_table b/.testing/tc3/diag_table new file mode 100644 index 0000000000..64043b6e0d --- /dev/null +++ b/.testing/tc3/diag_table @@ -0,0 +1,2 @@ +"MOM test configuration 3" +1 1 1 0 0 0 diff --git a/.testing/tc3/input.nml b/.testing/tc3/input.nml new file mode 100644 index 0000000000..e9aa67941d --- /dev/null +++ b/.testing/tc3/input.nml @@ -0,0 +1,17 @@ +&MOM_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_override' +/ + +&diag_manager_nml +/ + +&fms_nml + domains_stack_size = 1326000 + stack_size = 0 +/ diff --git a/.testing/tc4/.gitignore b/.testing/tc4/.gitignore new file mode 100644 index 0000000000..4f9cc2826f --- /dev/null +++ b/.testing/tc4/.gitignore @@ -0,0 +1,15 @@ +# Autoconf +aclocal.m4 +autom4te.cache/ +config.log +config.status +configure~ + +# Output +gen_grid +ocean_hgrid.nc +topog.nc + +gen_data +sponge.nc +temp_salt_ic.nc diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input new file mode 100644 index 0000000000..591ed4c788 --- /dev/null +++ b/.testing/tc4/MOM_input @@ -0,0 +1,413 @@ +! This file was written by the model and records the non-default parameters used at run-time. + +! === module MOM === +USE_REGRIDDING = True ! [Boolean] default = False + ! If True, use the ALE algorithm (regridding/remapping). If False, use the + ! layered isopycnal algorithm. +DT = 1200.0 ! [s] + ! The (baroclinic) dynamics time step. The time-step that is actually used will + ! be an integer fraction of the forcing time-step (DT_FORCING in ocean-only mode + ! or the coupling timestep in coupled mode.) +DT_THERM = 3600.0 ! [s] default = 1200.0 + ! The thermodynamic and tracer advection time step. Ideally DT_THERM should be + ! an integer multiple of DT and less than the forcing or coupling time-step, + ! unless THERMO_SPANS_COUPLING is true, in which case DT_THERM can be an integer + ! multiple of the coupling timestep. By default DT_THERM is set to DT. +C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 + ! The heat capacity of sea water, approximated as a constant. This is only used + ! if ENABLE_THERMODYNAMICS is true. The default value is from the TEOS-10 + ! definition of conservative temperature. +USE_PSURF_IN_EOS = False ! [Boolean] default = True + ! If true, always include the surface pressure contributions in equation of + ! state calculations. +SAVE_INITIAL_CONDS = False ! [Boolean] default = False + ! If true, write the initial conditions to a file given by IC_OUTPUT_FILE. + +! === module MOM_domains === +REENTRANT_X = False ! [Boolean] default = True + ! If true, the domain is zonally reentrant. +NIGLOBAL = 14 ! + ! The total number of thickness grid points in the x-direction in the physical + ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +NJGLOBAL = 10 ! + ! The total number of thickness grid points in the y-direction in the physical + ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. + +! === module MOM_verticalGrid === +! Parameters providing information about the vertical grid. +NK = 2 ! [nondim] + ! The number of model layers. + +! === module MOM_fixed_initialization === + +! === module MOM_grid_init === +GRID_CONFIG = "mosaic" ! + ! A character string that determines the method for defining the horizontal + ! grid. Current options are: + ! mosaic - read the grid from a mosaic (supergrid) + ! file set by GRID_FILE. + ! cartesian - use a (flat) Cartesian grid. + ! spherical - use a simple spherical grid. + ! mercator - use a Mercator spherical grid. +GRID_FILE = "ocean_hgrid.nc" ! + ! Name of the file from which to read horizontal grid data. +TOPO_CONFIG = "file" ! + ! This specifies how bathymetry is specified: + ! file - read bathymetric information from the file + ! specified by (TOPO_FILE). + ! flat - flat bottom set to MAXIMUM_DEPTH. + ! bowl - an analytically specified bowl-shaped basin + ! ranging between MAXIMUM_DEPTH and MINIMUM_DEPTH. + ! spoon - a similar shape to 'bowl', but with an vertical + ! wall at the southern face. + ! halfpipe - a zonally uniform channel with a half-sine + ! profile in the meridional direction. + ! bbuilder - build topography from list of functions. + ! benchmark - use the benchmark test case topography. + ! Neverworld - use the Neverworld test case topography. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! ISOMIP - use a slope and channel configuration for the + ! ISOMIP test case. + ! DOME2D - use a shelf and slope configuration for the + ! DOME2D gravity current/overflow test case. + ! Kelvin - flat but with rotated land mask. + ! seamount - Gaussian bump for spontaneous motion test case. + ! dumbbell - Sloshing channel with reservoirs on both ends. + ! shelfwave - exponential slope for shelfwave test case. + ! Phillips - ACC-like idealized topography used in the Phillips config. + ! dense - Denmark Strait-like dense water formation and overflow. + ! USER - call a user modified routine. +!MAXIMUM_DEPTH = 100.0 ! [m] + ! The (diagnosed) maximum depth of the ocean. + +ROTATION = "betaplane" ! default = "2omegasinlat" + ! This specifies how the Coriolis parameter is specified: + ! 2omegasinlat - Use twice the planetary rotation rate + ! times the sine of latitude. + ! betaplane - Use a beta-plane or f-plane. + ! 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 === + +! === module MOM_EOS === +EQN_OF_STATE = "LINEAR" ! default = "WRIGHT" + ! EQN_OF_STATE determines which ocean equation of state should be used. + ! Currently, the valid choices are "LINEAR", "UNESCO", "WRIGHT", "NEMO" and + ! "TEOS10". This is only used if USE_EOS is true. +DRHO_DS = 0.0 ! [kg m-3 PSU-1] default = 0.8 + ! When EQN_OF_STATE=LINEAR, this is the partial derivative of density with + ! salinity. + +! === module MOM_tracer_flow_control === + +! === module MOM_coord_initialization === +COORD_CONFIG = "linear" ! default = "none" + ! This specifies how layers are to be defined: + ! ALE or none - used to avoid defining layers in ALE mode + ! file - read coordinate information from the file + ! specified by (COORD_FILE). + ! BFB - Custom coords for buoyancy-forced basin case + ! based on SST_S, T_BOT and DRHO_DT. + ! linear - linear based on interfaces not layers + ! layer_ref - linear based on layer densities + ! ts_ref - use reference temperature and salinity + ! ts_range - use range of temperature and salinity + ! (T_REF and S_REF) to determine surface density + ! and GINT calculate internal densities. + ! gprime - use reference density (RHO_0) for surface + ! density and GINT calculate internal densities. + ! ts_profile - use temperature and salinity profiles + ! (read from COORD_FILE) to set layer densities. + ! USER - call a user modified routine. +REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = False + ! If true, uses the old remapping-via-a-delta-z method for remapping u and v. If + ! false, uses the new method that remaps between grids described by an old and + ! new thickness. +REGRIDDING_COORDINATE_MODE = "Z*" ! default = "LAYER" + ! Coordinate mode for vertical regridding. Choose among the following + ! possibilities: LAYER - Isopycnal or stacked shallow water layers + ! ZSTAR, Z* - stretched geopotential z* + ! SIGMA_SHELF_ZSTAR - stretched geopotential z* ignoring shelf + ! SIGMA - terrain following coordinates + ! RHO - continuous isopycnal + ! HYCOM1 - HyCOM-like hybrid coordinate + ! HYBGEN - Hybrid coordinate from the Hycom hybgen code + ! SLIGHT - stretched coordinates above continuous isopycnal + ! ADAPTIVE - optimize for smooth neutral density surfaces +!ALE_RESOLUTION = 2*50.0 ! [m] + ! The distribution of vertical resolution for the target + ! grid used for Eulerian-like coordinates. For example, + ! in z-coordinate mode, the parameter is a list of level + ! thicknesses (in m). In sigma-coordinate mode, the list + ! is of non-dimensional fractions of the water column. +REMAPPING_SCHEME = "PPM_IH4" ! default = "PLM" + ! This sets the reconstruction scheme used for vertical remapping for all + ! variables. It can be one of the following schemes: PCM (1st-order + ! accurate) + ! PLM (2nd-order accurate) + ! PLM_HYBGEN (2nd-order accurate) + ! PPM_H4 (3rd-order accurate) + ! PPM_IH4 (3rd-order accurate) + ! PPM_HYBGEN (3rd-order accurate) + ! WENO_HYBGEN (3rd-order accurate) + ! PQM_IH4IH3 (4th-order accurate) + ! PQM_IH6IH5 (5th-order accurate) + +! === module MOM_state_initialization === +INIT_LAYERS_FROM_Z_FILE = True ! [Boolean] default = False + ! If true, initialize the layer thicknesses, temperatures, and salinities from a + ! Z-space file on a latitude-longitude grid. + +! === module MOM_initialize_layers_from_Z === +TEMP_SALT_Z_INIT_FILE = "temp_salt_ic.nc" ! default = "temp_salt_z.nc" + ! The name of the z-space input file used to initialize temperatures (T) and + ! salinities (S). If T and S are not in the same file, TEMP_Z_INIT_FILE and + ! SALT_Z_INIT_FILE must be set. +Z_INIT_ALE_REMAPPING = True ! [Boolean] default = False + ! If True, then remap straight to model coordinate from file. +SPONGE = True ! [Boolean] default = False + ! If true, sponges may be applied anywhere in the domain. The exact location and + ! properties of those sponges are specified via SPONGE_CONFIG. +SPONGE_DAMPING_FILE = "sponge.nc" ! + ! The name of the file with the sponge damping rates. +SPONGE_STATE_FILE = "temp_salt_ic.nc" ! default = "sponge.nc" + ! The name of the file with the state to damp toward. +SPONGE_PTEMP_VAR = "ptemp" ! default = "PTEMP" + ! The name of the potential temperature variable in SPONGE_STATE_FILE. +SPONGE_SALT_VAR = "salt" ! default = "SALT" + ! The name of the salinity variable in SPONGE_STATE_FILE. +INTERPOLATE_SPONGE_TIME_SPACE = True ! [Boolean] default = False + ! If True, perform on-the-fly regridding in lat-lon-time of sponge restoring + ! data. + +! === module MOM_sponge === +SPONGE_DATA_ONGRID = True ! [Boolean] default = False + ! When defined, the incoming sponge data are assumed to be on the model grid +!Total sponge columns at h points = 100 ! + ! The total number of columns where sponges are applied at h points. + +! === module MOM_diag_mediator === +DIAG_AS_CHKSUM = True ! [Boolean] default = False + ! Instead of writing diagnostics to the diag manager, write a text file + ! containing the checksum (bitcount) of the array. + +! === module MOM_lateral_mixing_coeffs === + +! === module MOM_set_visc === +LINEAR_DRAG = True ! [Boolean] default = False + ! If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag law is + ! cdrag*DRAG_BG_VEL*u. +HBBL = 10.0 ! [m] + ! The thickness of a bottom boundary layer with a viscosity increased by + ! KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which + ! near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is + ! defined but LINEAR_DRAG is not. +CDRAG = 0.002 ! [nondim] default = 0.003 + ! CDRAG is the drag coefficient relating the magnitude of the velocity field to + ! the bottom stress. CDRAG is only used if BOTTOMDRAGLAW is defined. +DRAG_BG_VEL = 0.05 ! [m s-1] default = 0.0 + ! DRAG_BG_VEL is either the assumed bottom velocity (with LINEAR_DRAG) or an + ! unresolved velocity that is combined with the resolved velocity to estimate + ! the velocity magnitude. DRAG_BG_VEL is only used when BOTTOMDRAGLAW is + ! defined. +BBL_USE_EOS = True ! [Boolean] default = True + ! If true, use the equation of state in determining the properties of the bottom + ! boundary layer. Otherwise use the layer target potential densities. +BBL_THICK_MIN = 0.1 ! [m] default = 0.0 + ! The minimum bottom boundary layer thickness that can be used with + ! BOTTOMDRAGLAW. This might be Kv/(cdrag*drag_bg_vel) to give Kv as the minimum + ! near-bottom viscosity. +KV = 1.0E-04 ! [m2 s-1] + ! The background kinematic viscosity in the interior. The molecular value, ~1e-6 + ! m2 s-1, may be used. + +! === 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 === + +! === module MOM_dynamics_split_RK2 === +BE = 0.7 ! [nondim] default = 0.6 + ! If SPLIT is true, BE determines the relative weighting of a 2nd-order + ! Runga-Kutta baroclinic time stepping scheme (0.5) and a backward Euler scheme + ! (1) that is used for the Coriolis and inertial terms. BE may be from 0.5 to + ! 1, but instability may occur near 0.5. BE is also applicable if SPLIT is false + ! and USE_RK2 is true. + +! === module MOM_continuity === + +! === module MOM_continuity_PPM === +ETA_TOLERANCE = 1.0E-12 ! [m] default = 1.0E-10 + ! The tolerance for the differences between the barotropic and baroclinic + ! estimates of the sea surface height due to the fluxes through each face. The + ! total tolerance for SSH is 4 times this value. The default is + ! 0.5*NK*ANGSTROM, and this should not be set less than about + ! 10^-15*MAXIMUM_DEPTH. + +! === module MOM_CoriolisAdv === +CORIOLIS_EN_DIS = True ! [Boolean] default = False + ! If true, two estimates of the thickness fluxes are used to estimate the + ! Coriolis term, and the one that dissipates energy relative to the other one is + ! used. +BOUND_CORIOLIS = True ! [Boolean] default = False + ! If true, the Coriolis terms at u-points are bounded by the four estimates of + ! (f+rv)v from the four neighboring v-points, and similarly at v-points. This + ! option is always effectively false with CORIOLIS_EN_DIS defined and + ! CORIOLIS_SCHEME set to SADOURNY75_ENERGY. + +! === module MOM_PressureForce === + +! === module MOM_PressureForce_FV === +RECONSTRUCT_FOR_PRESSURE = False ! [Boolean] default = True + ! If True, use vertical reconstruction of T & S within the integrals of the FV + ! pressure gradient calculation. If False, use the constant-by-layer algorithm. + ! The default is set by USE_REGRIDDING. + +! === module MOM_hor_visc === +SMAGORINSKY_AH = True ! [Boolean] default = False + ! If true, use a biharmonic Smagorinsky nonlinear eddy viscosity. +SMAG_BI_CONST = 0.03 ! [nondim] default = 0.0 + ! The nondimensional biharmonic Smagorinsky constant, typically 0.015 - 0.06. +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = True + ! If true, use the land mask for the computation of thicknesses at velocity + ! locations. This eliminates the dependence on arbitrary values over land or + ! outside of the domain. + +! === module MOM_vert_friction === +DIRECT_STRESS = True ! [Boolean] default = False + ! If true, the wind stress is distributed over the topmost HMIX_STRESS of fluid + ! (like in HYCOM), and an added mixed layer viscosity or a physically based + ! boundary layer turbulence parameterization is not needed for stability. +HMIX_FIXED = 20.0 ! [m] + ! The prescribed depth over which the near-surface viscosity and diffusivity are + ! elevated when the bulk mixed layer is not used. +KV_ML_INVZ2 = 0.01 ! [m2 s-1] default = 0.0 + ! An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, with + ! the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the distance + ! from the surface, to allow for finite wind stresses to be transmitted through + ! infinitesimally thin surface layers. This is an older option for numerical + ! convenience without a strong physical basis, and its use is now discouraged. +MAXVEL = 10.0 ! [m s-1] default = 3.0E+08 + ! The maximum velocity allowed before the velocity components are truncated. + +! === module MOM_barotropic === +BOUND_BT_CORRECTION = True ! [Boolean] default = False + ! If true, the corrective pseudo mass-fluxes into the barotropic solver are + ! limited to values that require less than maxCFL_BT_cont to be accommodated. +SSH_EXTRA = 10.0 ! [m] default = 5.0 + ! An estimate of how much higher SSH might get, for use in calculating the safe + ! external wave speed. The default is the minimum of 10 m or 5% of + ! MAXIMUM_DEPTH. +BEBT = 0.2 ! [nondim] default = 0.1 + ! BEBT determines whether the barotropic time stepping uses the forward-backward + ! time-stepping scheme or a backward Euler scheme. BEBT is valid in the range + ! from 0 (for a forward-backward treatment of nonrotating gravity waves) to 1 + ! (for a backward Euler treatment). In practice, BEBT must be greater than about + ! 0.05. +DTBT = 10.0 ! [s or nondim] default = -0.98 + ! The barotropic time step, in s. DTBT is only used with the split explicit time + ! stepping. To set the time step automatically based the maximum stable value + ! use 0, or a negative value gives the fraction of the stable value. Setting + ! DTBT to 0 is the same as setting it to -0.98. The value of DTBT that will + ! actually be used is an integer fraction of DT, rounding down. + +! === module MOM_diagnostics === + +! === module MOM_diabatic_driver === +! The following parameters are used for diabatic processes. + +! === module MOM_set_diffusivity === +BBL_EFFIC = 0.0 ! [nondim] default = 0.2 + ! The efficiency with which the energy extracted by bottom drag drives BBL + ! diffusion. This is only used if BOTTOMDRAGLAW is true. + +! === module MOM_bkgnd_mixing === +! Adding static vertical background mixing coefficients +KD = 0.0 ! [m2 s-1] + ! The background diapycnal diffusivity of density in the interior. Zero or the + ! molecular value, ~1e-7 m2 s-1, may be used. + +! === module MOM_diabatic_aux === +! The following parameters are used for auxiliary diabatic processes. + +! === module MOM_opacity === +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 1.0 + ! A thickness that is used to absorb the remaining penetrating shortwave heat + ! flux when it drops below PEN_SW_FLUX_ABSORB. + +! === module MOM_tracer_advect === + +! === module MOM_tracer_hor_diff === + +! === module MOM_sum_output === +MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 + ! The run will be stopped, and the day set to a very large value if the velocity + ! is truncated more than MAXTRUNC times between energy saves. Set MAXTRUNC to 0 + ! to stop if there is any truncation of velocities. +DATE_STAMPED_STDOUT = False ! [Boolean] default = True + ! If true, use dates (not times) in messages to stdout +ENERGYSAVEDAYS = 0.125 ! [days] default = 1.0 + ! The interval in units of TIMEUNIT between saves of the energies of the run and + ! other globally summed diagnostics. + +! === module MOM_surface_forcing === +VARIABLE_WINDS = False ! [Boolean] default = True + ! If true, the winds vary in time after the initialization. +VARIABLE_BUOYFORCE = False ! [Boolean] default = True + ! If true, the buoyancy forcing varies in time after the initialization of the + ! model. +BUOY_CONFIG = "zero" ! + ! The character string that indicates how buoyancy forcing is specified. Valid + ! options include (file), (zero), (linear), (USER), (BFB) and (NONE). +WIND_CONFIG = "zero" ! + ! The character string that indicates how wind forcing is specified. Valid + ! 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] + ! The final time of the whole simulation, in units of TIMEUNIT seconds. This + ! also sets the potential end time of the present run segment if the end time is + ! not set via ocean_solo_nml in input.nml. +RESTART_CONTROL = 3 ! default = 1 + ! An integer whose bits encode which restart files are written. Add 2 (bit 1) + ! for a time-stamped file, and odd (bit 0) for a non-time-stamped file. A + ! non-time-stamped restart file is saved at the end of the run segment for any + ! non-negative value. + +! === module MOM_write_cputime === +MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 + ! The maximum amount of cpu time per processor for which MOM should run before + ! saving a restart file and quitting with a return value that indicates that a + ! further run is required to complete the simulation. If automatic restarts are + ! not desired, use a negative value for MAXCPU. MAXCPU has units of wall-clock + ! seconds, so the actual CPU time used is larger by a factor of the number of + ! processors used. + +! === module MOM_file_parser === + +DEBUG = True + +INTERPOLATE_RES_FN = True ! [Boolean] default = True +GILL_EQUATORIAL_LD = False ! [Boolean] default = False +FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +USE_MLD_ITERATION = False ! [Boolean] default = False + diff --git a/.testing/tc4/MOM_override b/.testing/tc4/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc4/Makefile.in b/.testing/tc4/Makefile.in new file mode 100644 index 0000000000..714a8f19f1 --- /dev/null +++ b/.testing/tc4/Makefile.in @@ -0,0 +1,60 @@ +FC = @FC@ +LD = @LD@ +FCFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ + +LAUNCHER ?= + +OUT = ocean_hgrid.nc topog.nc temp_salt_ic.nc sponge.nc + +# Since each program generates two outputs, we can only use one to track the +# creation. The second rule is used to indirectly re-invoke the first rule. +# +# Reference: +# https://www.gnu.org/software/automake/manual/html_node/Multiple-Outputs.html + +# Program output +all: ocean_hgrid.nc temp_salt_ic.nc +executables: gen_data gen_grid + +ocean_hgrid.nc: gen_grid + $(LAUNCHER) ./gen_grid +topog.nc: ocean_hgrid.nc + @test -f $@ || rm -f $^ + @test -f $@ || $(MAKE) $^ + +temp_salt_ic.nc: gen_data ocean_hgrid.nc + $(LAUNCHER) ./gen_data +sponge.nc: temp_salt_ic.nc + @test -f $@ || rm -f $^ + @test -f $@ || $(MAKE) $^ + + +# Programs + +gen_grid: gen_grid.F90 + $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $^ $(LIBS) + +gen_data: gen_data.F90 + $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $^ $(LIBS) + + +# Support + +.PHONY: clean +clean: + rm -rf $(OUT) gen_grid gen_data + +.PHONY: distclean +distclean: clean + rm -f config.log + rm -f config.status + rm -f Makefile + +.PHONY: ac-clean +ac-clean: distclean + rm -f aclocal.m4 + rm -rf autom4te.cache + rm -f configure + rm -f configure~ diff --git a/.testing/tc4/configure.ac b/.testing/tc4/configure.ac new file mode 100644 index 0000000000..c431ad65ef --- /dev/null +++ b/.testing/tc4/configure.ac @@ -0,0 +1,71 @@ +# tc4 preprocessor configuration +AC_PREREQ([2.63]) +AC_INIT([], []) + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([gen_grid.F90]) +AC_CONFIG_MACRO_DIR([../../ac/m4]) + + +# Explicitly assume free-form Fortran +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) + +# We do not need MPI, but we want to emulate the executable used in MOM6 +AX_MPI([], [AC_MSG_ERROR([Could not find MPI launcher.])]) +AC_SUBST([FC], [$MPIFC]) +AC_SUBST([LD], [$MPILD]) + + +# netCDF configuration + +# Search for the Fortran netCDF module. +AX_FC_CHECK_MODULE([netcdf], [], [ + AS_UNSET([ax_fc_cv_mod_netcdf]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([FCFLAGS], ["$FCFLAGS -I$($NF_CONFIG --includedir)"]) + ], [AC_MSG_ERROR([Could not find nf-config.])] + ) + AX_FC_CHECK_MODULE([netcdf], [], [ + AC_MSG_ERROR([Could not find netcdf module.]) + ]) +]) + +# Confirm that the Fortran compiler can link the netCDF C library +AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AS_UNSET([ax_fc_cv_c_lib_netcdf_nc_create]) + AC_PATH_PROG([NC_CONFIG], [nc-config]) + AS_IF([test -n "$NC_CONFIG"], [ + AC_SUBST([LDFLAGS], ["$LDFLAGS -L$($NC_CONFIG --libdir)"]) + ], [ + AC_MSG_ERROR([Could not find nc-config.]) + ]) + AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AC_MSG_ERROR([Could not find netCDF C library.]) + ]) +]) + +# Confirm that the Fortran compiler can link to the netCDF Fortran library. +# NOTE: +# - 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)"] + ) + ], [ + 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]) +AC_OUTPUT diff --git a/.testing/tc4/diag_table b/.testing/tc4/diag_table new file mode 100644 index 0000000000..e08d2714c2 --- /dev/null +++ b/.testing/tc4/diag_table @@ -0,0 +1,2 @@ +"MOM test configuration 4" +1 1 1 0 0 0 diff --git a/.testing/tc4/gen_data.F90 b/.testing/tc4/gen_data.F90 new file mode 100644 index 0000000000..8f44aa1465 --- /dev/null +++ b/.testing/tc4/gen_data.F90 @@ -0,0 +1,189 @@ +use netcdf +implicit none + +integer, parameter :: dp = selected_real_kind(10, 100) + !! Double precision (8-byte) + +integer, parameter :: nz = 3 + !! Number of vertical layers +real(kind=dp), parameter :: salt0 = 35._dp + !! Background salinity +real(kind=dp), parameter :: dampTime = 20._dp + !! Sponge damping timescale [days] +real(kind=dp), parameter :: secs_per_day = 86400._dp + !! Seconds per calendar day + +integer :: ncid + +integer :: x_id, y_id +integer :: lon_dimid, lat_dimid, depth_dimid, time_dimid +integer :: lon_id, lat_id, depth_id, time_id, temp_id, salt_id, idamp_id +integer :: field_dimids(2) +integer :: nx, ny + +integer :: i, rc + +real(kind=dp), allocatable :: x(:,:), y(:,:), z(:) + !! Temperature grid positions +real(kind=dp), allocatable :: zbot(:,:) + !! Bottom topography +real(kind=dp) :: zbot0 + !! Maximum topographic depth +real(kind=dp), allocatable :: temp(:,:,:), salt(:,:,:) + !! Initial temperature and salinity fields +real(kind=dp), allocatable :: Idamp(:,:) + !! Sponge dampening rate + +! Read the domain grid +rc = nf90_open('ocean_hgrid.nc', NF90_NOWRITE, ncid) + +rc = nf90_inq_varid(ncid, 'x', x_id) +rc = nf90_inq_varid(ncid, 'y', y_id) + +rc = nf90_inquire_variable(ncid, x_id, dimids=field_dimids) +rc = nf90_inquire_dimension(ncid, field_dimids(1), len=nx) +rc = nf90_inquire_dimension(ncid, field_dimids(2), len=ny) + +! Extract center ("T") points of supergrid +nx = nx / 2 +ny = ny / 2 +allocate(x(nx, ny), y(nx, ny)) +rc = nf90_get_var(ncid, x_id, x, start=[2,2], stride=[2,2]) +rc = nf90_get_var(ncid, y_id, y, start=[2,2], stride=[2,2]) + +rc = nf90_close(ncid) + + +! Read the topographic domain +rc = nf90_open('topog.nc', NF90_NOWRITE, ncid) + +rc = nf90_inq_varid(ncid, 'depth', depth_id) +rc = nf90_inquire_variable(ncid, depth_id, dimids=field_dimids) +rc = nf90_inquire_dimension(ncid, field_dimids(1), len=nx) +rc = nf90_inquire_dimension(ncid, field_dimids(2), len=ny) + +allocate(zbot(nx, ny)) +rc = nf90_get_var(ncid, depth_id, zbot) +rc = nf90_close(ncid) + + +! Construct the vertical axis +allocate(z(nz)) +z = [(i, i=0,nz-1)] * maxval(zbot) / nz + +allocate(temp(nx, ny, nz), salt(nx, ny, nz)) +call t_fc(x, y, z, temp) +salt(:,:,:) = salt0 + + +! Write T/S initial state +rc = nf90_create('temp_salt_ic.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'lon', nx, lon_dimid) +rc = nf90_def_dim(ncid, 'lat', ny, lat_dimid) +rc = nf90_def_dim(ncid, 'depth', nz, depth_dimid) +rc = nf90_def_dim(ncid, 'Time', NF90_UNLIMITED, time_dimid) + +rc = nf90_def_var(ncid, 'depth', NF90_DOUBLE, [depth_dimid], depth_id) +rc = nf90_def_var(ncid, 'lon', NF90_DOUBLE, [lon_dimid], lon_id) +rc = nf90_def_var(ncid, 'lat', NF90_DOUBLE, [lat_dimid], lat_id) +rc = nf90_def_var(ncid, 'Time', NF90_DOUBLE, [time_dimid], time_id) + +rc = nf90_put_att(ncid, time_id, 'calendar', 'noleap') +rc = nf90_put_att(ncid, time_id, 'units', 'days since 0001-01-01 00:00:00.0') +! NOTE: nf90_put_att() truncates empty strings, so use nf90_put_att_any() +rc = nf90_put_att_any(ncid, time_id, 'modulo', NF90_CHAR, 1, ' ') + +rc = nf90_def_var(ncid, 'ptemp', NF90_DOUBLE, & + [lon_dimid, lat_dimid, depth_dimid, time_dimid], temp_id) +rc = nf90_def_var_fill(ncid, temp_id, 0, -1e20_dp) + +rc = nf90_def_var(ncid, 'salt', NF90_DOUBLE, & + [lon_dimid, lat_dimid, depth_dimid, time_dimid], salt_id) +rc = nf90_def_var_fill(ncid, salt_id, 0, -1e20_dp) + +rc = nf90_enddef(ncid) + +rc = nf90_put_var(ncid, lon_id, x(:,1)) +rc = nf90_put_var(ncid, lat_id, y(1,:)) +rc = nf90_put_var(ncid, depth_id, z) +rc = nf90_put_var(ncid, time_id, 0.) +rc = nf90_put_var(ncid, temp_id, temp) +rc = nf90_put_var(ncid, salt_id, salt) + +rc = nf90_close(ncid) + + +! Sponge file +rc = nf90_create('sponge.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'lon', nx, lon_dimid) +rc = nf90_def_dim(ncid, 'lat', ny, lat_dimid) + +rc = nf90_def_var(ncid, 'lon', NF90_DOUBLE, lon_id) +rc = nf90_def_var(ncid, 'lat', NF90_DOUBLE, lat_id) +rc = nf90_def_var(ncid, 'Idamp', NF90_DOUBLE, [lon_dimid, lat_dimid], Idamp_id) +rc = nf90_def_var_fill(ncid, Idamp_id, 0, -1e20_dp) + +rc = nf90_enddef(ncid) + +allocate(Idamp(nx, ny)) +Idamp = 0. +if (dampTime > 0.) & + Idamp(:,:) = 1. / (dampTime * secs_per_day) + +rc = nf90_put_var(ncid, Idamp_id, Idamp) +rc = nf90_put_var(ncid, lon_id, x(:,1)) +rc = nf90_put_var(ncid, lat_id, y(1,:)) + +rc = nf90_close(ncid) + +contains + +subroutine t_fc(x, y, z, tl, radius, tmag) + real(kind=dp), intent(in) :: x(:,:), y(:,:), z(:) + !! Grid positions + real(kind=dp), intent(inout) :: tl(:,:,:) + !! Temperature field on the model grid + real(kind=dp), intent(in), optional :: radius + !! Temperature anomaly radius + real(kind=dp), intent(in), optional :: tmag + !! Temperature anomaly maximum + + real(kind=dp) :: t_rad, t_max + !! Temperature field parameters (radius, max value) + real(kind=dp) :: x0, y0 + !! Center of anomaly (currently midpoint of domain) + real(kind=dp), allocatable :: r(:,:), zd(:) + !! Radial and vertical extent of anomaly + integer :: k, nz + !! Vertical level indexing + + t_rad = 5._dp + if (present(radius)) t_rad = radius + + t_max = 1._dp + if (present(tmag)) t_max = tmag + + ! Reduce supergrid size to T/S grid + allocate(zd, source=z) + + x0 = x(1 + size(x, 1)/2, 1 + size(x, 2)/2) + y0 = y(1 + size(y, 1)/2, 1 + size(y, 2)/2) + + tl(:,:,:) = 0. + nz = size(z) + if (nz > 1) then + zd(:) = z(:) / z(nz) + else + zd(:) = 0. + endif + + allocate(r, source=x) + r(:,:) = hypot(x(:,:) - x0, y(:,:) - y0) + do k = 1, nz + tl(:,:,k) = (1. - min(r(:,:) / t_rad, 1.)) * t_max * (1. - zd(k)) + enddo +end subroutine t_fc + +end diff --git a/.testing/tc4/gen_grid.F90 b/.testing/tc4/gen_grid.F90 new file mode 100644 index 0000000000..e76a681924 --- /dev/null +++ b/.testing/tc4/gen_grid.F90 @@ -0,0 +1,108 @@ +use netcdf + +implicit none + +integer, parameter :: dp = selected_real_kind(10, 100) + !! Double precision (8-byte) + +integer, parameter :: nx = 14, ny = 10 + !! Grid size +real(kind=dp), parameter :: depth0 = 100._dp + !! Uniform depth +real(kind=dp), parameter :: ds = 0.01_dp + !! Grid resolution at the equator in degrees +real(kind=dp), parameter :: Re = 6.378e6_dp + !! Radius of earth +real(kind=dp), parameter :: rad_per_deg = (4. * atan(1._dp)) / 180._dp + !! Degress to radians (= pi/180.) + +integer :: ncid +integer :: nx_id, ny_id, nxp_id, nyp_id, ntile_id, string_id +integer :: depth_id, h2_id +integer :: x_id, y_id, dx_id, dy_id, area_id, angle_id, tile_id + +! Fields on model grid +real(kind=dp) :: depth(nx, ny) + +! Grid fields (defined on supergrid) +real(kind=dp) :: xg(0:2*nx), yg(0:2*ny) +real(kind=dp) :: x(0:2*nx, 0:2*ny), y(0:2*nx, 0:2*ny) +real(kind=dp) :: dx(0:2*nx-1, 0:2*ny) +real(kind=dp) :: dy(0:2*nx, 0:2*ny-1) +real(kind=dp) :: area(0:2*nx-1, 0:2*ny-1) +real(kind=dp) :: angle_dx(0:2*nx, 0:2*ny) + +integer :: i, j, rc + + +! Topography +rc = nf90_create('topog.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'ny', ny, ny_id) +rc = nf90_def_dim(ncid, 'nx', nx, nx_id) +rc = nf90_def_dim(ncid, 'ntiles', 1, ntile_id) + +rc = nf90_def_var(ncid, 'depth', NF90_DOUBLE, [nx_id, ny_id], depth_id) +rc = nf90_def_var(ncid, 'h2', NF90_DOUBLE, [nx_id, ny_id], h2_id) + +rc = nf90_enddef(ncid) + +depth(:,:) = depth0 +rc = nf90_put_var(ncid, depth_id, depth) + +rc = nf90_close(ncid) + + +! Horizontal grid +rc = nf90_create('ocean_hgrid.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'ny', 2*ny, ny_id) +rc = nf90_def_dim(ncid, 'nx', 2*nx, nx_id) +rc = nf90_def_dim(ncid, 'nyp', 2*ny+1, nyp_id) +rc = nf90_def_dim(ncid, 'nxp', 2*nx+1, nxp_id) +rc = nf90_def_dim(ncid, 'string', 5, string_id) + +rc = nf90_def_var(ncid, 'y', NF90_DOUBLE, [nxp_id, nyp_id], y_id) +rc = nf90_def_var(ncid, 'x', NF90_DOUBLE, [nxp_id, nyp_id], x_id) +rc = nf90_def_var(ncid, 'dy', NF90_DOUBLE, [nxp_id, ny_id], dy_id) +rc = nf90_def_var(ncid, 'dx', NF90_DOUBLE, [nx_id, nyp_id], dx_id) +rc = nf90_def_var(ncid, 'area', NF90_DOUBLE, [nx_id, ny_id], area_id) +rc = nf90_def_var(ncid, 'angle_dx', NF90_DOUBLE, [nxp_id, nyp_id], angle_id) +rc = nf90_def_var(ncid, 'tile', NF90_CHAR, string_id, tile_id) + +rc = nf90_put_att(ncid, y_id, 'units', 'degrees') +rc = nf90_put_att(ncid, x_id, 'units', 'degrees') +rc = nf90_put_att(ncid, dy_id, 'units', 'meters') +rc = nf90_put_att(ncid, dx_id, 'units', 'meters') +rc = nf90_put_att(ncid, area_id, 'units', 'm2') +rc = nf90_put_att(ncid, angle_id, 'units', 'degrees') + +rc = nf90_enddef(ncid) + +xg = ds * [(i, i=0, 2*nx)] +yg = ds * [(j, j=0, 2*ny)] + +! NOTE: sin() and cos() are compiler-dependent + +x(:,:) = spread(xg(:), 2, 2*ny+1) +y(:,:) = spread(yg(:), 1, 2*nx+1) +dx(:,:) = rad_per_deg * Re * (x(1:,:) - x(:2*nx-1,:)) & + * cos(0.5 * rad_per_deg * (y(1:,:) + y(:2*nx-1,:))) +dy(:,:) = rad_per_deg * Re * (y(:,1:) - y(:,:2*ny-1)) + +area(:,:) = rad_per_deg * Re * Re & + * spread(sin(rad_per_deg * yg(1:)) - sin(rad_per_deg * yg(:2*ny-1)), 1, 2*nx) & + * spread(xg(1:) - xg(:2*nx-1), 2, 2*ny) + +angle_dx(:,:) = 0. + +rc = nf90_put_var(ncid, x_id, x) +rc = nf90_put_var(ncid, y_id, y) +rc = nf90_put_var(ncid, dx_id, dx) +rc = nf90_put_var(ncid, dy_id, dy) +rc = nf90_put_var(ncid, area_id, area) +rc = nf90_put_var(ncid, angle_id, angle_dx) +rc = nf90_put_var(ncid, tile_id, 'tile1') + +rc = nf90_close(ncid) +end diff --git a/.testing/tc4/input.nml b/.testing/tc4/input.nml new file mode 100644 index 0000000000..0b30a7a5a6 --- /dev/null +++ b/.testing/tc4/input.nml @@ -0,0 +1,18 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_override', +/ + +&diag_manager_nml + flush_nc_files = .true. +/ + +&fms_nml + domains_stack_size = 710000 + stack_size = 0 +/ diff --git a/.testing/tools/compare_clocks.py b/.testing/tools/compare_clocks.py new file mode 100755 index 0000000000..77198fda6a --- /dev/null +++ b/.testing/tools/compare_clocks.py @@ -0,0 +1,88 @@ +#!/usr/bin/env python +import argparse +import json + +# Ignore timers below this threshold (in seconds) +DEFAULT_THRESHOLD = 0.05 + +# Thresholds for reporting +DT_WARN = 0.10 # Slowdown warning +DT_FAIL = 0.25 # Slowdown abort + +ANSI_RED = '\033[31m' +ANSI_GREEN = '\033[32m' +ANSI_YELLOW = '\033[33m' +ANSI_RESET = '\033[0m' + + +def main(): + desc = ( + 'Compare two FMS clock output files and report any differences within ' + 'a defined threshold.' + ) + + parser = argparse.ArgumentParser(description=desc) + parser.add_argument('expt') + parser.add_argument('ref') + parser.add_argument('--threshold') + parser.add_argument('--verbose', action='store_true') + args = parser.parse_args() + + threshold = float(args.threshold) if args.threshold else DEFAULT_THRESHOLD + verbose = args.verbose + + clock_cmp = {} + + print('{:35s}{:8s} {:8s}'.format('', 'Profile', 'Reference')) + print() + + with open(args.expt) as log_expt, open(args.ref) as log_ref: + clocks_expt = json.load(log_expt)['clocks'] + clocks_ref = json.load(log_ref)['clocks'] + + # Gather timers which appear in both clocks + clock_tags = [clk for clk in clocks_expt if clk in clocks_ref] + + for clk in clock_tags: + clock_cmp[clk] = {} + + # For now, we only comparge tavg, the rank-averaged timing + rec = 'tavg' + + t_expt = clocks_expt[clk][rec] + t_ref = clocks_ref[clk][rec] + + # Compare the relative runtimes + if all(t > threshold for t in (t_expt, t_ref)): + dclk = (t_expt - t_ref) / t_ref + else: + dclk = 0. + clock_cmp[clk][rec] = dclk + + # Skip trivially low clocks + if all(t < threshold for t in (t_expt, t_ref)) and not verbose: + continue + + # Report the time differences + ansi_color = ANSI_RESET + + if abs(t_expt - t_ref) > threshold: + if dclk > DT_FAIL: + ansi_color = ANSI_RED + elif dclk > DT_WARN: + ansi_color = ANSI_YELLOW + elif dclk < -DT_WARN: + ansi_color = ANSI_GREEN + + print('{}{}: {:7.3f}s, {:7.3f}s ({:.1f}%){}'.format( + ansi_color, + ' ' * (32 - len(clk)) + clk, + t_expt, + t_ref, + 100. * dclk, + ANSI_RESET, + )) + + +if __name__ == '__main__': + main() diff --git a/.testing/tools/compare_perf.py b/.testing/tools/compare_perf.py new file mode 100755 index 0000000000..e4a651c709 --- /dev/null +++ b/.testing/tools/compare_perf.py @@ -0,0 +1,110 @@ +#!/usr/bin/env python +import argparse +import json + +# Ignore timers below this threshold (in seconds) +DEFAULT_THRESHOLD = 0.05 + +# Thresholds for reporting +DT_WARN = 0.10 # Slowdown warning +DT_FAIL = 0.25 # Slowdown abort + +ANSI_RED = '\033[31m' +ANSI_GREEN = '\033[32m' +ANSI_YELLOW = '\033[33m' +ANSI_RESET = '\033[0m' + + +def main(): + desc = ( + 'Compare two FMS clock output files and report any differences within ' + 'a defined threshold.' + ) + + parser = argparse.ArgumentParser(description=desc) + parser.add_argument('expt') + parser.add_argument('ref') + parser.add_argument('--threshold') + parser.add_argument('--verbose', action='store_true') + args = parser.parse_args() + + threshold = float(args.threshold) if args.threshold else DEFAULT_THRESHOLD + verbose = args.verbose + + clock_cmp = {} + + print('{:35s}{:8s} {:8s}'.format('', 'Profile', 'Reference')) + print() + + with open(args.expt) as profile_expt, open(args.ref) as profile_ref: + perf_expt = json.load(profile_expt) + perf_ref = json.load(profile_ref) + + events = [ev for ev in perf_expt if ev in perf_ref] + + for event in events: + # For now, only report the times + if event not in ('task-clock', 'cpu-clock'): + continue + + count_expt = perf_expt[event]['count'] + count_ref = perf_ref[event]['count'] + + symbols_expt = perf_expt[event]['symbol'] + symbols_ref = perf_ref[event]['symbol'] + + symbols = [ + s for s in symbols_expt + if s in symbols_ref + and not s.startswith('0x') + ] + + for symbol in symbols: + t_expt = float(symbols_expt[symbol]) / 1e9 + t_ref = float(symbols_ref[symbol]) / 1e9 + + # Compare the relative runtimes + if all(t > threshold for t in (t_expt, t_ref)): + dclk = (t_expt - t_ref) / t_ref + else: + dclk = 0. + + # Skip trivially low clocks + if all(t < threshold for t in (t_expt, t_ref)) and not verbose: + continue + + # Report the time differences + ansi_color = ANSI_RESET + + if abs(t_expt - t_ref) > threshold: + if dclk > DT_FAIL: + ansi_color = ANSI_RED + elif dclk > DT_WARN: + ansi_color = ANSI_YELLOW + elif dclk < -DT_WARN: + ansi_color = ANSI_GREEN + + # Remove module name + sname = symbol.split('_MOD_', 1)[-1] + + # Strip version from glibc calls + sname = sname.split('@')[0] + + # Remove GCC optimization renaming + sname = sname.replace('.constprop.0', '') + + if len(sname) > 32: + sname = sname[:29] + '...' + + print('{}{}: {:7.3f}s, {:7.3f}s ({:.1f}%){}'.format( + ansi_color, + ' ' * (32 - len(sname)) + sname, + t_expt, + t_ref, + 100. * dclk, + ANSI_RESET, + )) + + +if __name__ == '__main__': + main() diff --git a/.testing/tools/disp_timing.py b/.testing/tools/disp_timing.py new file mode 100755 index 0000000000..ac90ef2b55 --- /dev/null +++ b/.testing/tools/disp_timing.py @@ -0,0 +1,133 @@ +#!/usr/bin/env python3 + +from __future__ import print_function + +import argparse +import json +import math + +scale = 1e6 # micro-seconds (should make this dynamic) + + +def display_timing_file(file, show_all): + """Parse a JSON file of timing results and pretty-print the results""" + + with open(file) as json_file: + timing_dict = json.load(json_file) + + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Min time Module & function") + for sub in timing_dict.keys(): + tmin = timing_dict[sub]['min'] * scale + print("%10.4e %s" % (tmin, sub)) + + if show_all: + tmean = timing_dict[sub]['mean'] * scale + tmax = timing_dict[sub]['max'] * scale + tstd = timing_dict[sub]['std'] * scale + nsamp = timing_dict[sub]['n_samples'] + tsstd = tstd / math.sqrt(nsamp) + print(" (" + + "mean = %10.4e " % (tmean) + + "±%7.1e, " % (tsstd) + + "max = %10.4e, " % (tmax) + + "std = %8.2e, " % (tstd) + + "# = %d)" % (nsamp)) + + +def compare_timing_files(file, ref, show_all, significance_threshold): + """Read and compare two JSON files of timing results""" + + with open(file) as json_file: + timing_dict = json.load(json_file) + + with open(ref) as json_file: + ref_dict = json.load(json_file) + + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Delta (%) Module & function") + for sub in {**ref_dict, **timing_dict}.keys(): + T1 = ref_dict.get(sub) + T2 = timing_dict.get(sub) + if T1 is not None: + # stats for reference (old) + tmin1 = T1['min'] * scale + tmean1 = T1['mean'] * scale + if T2 is not None: + # stats for reference (old) + tmin2 = T2['min'] * scale + tmean2 = T2['mean'] * scale + if (T1 is not None) and (T2 is not None): + # change in actual minimum as percentage of old + dt = (tmin2 - tmin1) * 100 / tmin1 + if dt < -significance_threshold: + color = '\033[92m' + elif dt > significance_threshold: + color = '\033[91m' + else: + color = '' + print("%s%+10.4f%%\033[0m %s" % (color, dt, sub)) + else: + if T2 is None: + print(" removed %s" % (sub)) + else: + print(" added %s" % (sub)) + + if show_all: + if T2 is None: + print(" --") + else: + tmax2 = T2['max'] * scale + tstd2 = T2['std'] * scale + n2 = T2['n_samples'] + tsstd2 = tstd2 / math.sqrt(n2) + print(" %10.4e (" % (tmin2) + + "mean = %10.4e " % (tmean2) + + "±%7.1e, " % (tsstd2) + + "max=%10.4e, " % (tmax2) + + "std=%8.2e, " % (tstd2) + + "# = %d)" % (n2)) + if T1 is None: + print(" --") + else: + tmax1 = T1['max'] * scale + tstd1 = T1['std'] * scale + n1 = T1['n_samples'] + tsstd1 = tstd1 / math.sqrt(n1) + print(" %10.4e (" % (tmin1) + + "mean = %10.4e " % (tmean1) + + "±%7.1e, " % (tsstd1) + + "max=%10.4e, " % (tmax1) + + "std=%8.2e, " % (tstd1) + + "# = %d)" % (n1)) + + +# Parse arguments +parser = argparse.ArgumentParser( + description="Beautify timing output from MOM6 timing tests." +) +parser.add_argument( + 'file', + help="File to process." +) +parser.add_argument( + '-a', '--all', + action='store_true', + help="Display all metrics rather than just the minimum time." +) +parser.add_argument( + '-t', '--threshold', + default=6.0, type=float, + help="Significance threshold to flag (percentage)." +) +parser.add_argument( + '-r', '--reference', + help="Reference file to compare against." +) +args = parser.parse_args() + +# Do the thing +if args.reference is None: + display_timing_file(args.file, args.all) +else: + compare_timing_files(args.file, args.reference, args.all, args.threshold) diff --git a/.testing/tools/parse_fms_clocks.py b/.testing/tools/parse_fms_clocks.py new file mode 100755 index 0000000000..fd3e7179d7 --- /dev/null +++ b/.testing/tools/parse_fms_clocks.py @@ -0,0 +1,158 @@ +#!/usr/bin/env python +import argparse +import collections +import json +import os +import sys + +import f90nml + +record_type = collections.defaultdict(lambda: float) +for rec in ('grain', 'pemin', 'pemax',): + record_type[rec] = int + + +def main(): + desc = 'Parse MOM6 model stdout and return clock data in JSON format.' + + parser = argparse.ArgumentParser(description=desc) + parser.add_argument('--format', '-f', action='store_true') + parser.add_argument('--dir', '-d') + parser.add_argument('log') + args = parser.parse_args() + + config = {} + + if args.dir: + # Gather model configuration + input_nml = os.path.join(args.dir, 'input.nml') + nml = f90nml.read(input_nml) + config['input.nml'] = nml.todict() + + parameter_filenames = [ + ('params', 'MOM_parameter_doc.all'), + ('layout', 'MOM_parameter_doc.layout'), + ('debug', 'MOM_parameter_doc.debugging'), + ] + for key, fname in parameter_filenames: + config[key] = {} + with open(os.path.join(args.dir, fname)) as param_file: + params = parse_mom6_param(param_file) + config[key].update(params) + + # Get log path + if os.path.isfile(args.log): + log_path = args.log + elif os.path.isfile(os.path.join(args.dir, args.log)): + log_path = os.path.join(args.dir, args.log) + else: + sys.exit('stdout log not found.') + + # Parse timings + with open(log_path) as log: + clocks = parse_clocks(log) + + config['clocks'] = clocks + + if args.format: + print(json.dumps(config, indent=4)) + else: + print(json.dumps(config)) + + +def parse_mom6_param(param_file, header=None): + """Parse a MOM6 input file and return its contents. + + param_file: Path to MOM input file. + header: Optional argument indicating current subparameter block. + """ + params = {} + for line in param_file: + # Remove any trailing comments from the line. + # NOTE: Exotic values containing `!` will behave unexpectedly. + param_stmt = line.split('!')[0].strip() + + # Skip blank lines + if not param_stmt: + continue + + if param_stmt[-1] == '%': + # Set up a subparameter block which returns its own dict. + + # Extract the (potentially nested) subparameter: [...%]param% + key = param_stmt.split('%')[-2] + + # Construct subparameter endline: %param[%...] + subheader = key + if header: + subheader = header + '%' + subheader + + # Parse the subparameter contents and return as a dict. + value = parse_mom6_param(param_file, header=subheader) + + elif header and param_stmt == '%' + header: + # Finalize the current subparameter block. + break + + else: + # Extract record from `key = value` entry + # NOTE: Exotic values containing `=` will behave unexpectedly. + key, value = [s.strip() for s in param_stmt.split('=')] + + if value in ('True', 'False'): + # Boolean values are converted into Python logicals. + params[key] = bool(value) + else: + # All other values are currently stored as strings. + params[key] = value + + return params + + +def parse_clocks(log): + """Parse the FMS time stats from MOM6 output log and return as a dict. + + log: Path to file containing MOM6 stdout. + """ + + clock_start_msg = 'Tabulating mpp_clock statistics across' + clock_end_msg = 'MPP_STACK high water mark=' + + fields = [] + for line in log: + if line.startswith(clock_start_msg): + npes = line.lstrip(clock_start_msg).split()[0] + + # Get records + fields = [] + line = next(log) + + # Skip blank lines + while line.isspace(): + line = next(log) + + fields = line.split() + + # Exit this loop, begin clock parsing + break + + clocks = {} + for line in log: + # Treat MPP_STACK usage as end of clock reports + if line.lstrip().startswith(clock_end_msg): + break + + record = line.split()[-len(fields):] + + clk = line.split(record[0])[0].strip() + clocks[clk] = {} + + for fld, rec in zip(fields, record): + rtype = record_type[fld] + clocks[clk][fld] = rtype(rec) + + return clocks + + +if __name__ == '__main__': + main() diff --git a/.testing/tools/parse_perf.py b/.testing/tools/parse_perf.py new file mode 100755 index 0000000000..efcfa13b4f --- /dev/null +++ b/.testing/tools/parse_perf.py @@ -0,0 +1,128 @@ +#!/usr/bin/env python +import argparse +import collections +import json +import os +import re +import shlex +import subprocess +import sys + +perf_scanner = re.Scanner([ + (r'<', lambda scanner, token: token), + (r'>', lambda scanner, token: token), + (r'\(', lambda scanner, token: token), + (r'\)', lambda scanner, token: token), + (r'[ \t]+', lambda scanner, token: token), + (r'[^<>() \t]+', lambda scanner, token: token), +]) + + +def main(): + desc = 'Parse perf.data and return in JSON format.' + + parser = argparse.ArgumentParser(description=desc) + parser.add_argument('--format', '-f', action='store_true') + parser.add_argument('data') + args = parser.parse_args() + + profile = parse_perf_report(args.data) + + if args.format: + print(json.dumps(profile, indent=4)) + else: + print(json.dumps(profile)) + + +def parse_perf_report(perf_data_path): + profile = {} + + cmd = shlex.split( + 'perf report -s symbol,period -i {}'.format(perf_data_path) + ) + with subprocess.Popen(cmd, stdout=subprocess.PIPE, text=True) as proc: + event_name = None + for line in proc.stdout: + # Skip blank lines: + if not line or line.isspace(): + continue + + # Set the current event + if line.startswith('# Samples: '): + event_name = line.split()[-1].strip("'") + + # Remove perf modifiers for now + event_name = event_name.rsplit(':', 1)[0] + + profile[event_name] = {} + profile[event_name]['symbol'] = {} + + # Get total count + elif line.startswith('# Event count '): + event_count = int(line.split()[-1]) + profile[event_name]['count'] = event_count + + # skip all other 'comment' lines + elif line.startswith('#'): + continue + + # get per-symbol count + else: + tokens, remainder = perf_scanner.scan(line) + if remainder: + print('Line could not be tokenized', file=sys.stderr) + print(' line:', repr(line), file=sys.stderr) + print(' tokens:', tokens, file=sys.stderr) + print(' remainder:', remainder, file=sys.stderr) + sys.exit(os.EX_DATAERR) + + # Construct record from tokens + # (NOTE: Not a proper grammar, just dumb bracket counting) + record = [] + bracks = 0 + parens = 0 + + for tok in tokens: + if tok == '<': + bracks += 1 + + if tok == '(': + parens += 1 + + rec = record[-1] if record else None + + inside_bracket = rec and (bracks > 0 or parens > 0) + lead_rec = tok in '<(' and rec and not rec.isspace() + tail_rec = not tok.isspace() and rec and rec[-1] in '>)' + + if inside_bracket or lead_rec or tail_rec: + record[-1] += tok + else: + record.append(tok) + + if tok == '>': + bracks -= 1 + if tok == ')': + parens -= 1 + + # Strip any whitespace tokens + record = [rec for rec in record if not rec.isspace()] + + try: + symbol = record[2] + period = int(record[3]) + except: + print("parse_perf.py: Error extracting symbol count", + file=sys.stderr) + print("line:", repr(line), file=sys.stderr) + print("tokens:", tokens, file=sys.stderr) + print("record:", record, file=sys.stderr) + raise + + profile[event_name]['symbol'][symbol] = period + + return profile + + +if __name__ == '__main__': + main() diff --git a/.testing/tools/report_test_results.sh b/.testing/tools/report_test_results.sh new file mode 100755 index 0000000000..24bab45507 --- /dev/null +++ b/.testing/tools/report_test_results.sh @@ -0,0 +1,42 @@ +#!/bin/sh +RESULTS=${1:-${PWD}/results} + +GREEN="\033[0;32m" +RESET="\033[0m" +PASS="${GREEN}PASS${RESET}" + +if [ -d ${RESULTS} ]; then + if ls ${RESULTS}/*/std.*.err &> /dev/null; then + echo "The following tests failed to complete:" + ls ${RESULTS}/*/std.*.out \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[2]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + if ls ${RESULTS}/*/ocean.stats.*.diff &> /dev/null; then + echo "The following tests report solution regressions:" + ls ${RESULTS}/*/ocean.stats.*.diff \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[3]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + if ls ${RESULTS}/*/chksum_diag.*.diff &> /dev/null; then + echo "The following tests report diagnostic regressions:" + ls ${RESULTS}/*/chksum_diag.*.diff \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[2]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + exit 1 +else + printf "${PASS}: All tests passed!\n" +fi diff --git a/.testing/trailer.py b/.testing/trailer.py index 80b7e72738..64f016275f 100755 --- a/.testing/trailer.py +++ b/.testing/trailer.py @@ -1,95 +1,137 @@ #!/usr/bin/env python +"""Subroutines for Validating the whitespace of the source code.""" import argparse import os import re import sys + def parseCommandLine(): - """ - Parse the command line positional and optional arguments. - This is the highest level procedure invoked from the very end of the script. - """ + """Parse the command line positional and optional arguments. + + This is the highest level procedure invoked from the very end of the + script. + """ + # Arguments + parser = argparse.ArgumentParser( + description='trailer.py checks Fortran files for trailing white ' + 'space.', + epilog='Written by A.Adcroft, 2017.' + ) + parser.add_argument( + 'files_or_dirs', type=str, nargs='+', + metavar='FILE|DIR', + help='Fortran files or director in which to search for Fortran files ' + '(with .f, .f90, .F90 suffixes).''' + ) + parser.add_argument( + '-e', '--exclude_dir', type=str, action='append', + metavar='DIR', + help='''Exclude directories from search that end in DIR.''' + ) + parser.add_argument( + '-l', '--line_length', type=int, default=512, + help='''Maximum allowed length of a line.''' + ) + parser.add_argument( + '-s', '--source_line_length', type=int, default=132, + help='''Maximum allowed length of a source line excluding comments.''' + ) + parser.add_argument( + '-d', '--debug', action='store_true', + help='turn on debugging information.' + ) + args = parser.parse_args() - # Arguments - parser = argparse.ArgumentParser(description='''trailer.py checks Fortran files for trailing white space.''', - epilog='Written by A.Adcroft, 2017.') - parser.add_argument('files_or_dirs', type=str, nargs='+', - metavar='FILE|DIR', - help='''Fortran files or director in which to search for Fortran files (with .f, .f90, .F90 suffixes).''') - parser.add_argument('-e','--exclude_dir', type=str, action='append', - metavar='DIR', - help='''Exclude directories from search that end in DIR.''') - parser.add_argument('-l','--line_length', type=int, default=512, - help='''Maximum allowed length of a line.''') - parser.add_argument('-d','--debug', action='store_true', - help='turn on debugging information.') - args = parser.parse_args() + global debug + debug = args.debug - global debug - debug = args.debug + main(args) - main(args) def main(args): - ''' - Does the actual work - ''' - if (debug): print(args) + """Do the actual work.""" + if (debug): + print(args) + + # Process files_or_dirs argument into list of files + all_files = [] + for a in args.files_or_dirs: + if os.path.isfile(a): + all_files.append(a) + elif os.path.isdir(a): + for d, s, files in os.walk(a): + ignore = False + if args.exclude_dir is not None: + for e in args.exclude_dir: + if e+'/' in d+'/': + ignore = True + if not ignore: + for f in files: + _, ext = os.path.splitext(f) + if ext in ('.f', '.F', '.f90', '.F90'): + all_files.append(os.path.join(d, f)) + else: + raise Exception('Argument '+a+' is not a file or directory! ' + 'Stopping.') + if (debug): + print('Found: ', all_files) + + # For each file, check for trailing white space + fail = False + for filename in all_files: + this = scan_file(filename, line_length=args.line_length, + source_line_length=args.source_line_length) + fail = fail or this + if fail: + sys.exit(1) - # Process files_or_dirs argument into list of files - all_files = [] - for a in args.files_or_dirs: - if os.path.isfile(a): all_files.append(a) - elif os.path.isdir(a): - for d,s,files in os.walk(a): - ignore = False - if args.exclude_dir is not None: - for e in args.exclude_dir: - if e+'/' in d+'/': ignore = True - if not ignore: - for f in files: - _,ext = os.path.splitext(f) - if ext in ('.f','.F','.f90','.F90'): all_files.append( os.path.join(d,f) ) - else: raise Exception('Argument '+a+' is not a file or directory! Stopping.') - if (debug): print('Found: ',all_files) - # For each file, check for trailing white space - fail = False - for filename in all_files: - this = scan_file(filename, line_length=args.line_length) - fail = fail or this - if fail: sys.exit(1) +def scan_file(filename, line_length=512, source_line_length=132): + """Scan file for trailing white space.""" + def msg(filename, lineno, mesg, line=None): + if line is None: + print('%s, line %i: %s' % (filename, lineno, mesg)) + else: + print('%s, line %i: %s "%s"' % (filename, lineno, mesg, line)) + white_space_detected = False + tabs_space_detected = False + long_line_detected = False + with open(filename) as file: + trailing_space = re.compile(r'.* +$') + tabs = re.compile(r'.*\t.*') + lineno = 0 + for line in file.readlines(): + lineno += 1 + line = line.replace('\n', '') + srcline = line.split('!', 1)[0] # Discard comments + if trailing_space.match(line) is not None: + if debug: + print(filename, lineno, line, trailing_space.match(line)) + if len(line.strip()) > 0: + msg(filename, lineno, 'Trailing space detected', line) + else: + msg(filename, lineno, 'Blank line contains spaces') + white_space_detected = True + if tabs.match(line) is not None: + if len(line.strip()) > 0: + msg(filename, lineno, 'Tab detected', line) + else: + msg(filename, lineno, 'Blank line contains tabs') + tabs_space_detected = True + if len(line) > line_length: + if len(line.strip()) > 0: + msg(filename, lineno, 'Line length exceeded', line) + else: + msg(filename, lineno, + 'Blank line exceeds line length limit') + long_line_detected = True + if len(srcline) > source_line_length: + msg(filename, lineno, 'Non-comment line length exceeded', line) + return white_space_detected or tabs_space_detected or long_line_detected -def scan_file(filename, line_length=120): - '''Scans file for trailing white space''' - def msg(filename,lineno,mesg,line=None): - if line is None: print('%s, line %i: %s'%(filename,lineno,mesg)) - else: print('%s, line %i: %s "%s"'%(filename,lineno,mesg,line)) - white_space_detected = False - tabs_space_detected = False - long_line_detected = False - with open(filename) as file: - trailing_space = re.compile(r'.* +$') - tabs = re.compile(r'.*\t.*') - lineno = 0 - for line in file.readlines(): - lineno += 1 - line = line.replace('\n','') - if trailing_space.match(line) is not None: - if debug: print(filename,lineno,line,trailing_space.match(line)) - if len(line.strip())>0: msg(filename,lineno,'Trailing space detected',line) - else: msg(filename,lineno,'Blank line contains spaces') - white_space_detected = True - if tabs.match(line) is not None: - if len(line.strip())>0: msg(filename,lineno,'Tab detected',line) - else: msg(filename,lineno,'Blank line contains tabs') - tabs_space_detected = True - if len(line)>line_length: - if len(line.strip())>0: msg(filename,lineno,'Line length exceeded',line) - else: msg(filename,lineno,'Blank line exceeds line length limit') - long_line_detected = True - return white_space_detected or tabs_space_detected or long_line_detected # Invoke parseCommandLine(), the top-level procedure -if __name__ == '__main__': parseCommandLine() +if __name__ == '__main__': + parseCommandLine() diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 1d200d1899..0000000000 --- a/.travis.yml +++ /dev/null @@ -1,111 +0,0 @@ -# This Travis-CI file is for testing the state of the MOM6 source code. -# It does NOT test MOM6 solutions. - -# This is a not a c-language project but we use the same environment. -language: c -dist: xenial - -addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - tcsh pkg-config netcdf-bin libnetcdf-dev libnetcdff-dev openmpi-bin libopenmpi-dev gfortran - - doxygen graphviz flex bison cmake - -# Stages occur sequentially. Within each stage jobs run concurrently. -stages: - - check and compile - - tests - - cleanup - -cache: - directories: - - build - -# Compilation and testing is controlled by the "configure" and "Makefile" in -# .testing/ but they operate from the root directory. We copy them into place -# so that they can remain hidden from users. -install: - - echo "Install step" - - cp .testing/{configure,Makefile} . - -before_script: - - ls -l - - ls build - -# This avoids caching files we do not need between stages -before_cache: - - rm -f build/*.o build/*.mod - -jobs: - include: - - # Checks and compilation ################################################### -# - stage: check and compile -# script: -# - echo "Blank environment - this is where we would compile if we wanted to reuse executables in multiple tests" -# #- touch build/comp_nothing - - stage: check and compile - env: JOB="Code style compliance" - script: - - ./.testing/trailer.py -e TEOS10 -l 120 src config_src - - stage: check and compile - env: JOB="Doxygen" - script: - - cd docs && doxygen Doxyfile_nortd - - grep -v "config_src/solo_driver/coupler_types.F90" doxygen.log | tee doxy_errors - - test ! -s doxy_errors - - &compile-code - stage: check and compile - env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric REPRO=1" - script: - - make $MAKEARGS compile - - touch build/comp_${MAKEARGS//\ /_} - - <<: *compile-code - env: MAKEARGS="MEMORY_SHAPE=dynamic REPRO=1" - - <<: *compile-code - env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric DEBUG=1" - - <<: *compile-code - env: MAKEARGS="MEMORY_SHAPE=dynamic DEBUG=1" -# - <<: *compile-code -# env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric OPENMP=1" - - # Run tests ################################################################ - # The default "test" job is automatically invoked for each of the matrix environments - # The "test" jobs executes "./configure && make && make test" -# - stage: tests -# script: -# - echo "Placeholder for generic text using blank environment" - - &compile - stage: tests - env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric REPRO=1" - script: - - ./configure && make -j && make test - - <<: *compile - env: MAKEARGS="MEMORY_SHAPE=dynamic REPRO=1" - - <<: *compile - env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric DEBUG=1" - - <<: *compile - env: MAKEARGS="MEMORY_SHAPE=dynamic DEBUG=1" -# - <<: *compile -# env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric OPENMP=1" - - # Clean up ################################################################# - # We only want the cache directory to exist between stages so we manually - # clean out the cache, i.e. build/ - - &clean-build - stage: cleanup - script: - - rm -rf build/* - - ls -l -# - <<: *clean-build - env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric REPRO=1" - - <<: *clean-build - env: MAKEARGS="MEMORY_SHAPE=dynamic REPRO=1" - - <<: *clean-build - env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric DEBUG=1" - - <<: *clean-build - env: MAKEARGS="MEMORY_SHAPE=dynamic DEBUG=1" -# - <<: *clean-build -# env: MAKEARGS="MEMORY_SHAPE=dynamic_symmetric OPENMP=1" diff --git a/README.md b/README.md index 3e4ff016e3..17b0a3661c 100644 --- a/README.md +++ b/README.md @@ -1,17 +1,18 @@ -[![Build Status](https://travis-ci.org/NOAA-GFDL/MOM6.svg?branch=dev/master)](https://travis-ci.org/NOAA-GFDL/MOM6) -[![Read The Docs Status](https://readthedocs.org/projects/mom6/badge/?badge=latest)](http://mom6.readthedocs.io/) -[![codecov](https://codecov.io/gh/NOAA-GFDL/MOM6/branch/dev%2Fmaster/graph/badge.svg)](https://codecov.io/gh/NOAA-GFDL/MOM6) +[![Read The Docs Status](https://readthedocs.org/projects/mom6/badge/?version=main)](https://mom6.readthedocs.io/en/main/?badge=main) +[![codecov](https://codecov.io/gh/NOAA-GFDL/MOM6/branch/dev/gfdl/graph/badge.svg?token=uF8SVydCdp)](https://codecov.io/gh/NOAA-GFDL/MOM6) # MOM6 This is the MOM6 source code. + # Where to find information Start at the [MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki) which has installation instructions. [Source code documentation](http://mom6.readthedocs.io/) is hosted on read the docs. + # What files are what The top level directory structure groups source code and input files as follow: @@ -23,7 +24,19 @@ The top level directory structure groups source code and input files as follow: | ```src/``` | Contains the source code for MOM6 that is always compiled. | | ```config_src/``` | Contains optional source code depending on mode and configuration such as dynamic-memory versus static, ocean-only versus coupled. | | ```pkg/``` | Contains third party (non-MOM6 or FMS) code that is compiled into MOM6. | -| ```docs/``` | Workspace for generated documentation. | +| ```docs/``` | Workspace for generated documentation. See [docs/README.md](docs/README.md) | +| ```.testing/``` | Contains the verification test suite. See [.testing/README.md](.testing/README.md) | +| ```ac/``` | Contains the autoconf build configuration files. See [ac/README.md](ac/README.md) | + + +# Quick start guide + +To quickly get started and build an ocean-only MOM6 executable, see the +[autoconf README](ac/README.md). + +For setting up an experiment, or building an executable for coupled modeling, +consult the [MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki). + # Disclaimer diff --git a/ac/Makefile.in b/ac/Makefile.in new file mode 100644 index 0000000000..c4d23efdfb --- /dev/null +++ b/ac/Makefile.in @@ -0,0 +1,58 @@ +# Makefile template for MOM6 +# +# 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@ +PYTHON = @PYTHON@ +MAKEDEP = @MAKEDEP@ + +DEFS = @DEFS@ +CPPFLAGS = @CPPFLAGS@ +FCFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ +SRC_DIRS = @SRC_DIRS@ + + +-include Makefile.dep + +# Generate Makefile from template +Makefile: @srcdir@/ac/Makefile.in config.status + ./config.status + + +# Recursive wildcard (finds all files in $1 with suffixes in $2) +rwildcard=$(foreach d,$(wildcard $(1:=/*)),$(call rwildcard,$d,$2) $(filter $(subst *,%,$2),$d)) + + +# 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) + + +# Delete any files associated with configuration (including the Makefile). +.PHONY: distclean +distclean: clean + # configure output + rm -f config.log + rm -f config.status + rm -f Makefile + rm -f path_names + rm -f Makefile.dep + + +# This deletes all files generated by autoconf, including configure. +# It is more aggressive than automake's maintainer-clean. +# NOTE: Not a standard GNU target, this is for internal use only. +# Don't be surprised if the name changes or if it disappears someday. +.PHONY: ac-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~ diff --git a/ac/README.md b/ac/README.md new file mode 100644 index 0000000000..f50275c3a0 --- /dev/null +++ b/ac/README.md @@ -0,0 +1,181 @@ +# Autoconf Build Configuration + +This directory contains the configuration files required to build MOM6 using +Autoconf. + +Note that a top-level `./configure` is not contained in the repository, and the +instruction below will generate this script in the `ac` directory. + + +# Requirements + +The following tools and libraries must be installed on your system. + +* Autoconf +* Fortran compiler (e.g. GFortran) +* MPI (e.g. Open MPI, MPICH) +* netCDF, with Fortran support + +On some platforms, such as macOS, the Autoconf package may also require an +installation of Automake. + +Some packages such as netCDF may require an additional packages for Fortran +support. + + +# Quick start guide + +The following instructions will allow a new user to quickly create a MOM6 +executable for ocean-only simulations. + +Before starting, ensure that all submodules have been updated. +``` +$ git submodule update --init --recursive +``` + +Next, fetch the GFDL `mkmf` build tool and build the FMS framework library. + +For new users, a separate Makefile in `./ac/deps/` is provided for this step. +``` +$ cd ac/deps +$ make -j +``` + +To build MOM6, first generate the Autoconf `configure` script in `./ac`. +``` +$ cd ../.. # Return to the root directory +$ cd ac +$ autoreconf +``` +Then select your build directory, run the configure script, and build the +model. + +The instructions below build the model in the `./build` directory. +``` +$ cd .. # Return to the root directory +$ mkdir -p build +$ cd build +$ ../ac/configure +$ make -j +``` +This will create the MOM6 executable in the build directory. + +The steps above will produce an executable for ocean-only simulations, and +cannot be used for coupled modeling. It also requires the necessary experiment +configuration files, such as `input.nml` and `MOM_input`. For more +information, consult the [MOM6-examples +wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki). + + +# Build rules + +The Makefile produced by Autoconf provides the following rules. + +`make` + + Build the MOM6 executable. + +`make clean` + + Delete the executable and any object and module files, but preserve the + Autoconf output. + +`make distclean` + + Delete all of the files above, as well as any files generated by + `./configure`. Note that this will delete the Makefile containing this rule. + +`make ac-clean` + + Delete all of the files above, including `./configure` and any other files + created by `autoreconf`. As with `make distclean`, this will also delete the + Makefile containing this rule. + + +# Build configuration settings + +Autoconf will resolve most model dependencies, and includes the standard set of +configuration options, such as `FC` or `FCFLAGS`. The `configure` settings +specific to MOM6 are described below. + +`--enable-asymmetric` + + The MOM6 executable is configured to use symmetric grids by default. + + Use the flag above to compile using uniform (asymmetric) grids. + + Symmetric grids are defined such that the fields for every C-grid cell are + fully specified by their local values. In particular, quantities such as + velocities or vorticity are defined along the boundaries of the domain. + + Use of symmetric grids simplifies many calculations, but also results in + nonuniform domain sizes for different fields, and slightly greater storage + since the additional values can be considered redundant. + +`--enable-openmp` + + Use this flag to enable OpenMP in the build. + +`--disable-real-8` + + While MOM6 does not explicitly use double precision reals, most of the + algorithms are designed and tested under this assumption, and the default + configuration is to enforce 8-byte reals. + + This flag may be used to relax this requirement, causing the compiler to use + the default size (usually single precision reals), although there is no + guarantee that the model will be usable. + +For the complete list of settings, run `./configure --help`. + + +# GFDL Dependencies + +This section briefly describes the management of the `mkmf` and FMS +dependencies. + +When building MOM6, the `configure` script will first check if the compiler and +its configured flags (`FCFLAGS`, `LDFLAGS`, etc.) can locate `mkmf` and the FMS +library. If unavailable, then it will search in the local `ac/deps` library. +If still unavailable, then the build will abort. + +The dependencies are not automatically provided in `ac/deps`. However, running +`make -C ac/deps` will fetch and build them. If the user wishes to target an +external FMS library or `mkmf` tools, then they should set `PATH`, `FCFLAGS` +and `LDFLAGS` so that `configure` can locate them. + +Exported environment variables such as `FC` or `FCFLAGS` will be passed to the +corresponding `configure` scripts. + +The following configuration options are also provided, which can be used to +specify the git URL and commit of the dependencies. + +`MKMF_URL` (*default:* https://github.com/NOAA-GFDL/mkmf.git) + +`MKMF_COMMIT`(*default:* `master`) + +`FMS_URL` (*default:* https://github.com/NOAA-GFDL/FMS.git) + +`FMS_COMMIT` (*default:* `2019.01.03`) + + +# Known issues / Future development + +## MPI configuration + +There are minor issues with the MPI configuration macro, where it may use an +MPI build wrapper (e.g. `mpifort`) whose underlying compiler does not match +the `FC` compiler, which will often be auto-configured to `gfortran`. + +This is usually not an issue, but can cause confusion if `FCFLAGS` is +configured for the MPI wrapper but is incompatible with the `FC` compiler. + +To resolve this, ensure that `FC` and `FCFLAGS` are specified for the same +compiler. + + +## Coupled builds + +The Autoconf build is currently only capable of building ocean-only +executables, and cannot yet be used as part of a coupled model, nor as a +standalone library. This is planned to be addressed in a future release. diff --git a/ac/configure.ac b/ac/configure.ac new file mode 100644 index 0000000000..071f43f5a9 --- /dev/null +++ b/ac/configure.ac @@ -0,0 +1,327 @@ +# 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]) + +#--- +# NOTE: For the autoconf-adverse, the configuration files and autoreconf output +# are kept in the `ac` directory. +# +# This breaks the convention where configure.ac resides in the top directory. +# +# As a result, $srcdir initially points to the `ac` directory, rather than the +# top directory of the codebase. +# +# In order to balance this, we up-path (../) srcdir and point AC_CONFIG_SRCDIR +# to srcdir and point AC_CONFIG_SRCDIR to the parent directory. +# +# Someday we may revert this and work from the top-level directory. But for +# now we will isolate autoconf to a subdirectory. +#--- + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([../src/core/MOM.F90]) +AC_CONFIG_MACRO_DIR([m4]) +srcdir=$srcdir/.. + + +# Configure the memory layout header + +AC_ARG_VAR([MOM_MEMORY], + [Path to MOM_memory.h header, describing the field memory layout: dynamic + symmetric (default), dynamic asymmetric, or static.] +) + +AS_VAR_IF([MOM_MEMORY], [], + [MOM_MEMORY=${srcdir}/config_src/memory/dynamic_symmetric/MOM_memory.h] +) + +# Confirm that MOM_MEMORY is named 'MOM_memory.h' +AS_IF([test $(basename "${MOM_MEMORY}") == "MOM_memory.h"], [], + [AC_MSG_ERROR([MOM_MEMORY header ${MOM_MEMORY} must be named 'MOM_memory.h'])] +) + +# Confirm that the file exists +AC_CHECK_FILE(["$MOM_MEMORY"], [], + [AC_MSG_ERROR([MOM_MEMORY header ${MOM_MEMORY} not found.])] +) + +MOM_MEMORY_DIR=$(AS_DIRNAME(["${MOM_MEMORY}"])) +AC_SUBST([MOM_MEMORY_DIR]) + + +# Default to solo_driver +DRIVER_DIR=${srcdir}/config_src/drivers/solo_driver +AC_ARG_WITH([driver], + AS_HELP_STRING( + [--with-driver=coupled_driver|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}]) + +# TODO: Rather than point to a pre-configured header file, autoconf could be +# used to configure a header based on a template. +#AC_CONFIG_HEADERS(["$MEM_LAYOUT/MOM_memory.h"]) + + +# Explicitly assume free-form Fortran +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) + + +# Determine MPI compiler wrappers +# NOTE: +# - AX_MPI invokes AC_PROG_FC, often with gfortran, even if the MPI launcher +# does not use gfortran. +# - This can cause standard AC_PROG_FC tests to fail if FCFLAGS is configured +# with flags from another compiler. +# - I do not yet know how to resolve this possible issue. +AX_MPI([], [ + AC_MSG_ERROR([Could not find MPI launcher.]) +]) + + +# Explicitly replace FC and LD with MPI wrappers +# NOTE: This is yet another attempt to manage the potential mismatches between +# FC and MPIFC. Without this step, the tests below would not use MPIFC. +AC_SUBST(FC, $MPIFC) +AC_SUBST(LD, $MPIFC) + +# Confirm that FC can see the Fortran 90 MPI module. +AX_FC_CHECK_MODULE([mpi], + [], [AC_MSG_ERROR([Could not find MPI Fortran module.])]) + + +# netCDF configuration + +# Search for the Fortran netCDF module. +AX_FC_CHECK_MODULE([netcdf], [], [ + AS_UNSET([ax_fc_cv_mod_netcdf]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([FCFLAGS], ["$FCFLAGS -I$($NF_CONFIG --includedir)"]) + ], [AC_MSG_ERROR([Could not find nf-config.])] + ) + AX_FC_CHECK_MODULE([netcdf], [], [ + AC_MSG_ERROR([Could not find netcdf module.]) + ]) +]) + +# Confirm that the Fortran compiler can link the netCDF C library +AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AS_UNSET([ax_fc_cv_c_lib_netcdf_nc_create]) + AC_PATH_PROG([NC_CONFIG], [nc-config]) + AS_IF([test -n "$NC_CONFIG"], [ + AC_SUBST([LDFLAGS], ["$LDFLAGS -L$($NC_CONFIG --libdir)"]) + ], [ + AC_MSG_ERROR([Could not find nc-config.]) + ]) + AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AC_MSG_ERROR([Could not find netCDF C library.]) + ]) +]) + +# Confirm that the Fortran compiler can link to the netCDF Fortran library. +# NOTE: +# - 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)"] + ) + ], [ + 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"]) + + +# OpenMP configuration + +# NOTE: AC_OPENMP fails on `Fortran` for Autoconf <2.69 due to a m4 bug. +# For older versions, we test against CC and use the result for FC. +m4_version_prereq([2.69], [AC_OPENMP], [ + AC_LANG_PUSH([C]) + AC_OPENMP + AC_LANG_POP([C]) + OPENMP_FCFLAGS="$OPENMP_CFLAGS" +]) + +# NOTE: Only apply OpenMP flags if explicitly enabled. +AS_IF( + [test "$enable_openmp" = yes], [ + FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" + LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS" +]) + + +# FMS support + +# Test for fms_mod to verify FMS module access +AX_FC_CHECK_MODULE([fms_mod], [], [ + AS_UNSET([ax_fc_cv_mod_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]) +]) + +# Test for fms_init to verify FMS library linking +AX_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]) + ] +) + +# Verify that FMS is at least 2019.01.02 +# NOTE: 2019.01.02 introduced two changes: +# - diag_axis_init supports an optional domain_position argument +# - position values NORTH, EAST, CENTER were added to diag_axis_mod +# For our versioning test, we check the second feature. +AC_MSG_CHECKING([if diag_axis_mod supports domain positions]) +AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [use diag_axis_mod, only: NORTH, EAST, CENTER])], + [AC_MSG_RESULT([yes])], + [ + AC_MSG_RESULT([no]) + AC_MSG_ERROR([diag_axis_mod in MOM6 requires FMS 2019.01.02 or newer.]) + ] +) + +# Determine the FMS IO implementation. +AX_FC_CHECK_MODULE([fms2_io_mod], [ + MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2 +],[ + MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1 +]) + + +# Python interpreter test + +# Declare the Python interpreter variable +AC_ARG_VAR([PYTHON], [Python interpreter command]) + +# If PYTHON is set to an empty string, then unset it +AS_VAR_IF([PYTHON], [], [AS_UNSET([PYTHON])], []) + +# Now attempt to find a Python interpreter if PYTHON is unset +AS_VAR_SET_IF([PYTHON], [ + AC_PATH_PROGS([PYTHON], ["$PYTHON"], [none]) +], [ + AC_PATH_PROGS([PYTHON], [python python3 python2], [none]) +]) +AS_VAR_IF([PYTHON], [none], [ + AC_MSG_ERROR([Python interpreter not found.]) +]) + + +# Makedep test +AC_PATH_PROG([MAKEDEP], [makedep], [${srcdir}/ac/makedep]) +AC_SUBST([MAKEDEP]) + + +# Generate source list and configure dependency command +AC_SUBST([SRC_DIRS], ["\\ + ${srcdir}/src \\ + ${MODEL_FRAMEWORK} \\ + ${srcdir}/config_src/external \\ + ${DRIVER_DIR} \\ + ${MOM_MEMORY_DIR}"] +) +AC_CONFIG_COMMANDS(Makefile.dep, [make depend]) + + +# POSIX verification tests + +# Symbols in may be defined as macros, making them inaccessible by +# Fortran C bindings. `sigsetjmp` is known to have an internal symbol in +# glibc, so we check for this possibility. For the others, we only check for +# existence. + +# If the need arises, we may want to define these under a standalone macro. + +# Validate the setjmp symbol +AX_FC_CHECK_BIND_C([setjmp], + [SETJMP="setjmp"], [SETJMP="setjmp_missing"] +) +AC_DEFINE_UNQUOTED([SETJMP_NAME], ["${SETJMP}"]) + +# Validate the longjmp symbol +AX_FC_CHECK_BIND_C([longjmp], + [LONGJMP="longjmp"], [LONGJMP="longjmp_missing"] +) +AC_DEFINE_UNQUOTED([LONGJMP_NAME], ["${LONGJMP}"]) + +# Determine the sigsetjmp symbol. If missing, then point to sigsetjmp_missing. +# +# Supported symbols: +# sigsetjmp POSIX, BSD libc (MacOS) +# __sigsetjmp glibc (Linux) +SIGSETJMP="sigsetjmp_missing" +for sigsetjmp_fn in sigsetjmp __sigsetjmp; do + AX_FC_CHECK_BIND_C([${sigsetjmp_fn}], [ + SIGSETJMP=${sigsetjmp_fn} + break + ]) +done +AC_DEFINE_UNQUOTED([SIGSETJMP_NAME], ["${SIGSETJMP}"]) + +# Validate the siglongjmp symbol +AX_FC_CHECK_BIND_C([siglongjmp], + [SIGLONGJMP="siglongjmp"], [SETJMP="siglongjmp_missing"] +) +AC_DEFINE_UNQUOTED([SIGLONGJMP_NAME], ["${SIGLONGJMP}"]) + + +# Verify the size of nonlocal jump buffer structs +# NOTE: This requires C compiler, but can it be done with a Fortran compiler? +AC_LANG_PUSH([C]) + +AX_MPI([], [AC_MSG_ERROR([Could not find MPI launcher.])]) +AC_SUBST([CC], [$MPICC]) + +AC_CHECK_SIZEOF([jmp_buf], [], [#include ]) +AC_CHECK_SIZEOF([sigjmp_buf], [], [#include ]) + +AC_LANG_POP([C]) + + +# Prepare output +AC_SUBST([CPPFLAGS]) +AC_CONFIG_FILES([Makefile:${srcdir}/ac/Makefile.in]) +AC_OUTPUT diff --git a/ac/deps/.gitignore b/ac/deps/.gitignore new file mode 100644 index 0000000000..8cfaa6ebcb --- /dev/null +++ b/ac/deps/.gitignore @@ -0,0 +1,5 @@ +/bin/ +/fms/ +/include/ +/lib/ +/mkmf/ diff --git a/ac/deps/Makefile b/ac/deps/Makefile new file mode 100644 index 0000000000..01431cef8c --- /dev/null +++ b/ac/deps/Makefile @@ -0,0 +1,81 @@ +SHELL = bash + +# Disable implicit rules +.SUFFIXES: + +# Disable implicit variables +MAKEFLAGS += -R + +# FMS framework +FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git +FMS_COMMIT ?= 2023.03 + + +# List of source files to link this Makefile's dependencies to model Makefiles +# Assumes a depth of two, and the following extensions: F90 inc c h +# (1): Root directory +SOURCE = \ + $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) + +FMS_SOURCE = $(call SOURCE,fms/src) + + +# If `true`, print logs if an error is encountered. +REPORT_ERROR_LOGS ?= + + +#--- +# Rules + +.PHONY: all +all: lib/libFMS.a + + +#--- +# FMS build + +# 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 + +fms/build/libFMS.a: fms/build/Makefile + $(MAKE) -C fms/build libFMS.a + +fms/build/Makefile: fms/build/Makefile.in fms/build/configure + cd $(@D) && { \ + ./configure --srcdir=../src \ + || { \ + 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 + +fms/build/configure: fms/build/configure.ac $(FMS_SOURCE) | fms/src + autoreconf fms/build + +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 + +fms/src: + git clone $(FMS_URL) $@ + git -C $@ checkout $(FMS_COMMIT) + +# Cleanup + +.PHONY: clean +clean: + rm -rf fms/build lib include + +.PHONY: distclean +distclean: clean + rm -rf fms diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in new file mode 100644 index 0000000000..e4617f1428 --- /dev/null +++ b/ac/deps/Makefile.fms.in @@ -0,0 +1,26 @@ +# Makefile template for FMS +# +# Compiler flags are configured by autoconf's configure script. +# +# Source code dependencies are configured by makedep and saved to Makefile.dep. + +CC = @CC@ +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 + +.PHONY: depend +depend: Makefile.dep +Makefile.dep: + $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e -x libFMS.a -s @srcdir@/test_fms @srcdir@ diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac new file mode 100644 index 0000000000..7d68daa3c7 --- /dev/null +++ b/ac/deps/configure.fms.ac @@ -0,0 +1,202 @@ +# Autoconf configuration +AC_PREREQ([2.63]) + +AC_INIT( + [FMS], + [ ], + [https://github.com/NOAA-GFDL/FMS/issues]) + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([fms/fms.F90]) +AC_CONFIG_MACRO_DIR([m4]) + + +# C configuration + +# Autoconf assumes that LDFLAGS can be passed to CFLAGS, even though this is +# not valid in some compilers. This can cause basic CC tests to fail. +# Since we do not link with CC, we can safely disable LDFLAGS for AC_PROG_CC. +FC_LDFLAGS="$LDFLAGS" +LDFLAGS="" + +# C compiler verification +AC_PROG_CC +AX_MPI +CC=$MPICC + + +# FMS configuration + +# Linux and macOS have a gettid system call, but it is not implemented in older +# glibc implementations. When unavailable, a native syscall is used. +# +# On Linux, this is defined in unistd.h as __NR_gettid, and FMS is hard-coded +# to use this value. In macOS, this is defined in sys/syscall.h as SYS_gettid, +# so we override this macro if __NR_gettid is unavailable. +AC_CHECK_FUNCS([gettid], [], [ + AC_MSG_CHECKING([if __NR_gettid must be redefined]) + AC_CACHE_VAL([ac_cv_cc_nr_gettid], [ + ac_cv_cc_nr_gettid='unknown' + for nr_gettid in __NR_gettid SYS_gettid; do + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([ +#include +#include + ], [syscall($nr_gettid)] + )], [ac_cv_cc_nr_gettid=$nr_gettid] + ) + AS_IF([test "$ac_cv_cc_nr_gettid" != unknown], [break]) + done + ]) + AS_CASE([ac_cv_cc_nr_gettid], + [__NR_gettid], [AC_MSG_RESULT([none needed])], + [AC_MSG_RESULT([$ac_cv_cc_nr_gettid])] + ) + AS_IF([test "$ac_cv_cc_nr_gettid" != unknown], [ + AS_IF([test "$ac_cv_cc_nr_gettid" != __NR_gettid], + [AC_DEFINE_UNQUOTED([__NR_gettid], [$ac_cv_cc_nr_gettid])] + )], [ + AC_MSG_ERROR(["Could not find the gettid syscall ID"]) + ]) +]) + + +# FMS 2019.01.03 uses __APPLE__ to disable Linux CPU affinity calls. +AC_CHECK_FUNCS([sched_getaffinity], [], [AC_DEFINE([__APPLE__])]) + +# Restore LDFLAGS +LDFLAGS="$FC_LDFLAGS" + + +# Standard Fortran configuration +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) +AC_PROG_FC + + +# Determine MPI compiler wrappers and override compilers +AX_MPI +AC_SUBST(FC, $MPIFC) +AC_SUBST(LD, $MPIFC) + + +# Module tests +AX_FC_CHECK_MODULE([mpi]) +AC_DEFINE([use_libMPI]) + + +# 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.]) + ]) +]) + +# FMS requires this macro to signal netCDF support. +AC_DEFINE([use_netCDF]) + + +# Enable Cray pointers +AX_FC_CRAY_POINTER + + +# Force 8-byte reals +AX_FC_REAL8 +AS_IF( + [test "$enable_real8" != no], + [FCFLAGS="$FCFLAGS $REAL8_FCFLAGS"]) + + +# OpenMP configuration + +# NOTE: AC_OPENMP fails in Autoconf <2.69 when LANG is Fortran or Fortran 77. +# For older versions, we test against CC and use the result for FC. +m4_version_prereq([2.69], [AC_OPENMP], [ + AC_LANG_PUSH([C]) + AC_OPENMP + AC_LANG_POP([C]) + OPENMP_FCFLAGS="$OPENMP_CFLAGS" +]) + +# NOTE: Only apply OpenMP flags if explicitly enabled. +AS_IF( + [test "$enable_openmp" = yes], [ + FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" + LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS" +]) + + +# Unlimited line length (2.67) +# AC_FC_LINE_LENGTH was added in 2.67. +m4_version_prereq([2.67], + [AC_FC_LINE_LENGTH([unlimited])], + [AX_FC_LINE_LENGTH([unlimited])] +) + + +# Allow invaliz BOZ assignment +AX_FC_ALLOW_INVALID_BOZ +FCFLAGS="$FCFLAGS $ALLOW_INVALID_BOZ_FCFLAGS" + + +# Allow argument mismatch (for functions lacking interfaces) +AX_FC_ALLOW_ARG_MISMATCH +FCFLAGS="$FCFLAGS $ALLOW_ARG_MISMATCH_FCFLAGS" + + +# Verify that Python is available +AC_PATH_PROGS([PYTHON], [python python3 python2], [ + AC_MSG_ERROR([Could not find python.]) +]) +AC_ARG_VAR([PYTHON], [Python interpreter command]) + + +# 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."]) +]) + + +# Autoconf does not configure the archiver (ar), as it is handled by Automake. +# TODO: Properly configure this tool. For now, we hard-set this to `ar`. +AR=ar +ARFLAGS=rv +AC_SUBST([AR]) +AC_SUBST([ARFLAGS]) + +AC_CONFIG_COMMANDS([Makefile.dep], [make depend]) + +AC_SUBST([CPPFLAGS]) + +# Prepare output +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 b/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 new file mode 100644 index 0000000000..cffa302c66 --- /dev/null +++ b/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 @@ -0,0 +1,58 @@ +dnl Test if mismatched function arguments are permitted. +dnl +dnl This macro tests if a flag is required to enable mismatched functions in +dnl a single translation unit (aka file). +dnl +dnl If a compiler encounters two undefined programs with different input +dnl argument types, then it may regard this as a mismatch which requires action +dnl from the user. A common example is a procedure which may be called with +dnl a variable of either an integer or a real type. +dnl +dnl This can happen, for example, if one is relying on an interface to resolve +dnl such differences, but one is also relying on a legacy header interface via +dnl `#include` rather than an explicit module which includes the complete +dnl interface specification. +dnl +dnl No modern project is expected to see these issues, but this is helpful for +dnl older projects which used legacy headers. +dnl +dnl Flags: +dnl GNU: -fallow-argument-mismatch +dnl +AC_DEFUN([AX_FC_ALLOW_ARG_MISMATCH], + [ALLOW_ARG_MISMATCH_FCFLAGS= + AC_CACHE_CHECK( + [for $FC option to support mismatched procedure arguments], + [ac_cv_prog_fc_arg_mismatch], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + call f(1) + call f(1.0) + ])], + [ac_cv_prog_fc_arg_mismatch='none needed'], + [ac_cv_prog_fc_arg_mismatch='unsupported' + for ac_option in -fallow-argument-mismatch; do + ac_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS $ac_option" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + call f(1) + call f(1.0) + ])], + [ac_cv_prog_fc_arg_mismatch=$ac_option] + ) + FCFLAGS=$ac_save_FCFLAGS + if test "$ac_cv_prog_fc_arg_mismatch" != unsupported; then + break + fi + done]) + ] + ) + case $ac_cv_prog_fc_arg_mismatch in #( + "none needed" | unsupported) + ;; #( + *) + ALLOW_ARG_MISMATCH_FCFLAGS=$ac_cv_prog_fc_arg_mismatch ;; + esac + AC_SUBST(ALLOW_ARG_MISMATCH_FCFLAGS) +]) diff --git a/ac/deps/m4/ax_fc_allow_invalid_boz.m4 b/ac/deps/m4/ax_fc_allow_invalid_boz.m4 new file mode 100644 index 0000000000..5d4521b5fb --- /dev/null +++ b/ac/deps/m4/ax_fc_allow_invalid_boz.m4 @@ -0,0 +1,54 @@ +dnl Test if BOZ literal assignment is supported. +dnl +dnl This macro tests if a flag is required to enable BOZ literal assignments +dnl for variables. +dnl +dnl BOZ literals (e.g. Z'FFFF') are typeless, and formally cannot be assigned +dnl to typed variables. Nonetheless, few compilers forbid such operations, +dnl despite the potential pitfalls around interpreting such values. +dnl +dnl As of version 10.1, gfortran now forbids such assignments and requires a +dnl flag to convert the raised errors into warnings. +dnl +dnl While the best solution is to replace such assignments with proper +dnl conversion functions, this test is useful to accommodate older projects. +dnl +dnl Flags: +dnl GNU: -fallow-invalid-boz +AC_DEFUN([AX_FC_ALLOW_INVALID_BOZ], + [ALLOW_INVALID_BOZ_FCFLAGS= + AC_CACHE_CHECK( + [for $FC option to support invalid BOZ assignment], + [ac_cv_prog_fc_invalid_boz], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + integer n + n = z'ff' + ])], + [ac_cv_prog_fc_invalid_boz='none needed'], + [ac_cv_prog_fc_invalid_boz='unsupported' + for ac_option in -fallow-invalid-boz; do + ac_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS $ac_option" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([], [ + integer n + n = z'ff' + ])], + [ac_cv_prog_fc_invalid_boz=$ac_option] + ) + FCFLAGS=$ac_save_FCFLAGS + if test "$ac_cv_prog_fc_invalid_boz" != unsupported; then + break + fi + done]) + ] + ) + case $ac_cv_prog_fc_invalid_boz in #( + "none needed" | unsupported) + ;; #( + *) + ALLOW_INVALID_BOZ_FCFLAGS=$ac_cv_prog_fc_invalid_boz ;; + esac + AC_SUBST(ALLOW_INVALID_BOZ_FCFLAGS)] +) diff --git a/ac/deps/m4/ax_fc_check_c_lib.m4 b/ac/deps/m4/ax_fc_check_c_lib.m4 new file mode 100644 index 0000000000..af5765282a --- /dev/null +++ b/ac/deps/m4/ax_fc_check_c_lib.m4 @@ -0,0 +1,45 @@ +dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C library can be referenced by a Fortran compiler. +dnl +dnl Results are cached in `ax_fc_cv_c_lib_LIBRARY_FUNCTION`. +dnl +dnl NOTE: Might be possible to rewrite this to use `AX_FC_CHECK_BIND_C`. +dnl +AC_DEFUN([AX_FC_CHECK_C_LIB], [ + AS_VAR_PUSHDEF([ax_fc_C_Lib], [ax_fc_cv_c_lib_$1_$2]) + m4_ifval([$5], + [ax_fc_c_lib_msg_LDFLAGS=" with $5"], + [ax_fc_c_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$ax_fc_c_lib_msg_LDFLAGS], [ax_fc_cv_c_lib_$1_$2], [ + ax_fc_check_c_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_c_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$2") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_C_Lib], [yes])], + [AS_VAR_SET([ax_fc_C_Lib], [no])] + ) + LDFLAGS=$ax_fc_check_c_lib_save_LDFLAGS + LIBS=$ax_fc_check_c_lib_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_C_Lib], [yes], + [m4_default([$3], [LIBS="-l$1 $LIBS"])], + [$4] + ) + AS_VAR_POPDEF([ax_fc_C_Lib]) +]) diff --git a/ac/deps/m4/ax_fc_check_lib.m4 b/ac/deps/m4/ax_fc_check_lib.m4 new file mode 100644 index 0000000000..a7f848cd60 --- /dev/null +++ b/ac/deps/m4/ax_fc_check_lib.m4 @@ -0,0 +1,53 @@ +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/deps/m4/ax_fc_check_module.m4 b/ac/deps/m4/ax_fc_check_module.m4 new file mode 100644 index 0000000000..1cfd0c5a5d --- /dev/null +++ b/ac/deps/m4/ax_fc_check_module.m4 @@ -0,0 +1,28 @@ +dnl AX_FC_CHECK_MODULE(MODULE, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-FCFLAGS]) +dnl +dnl This macro checks if a Fortran module is available to the compiler. +dnl +dnl The fourth argument (optional) allows for specification of supplemental +dnl FCFLAGS arguments. This would primarily be used to test additional +dnl paths (typically using -I) for the module file. +dnl +dnl Results are cached in the ax_fc_cv_mod_MODULE variable. +dnl +AC_DEFUN([AX_FC_CHECK_MODULE], +[ + AS_VAR_PUSHDEF([ax_fc_Module], [ax_fc_cv_mod_$1]) + AC_CACHE_CHECK([if $FC can use module $1$ax_fc_mod_msg_FCFLAGS], [ax_fc_cv_mod_$1],[ + ax_fc_chk_mod_save_FCFLAGS=$FCFLAGS + FCFLAGS="$4 $FCFLAGS" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([],[use $1])], + [AS_VAR_SET([ax_fc_Module], [yes])], + [AS_VAR_SET([ax_fc_Module], [no])] + ) + FCFLAGS=$ax_fc_chk_mod_save_FCFLAGS + ]) + AS_VAR_IF([ax_fc_Module], [yes], [$2], [$3]) + AS_VAR_POPDEF([ax_fc_Module]) +]) diff --git a/ac/deps/m4/ax_fc_cray_pointer.m4 b/ac/deps/m4/ax_fc_cray_pointer.m4 new file mode 100644 index 0000000000..57ed186afa --- /dev/null +++ b/ac/deps/m4/ax_fc_cray_pointer.m4 @@ -0,0 +1,51 @@ +dnl AX_FC_CRAY_POINTER([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE]) +dnl +dnl This macro tests if any flags are required to enable Cray pointers. +dnl +dnl Cray pointers provided a means for more direct access to memory. Since +dnl such references can potentially violate certain requirements of the +dnl language standard, they are typically considered a vendor extension. +dnl +dnl Most compilers provide these in some form. A partial list of supported +dnl flags are shown below, but additional feedback is required for other +dnl compilers. +dnl +dnl The known flags are: +dnl GCC -fcray-pointer +dnl Intel Fortran none +dnl PGI Fortran -Mcray=pointer +dnl Cray Fortran none +dnl +AC_DEFUN([AX_FC_CRAY_POINTER], [ + AC_LANG_ASSERT([Fortran]) + AC_MSG_CHECKING([for $FC option to support Cray pointers]) + AC_CACHE_VAL([ac_cv_fc_cray_ptr], [ + ac_cv_fc_cray_ptr='unknown' + ac_save_FCFLAGS=$FCFLAGS + for ac_option in none -fcray-pointer -Mcray=pointer; do + test "$ac_option" != none && FCFLAGS="$ac_save_FCFLAGS $ac_option" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + integer aptr(2) + pointer (iptr, aptr) + ])], + [ac_cv_fc_cray_ptr=$ac_option], + ) + FCFLAGS=$ac_save_FCFLAGS + AS_IF([test "$ac_cv_fc_cray_ptr" != unknown], [break]) + done + ]) + AS_CASE([ac_cv_fc_cray_ptr], + [none], [AC_MSG_RESULT([none_needed])], + [unknown], [AC_MSG_RESULT([unsupported])], + [AC_MSG_RESULT([$ac_cv_fc_cray_ptr])] + ) + AS_IF([test "$ac_cv_fc_cray_ptr" != unknown], [ + m4_default([$1], [ + AS_IF([test "$ac_cv_fc_cray_ptr" != none], + [FCFLAGS="$FCFLAGS $ac_cv_fc_cray_ptr"] + ) + ])], + [m4_default([$2], [AC_MSG_ERROR(["$FC does not support Cray pointers"])])] + ) +]) diff --git a/ac/deps/m4/ax_fc_line_length.m4 b/ac/deps/m4/ax_fc_line_length.m4 new file mode 100644 index 0000000000..97271da1f6 --- /dev/null +++ b/ac/deps/m4/ax_fc_line_length.m4 @@ -0,0 +1,101 @@ +# AX_FC_LINE_LENGTH([LENGTH], [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ------------------------------------------------ +# This is a backport of the AC_FC_LINE_LENGTH macro in Autoconf 2.67 and newer. +# Comments below are from the Autoconf 2.69 implementation. +# +# Look for a compiler flag to make the Fortran (FC) compiler accept long lines +# in the current (free- or fixed-format) source code, and adds it to FCFLAGS. +# The optional LENGTH may be 80, 132 (default), or `unlimited' for longer +# lines. Note that line lengths above 250 columns are not portable, and some +# compilers (hello ifort) do not accept more than 132 columns at least for +# fixed format. Call ACTION-IF-SUCCESS (defaults to nothing) if successful +# (i.e. can compile code using new extension) and ACTION-IF-FAILURE (defaults +# to failing with an error message) if not. (Defined via DEFUN_ONCE to +# prevent flag from being added to FCFLAGS multiple times.) +# You should call AC_FC_FREEFORM or AC_FC_FIXEDFORM to set the desired format +# prior to using this macro. +# +# The known flags are: +# -f{free,fixed}-line-length-N with N 72, 80, 132, or 0 or none for none. +# -ffree-line-length-none: GNU gfortran +# -ffree-line-length-huge: g95 (also -ffixed-line-length-N as above) +# -qfixed=132 80 72: IBM compiler (xlf) +# -Mextend: Cray +# -132 -80 -72: Intel compiler (ifort) +# Needs to come before -extend_source because ifort +# accepts that as well with an optional parameter and +# doesn't fail but only warns about unknown arguments. +# -extend_source: SGI compiler +# -W, -WNN (132, 80, 72): Absoft Fortran +# +es, +extend_source: HP Fortran (254 in either form, default is 72 fixed, +# 132 free) +# -w, (-)-wide: Lahey/Fujitsu Fortran (255 cols in fixed form) +# -e: Sun Fortran compiler (132 characters) +# -132: NAGWare +# -72, -f, -Wf,-f: f2c (a weak form of "free-form" and long lines). +# /XLine: Open Watcom + +AC_DEFUN_ONCE([AX_FC_LINE_LENGTH], [ + AC_LANG_ASSERT([Fortran]) + m4_case(m4_default([$1], [132]), + [unlimited], [ + ac_fc_line_len_string=unlimited + ac_fc_line_len=0 + ac_fc_line_length_test=' + subroutine longer_than_132(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,'\ +'arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,arg17,arg18,arg19)' + ], + [132], [ + ac_fc_line_len=132 + ac_fc_line_length_test=' + subroutine longer_than_80(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,'\ +'arg10)' + ], + [80], [ + ac_fc_line_len=80 + ac_fc_line_length_test=' + subroutine longer_than_72(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9)' + ], + [m4_warning([Invalid length argument `$1'])] + ) + : ${ac_fc_line_len_string=$ac_fc_line_len} + AC_MSG_CHECKING([for Fortran flag needed to accept $ac_fc_line_len_string column source lines]) + AC_CACHE_VAL([ac_cv_fc_line_length], [ + ac_cv_fc_line_length=unknown + ac_save_FCFLAGS=$FCFLAGS + for ac_flag in none \ + -ffree-line-length-none \ + -ffixed-line-length-none \ + -ffree-line-length-huge \ + -ffree-line-length-$ac_fc_line_len \ + -ffixed-line-length-$ac_fc_line_len \ + -qfixed=$ac_fc_line_len \ + -Mextend \ + -$ac_fc_line_len \ + -extend_source \ + -W$ac_fc_line_len \ + -W +extend_source +es -wide --wide -w -e -f -Wf,-f -xline + do + test "$ac_flag" != none && FCFLAGS="$ac_save_FCFLAGS $ac_flag" + AC_COMPILE_IFELSE([$ac_fc_line_length_test + end subroutine + ], [ac_cv_fc_line_length=$ac_flag] + ) + FCFLAGS=$ac_save_FCFLAGS + dnl TODO: Remove conftest.{err,$ac_objext,$ac_ext} ?? + AS_IF([test "$ac_cv_fc_line_length" != unknown], [break]) + done + ]) + AC_MSG_RESULT([$ac_cv_fc_line_length]) + AS_IF([test "$ac_cv_fc_line_length" != unknown], [ + m4_default([$2], [ + AS_IF([test "$ac_cv_fc_line_length" != none], [ + FCFLAGS="$FCFLAGS $ac_cv_fc_line_length" + ]) + ])], [ + m4_default([$3], [ + AC_MSG_ERROR([Fortran does not accept long source lines], 77) + ]) + ]) +]) diff --git a/ac/deps/m4/ax_fc_real8.m4 b/ac/deps/m4/ax_fc_real8.m4 new file mode 100644 index 0000000000..e914b9f39a --- /dev/null +++ b/ac/deps/m4/ax_fc_real8.m4 @@ -0,0 +1,86 @@ +dnl Determine the flag required to force 64-bit reals. +dnl +dnl Many applications do not specify the kind of its real variables, even +dnl though the code may intrinsically require double-precision. Most compilers +dnl will also default to using single-precision (32-bit) reals. +dnl +dnl This test determines the flag required to set reals without explcit kind to +dnl 64-bit double precision floats. Ideally, we also desire to leave any +dnl `DOUBLE PRECISION` variable as 64-bit. But this does not appear to always +dnl be possible, such as in NAG Fortran (see below). +dnl +dnl This does not test if the behavior of integers is changed; for example, +dnl Cray's Fortran wrapper's -default will double both. This is addressed by +dnl avoiding any flags with affect integers, but this should still be used with +dnl some care. +dnl +dnl GCC -fdefault-real-8, -fdefault-double-8 +dnl [Common alias] -r8 +dnl Intel Fortran -real-kind 64 +dnl PGI Fortran -Mr8 +dnl Cray Fortran -s real64 +dnl NAG -double +dnl +dnl NOTE: +dnl - Many compilers accept -r8 for real and double precision sizes, but +dnl several compiler-specific options are also provided. +dnl +dnl - -r8 in NAG will attempt to also set double precision to 16 bytes if +dnl available, which is generally undesired. +dnl +dnl Additionally, the -double flag, which doubles *all* types, appears to +dnl be the preferred flag here. +dnl +dnl Neither flag describes what we actually want, but we include it here +dnl as a last resort. +dnl +AC_DEFUN([AX_FC_REAL8], +[ + REAL8_FCFLAGS= + AC_ARG_ENABLE([real8], + [AS_HELP_STRING([--disable-real-8], [do not force 8-byte reals])]) + if test "$enable_real8" != no; then + AC_CACHE_CHECK([for $FC option to force 8-byte reals], + [ac_cv_prog_fc_real8], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + real :: x(4) + double precision :: y(4) + integer, parameter :: & + m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & + n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) + print *, x(::m) + print *, y(::n) + ])], + [ac_cv_prog_fc_real8='none needed'], + [ac_cv_prog_fc_real8='unsupported' + for ac_option in "-fdefault-real-8 -fdefault-double-8" -r8 "-real-kind 64" -Mr8 "-s real64" -double; do + ac_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS $ac_option" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([], [ + real :: x(4) + double precision :: y(4) + integer, parameter :: & + m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & + n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) + print *, x(::m) + print *, y(::n) + ])], + [ac_cv_prog_fc_real8=$ac_option] + ) + FCFLAGS=$ac_save_FCFLAGS + if test "$ac_cv_prog_fc_real8" != unsupported; then + break + fi + done]) + ]) + case $ac_cv_prog_fc_real8 in #( + "none needed" | unsupported) + ;; #( + *) + REAL8_FCFLAGS=$ac_cv_prog_fc_real8 ;; + esac + fi + AC_SUBST(REAL8_FCFLAGS) +]) diff --git a/ac/deps/m4/ax_mpi.m4 b/ac/deps/m4/ax_mpi.m4 new file mode 100644 index 0000000000..3d9966a19d --- /dev/null +++ b/ac/deps/m4/ax_mpi.m4 @@ -0,0 +1,176 @@ +# =========================================================================== +# https://www.gnu.org/software/autoconf-archive/ax_mpi.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_MPI([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) +# +# DESCRIPTION +# +# This macro tries to find out how to compile programs that use MPI +# (Message Passing Interface), a standard API for parallel process +# communication (see http://www-unix.mcs.anl.gov/mpi/) +# +# On success, it sets the MPICC, MPICXX, MPIF77, or MPIFC output variable +# to the name of the MPI compiler, depending upon the current language. +# (This may just be $CC/$CXX/$F77/$FC, but is more often something like +# mpicc/mpiCC/mpif77/mpif90.) It also sets MPILIBS to any libraries that +# are needed for linking MPI (e.g. -lmpi or -lfmpi, if a special +# MPICC/MPICXX/MPIF77/MPIFC was not found). +# +# Note that this macro should be used only if you just have a few source +# files that need to be compiled using MPI. In particular, you should +# neither overwrite CC/CXX/F77/FC with the values of +# MPICC/MPICXX/MPIF77/MPIFC, nor assume that you can use the same flags +# etc. as the standard compilers. If you want to compile a whole program +# using the MPI compiler commands, use one of the macros +# AX_PROG_{CC,CXX,FC}_MPI. +# +# ACTION-IF-FOUND is a list of shell commands to run if an MPI library is +# found, and ACTION-IF-NOT-FOUND is a list of commands to run if it is not +# found. If ACTION-IF-FOUND is not specified, the default action will +# define HAVE_MPI. +# +# LICENSE +# +# Copyright (c) 2008 Steven G. Johnson +# Copyright (c) 2008 Julian C. Cummings +# +# This program is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the +# Free Software Foundation, either version 3 of the License, or (at your +# option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General +# Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program. If not, see . +# +# As a special exception, the respective Autoconf Macro's copyright owner +# gives unlimited permission to copy, distribute and modify the configure +# scripts that are the output of Autoconf when processing the Macro. You +# need not follow the terms of the GNU General Public License when using +# or distributing such scripts, even though portions of the text of the +# Macro appear in them. The GNU General Public License (GPL) does govern +# all other use of the material that constitutes the Autoconf Macro. +# +# This special exception to the GPL applies to versions of the Autoconf +# Macro released by the Autoconf Archive. When you make and distribute a +# modified version of the Autoconf Macro, you may extend this special +# exception to the GPL to apply to your modified version as well. + +#serial 9 + +AU_ALIAS([ACX_MPI], [AX_MPI]) +AC_DEFUN([AX_MPI], [ +AC_PREREQ([2.50]) dnl for AC_LANG_CASE + +AC_LANG_CASE([C], [ + AC_REQUIRE([AC_PROG_CC]) + AC_ARG_VAR(MPICC,[MPI C compiler command]) + AC_CHECK_PROGS(MPICC, mpicc cc hcc mpxlc_r mpxlc mpcc cmpicc, $CC) + ax_mpi_save_CC="$CC" + CC="$MPICC" + AC_SUBST(MPICC) +], +[C++], [ + AC_REQUIRE([AC_PROG_CXX]) + AC_ARG_VAR(MPICXX,[MPI C++ compiler command]) + AC_CHECK_PROGS(MPICXX, mpic++ mpicxx mpiCC hcp mpxlC_r mpxlC mpCC cmpic++, $CXX) + ax_mpi_save_CXX="$CXX" + CXX="$MPICXX" + AC_SUBST(MPICXX) +], +[Fortran 77], [ + AC_REQUIRE([AC_PROG_F77]) + AC_ARG_VAR(MPIF77,[MPI Fortran 77 compiler command]) + AC_CHECK_PROGS(MPIF77, mpif77 hf77 mpxlf_r mpxlf mpf77 cmpifc, $F77) + ax_mpi_save_F77="$F77" + F77="$MPIF77" + AC_SUBST(MPIF77) +], +[Fortran], [ + AC_REQUIRE([AC_PROG_FC]) + AC_ARG_VAR(MPIFC,[MPI Fortran compiler command]) + AC_CHECK_PROGS(MPIFC, mpifort mpif90 ftn mpxlf95_r mpxlf90_r mpxlf95 mpxlf90 mpf90 cmpif90c, $FC) + ax_mpi_save_FC="$FC" + FC="$MPIFC" + AC_SUBST(MPIFC) +]) + +if test x = x"$MPILIBS"; then + AC_LANG_CASE([C], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [C++], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [Fortran 77], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])], + [Fortran], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])]) +fi +AC_LANG_CASE([Fortran 77], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpich, MPI_Init, [MPILIBS="-lfmpich"]) + fi +], +[Fortran], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpichf90, MPI_Init, [MPILIBS="-lmpichf90"]) + fi +]) +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpi, MPI_Init, [MPILIBS="-lmpi"]) +fi +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) +fi + +dnl We have to use AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[],[]) and not AC_CHECK_HEADER because the +dnl latter uses $CPP, not $CC (which may be mpicc). +AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[]])],[AC_MSG_RESULT(yes)],[MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[C++], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[]])],[AC_MSG_RESULT(yes)],[MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran 77], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi]) + +AC_LANG_CASE([C], [CC="$ax_mpi_save_CC"], + [C++], [CXX="$ax_mpi_save_CXX"], + [Fortran 77], [F77="$ax_mpi_save_F77"], + [Fortran], [FC="$ax_mpi_save_FC"]) + +AC_SUBST(MPILIBS) + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x = x"$MPILIBS"; then + $2 + : +else + ifelse([$1],,[AC_DEFINE(HAVE_MPI,1,[Define if you have the MPI library.])],[$1]) + : +fi +])dnl AX_MPI diff --git a/ac/m4/ax_fc_check_bind_c.m4 b/ac/m4/ax_fc_check_bind_c.m4 new file mode 100644 index 0000000000..9b9f821d4c --- /dev/null +++ b/ac/m4/ax_fc_check_bind_c.m4 @@ -0,0 +1,42 @@ +dnl AX_FC_CHECK_C_LIB(FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C binding is available to the compiler. +dnl +dnl Equivalently, it checks if the Fortran compiler can see a C function. +dnl +dnl Results are cached in `ax_fc_cv_bind_c_FUNCTION`. +dnl +AC_DEFUN([AX_FC_CHECK_BIND_C], [ + AS_VAR_PUSHDEF([ax_fc_Bind_C], [ax_fc_cv_bind_c_$1]) + m4_ifval([$4], + [ax_fc_bind_c_msg_LDFLAGS=" with $4"], + [ax_fc_bind_c_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [if $FC can bind $1$ax_fc_bind_c_msg_LDFLAGS], [ax_fc_cv_bind_c_$1], [ + ax_fc_check_bind_c_save_LDFLAGS=$LDFLAGS + LDFLAGS="$4 $LDFLAGS" + ax_fc_check_bind_c_save_LIBS=$LIBS + LIBS="$5 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$1") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_Bind_C], [yes])], + [AS_VAR_SET([ax_fc_Bind_C], [no])] + ) + LDFLAGS=$ax_fc_check_bind_c_save_LDFLAGS + LIBS=$ax_fc_check_bind_c_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_Bind_C], [yes], [$2], [$3]) + AS_VAR_POPDEF([ax_fc_Bind_C]) +]) diff --git a/ac/m4/ax_fc_check_c_lib.m4 b/ac/m4/ax_fc_check_c_lib.m4 new file mode 100644 index 0000000000..af5765282a --- /dev/null +++ b/ac/m4/ax_fc_check_c_lib.m4 @@ -0,0 +1,45 @@ +dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C library can be referenced by a Fortran compiler. +dnl +dnl Results are cached in `ax_fc_cv_c_lib_LIBRARY_FUNCTION`. +dnl +dnl NOTE: Might be possible to rewrite this to use `AX_FC_CHECK_BIND_C`. +dnl +AC_DEFUN([AX_FC_CHECK_C_LIB], [ + AS_VAR_PUSHDEF([ax_fc_C_Lib], [ax_fc_cv_c_lib_$1_$2]) + m4_ifval([$5], + [ax_fc_c_lib_msg_LDFLAGS=" with $5"], + [ax_fc_c_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$ax_fc_c_lib_msg_LDFLAGS], [ax_fc_cv_c_lib_$1_$2], [ + ax_fc_check_c_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_c_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$2") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_C_Lib], [yes])], + [AS_VAR_SET([ax_fc_C_Lib], [no])] + ) + LDFLAGS=$ax_fc_check_c_lib_save_LDFLAGS + LIBS=$ax_fc_check_c_lib_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_C_Lib], [yes], + [m4_default([$3], [LIBS="-l$1 $LIBS"])], + [$4] + ) + AS_VAR_POPDEF([ax_fc_C_Lib]) +]) diff --git a/ac/m4/ax_fc_check_lib.m4 b/ac/m4/ax_fc_check_lib.m4 new file mode 100644 index 0000000000..a7f848cd60 --- /dev/null +++ b/ac/m4/ax_fc_check_lib.m4 @@ -0,0 +1,53 @@ +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/ax_fc_check_module.m4 b/ac/m4/ax_fc_check_module.m4 new file mode 100644 index 0000000000..1cfd0c5a5d --- /dev/null +++ b/ac/m4/ax_fc_check_module.m4 @@ -0,0 +1,28 @@ +dnl AX_FC_CHECK_MODULE(MODULE, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-FCFLAGS]) +dnl +dnl This macro checks if a Fortran module is available to the compiler. +dnl +dnl The fourth argument (optional) allows for specification of supplemental +dnl FCFLAGS arguments. This would primarily be used to test additional +dnl paths (typically using -I) for the module file. +dnl +dnl Results are cached in the ax_fc_cv_mod_MODULE variable. +dnl +AC_DEFUN([AX_FC_CHECK_MODULE], +[ + AS_VAR_PUSHDEF([ax_fc_Module], [ax_fc_cv_mod_$1]) + AC_CACHE_CHECK([if $FC can use module $1$ax_fc_mod_msg_FCFLAGS], [ax_fc_cv_mod_$1],[ + ax_fc_chk_mod_save_FCFLAGS=$FCFLAGS + FCFLAGS="$4 $FCFLAGS" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([],[use $1])], + [AS_VAR_SET([ax_fc_Module], [yes])], + [AS_VAR_SET([ax_fc_Module], [no])] + ) + FCFLAGS=$ax_fc_chk_mod_save_FCFLAGS + ]) + AS_VAR_IF([ax_fc_Module], [yes], [$2], [$3]) + AS_VAR_POPDEF([ax_fc_Module]) +]) diff --git a/ac/m4/ax_fc_real8.m4 b/ac/m4/ax_fc_real8.m4 new file mode 100644 index 0000000000..e914b9f39a --- /dev/null +++ b/ac/m4/ax_fc_real8.m4 @@ -0,0 +1,86 @@ +dnl Determine the flag required to force 64-bit reals. +dnl +dnl Many applications do not specify the kind of its real variables, even +dnl though the code may intrinsically require double-precision. Most compilers +dnl will also default to using single-precision (32-bit) reals. +dnl +dnl This test determines the flag required to set reals without explcit kind to +dnl 64-bit double precision floats. Ideally, we also desire to leave any +dnl `DOUBLE PRECISION` variable as 64-bit. But this does not appear to always +dnl be possible, such as in NAG Fortran (see below). +dnl +dnl This does not test if the behavior of integers is changed; for example, +dnl Cray's Fortran wrapper's -default will double both. This is addressed by +dnl avoiding any flags with affect integers, but this should still be used with +dnl some care. +dnl +dnl GCC -fdefault-real-8, -fdefault-double-8 +dnl [Common alias] -r8 +dnl Intel Fortran -real-kind 64 +dnl PGI Fortran -Mr8 +dnl Cray Fortran -s real64 +dnl NAG -double +dnl +dnl NOTE: +dnl - Many compilers accept -r8 for real and double precision sizes, but +dnl several compiler-specific options are also provided. +dnl +dnl - -r8 in NAG will attempt to also set double precision to 16 bytes if +dnl available, which is generally undesired. +dnl +dnl Additionally, the -double flag, which doubles *all* types, appears to +dnl be the preferred flag here. +dnl +dnl Neither flag describes what we actually want, but we include it here +dnl as a last resort. +dnl +AC_DEFUN([AX_FC_REAL8], +[ + REAL8_FCFLAGS= + AC_ARG_ENABLE([real8], + [AS_HELP_STRING([--disable-real-8], [do not force 8-byte reals])]) + if test "$enable_real8" != no; then + AC_CACHE_CHECK([for $FC option to force 8-byte reals], + [ac_cv_prog_fc_real8], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + real :: x(4) + double precision :: y(4) + integer, parameter :: & + m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & + n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) + print *, x(::m) + print *, y(::n) + ])], + [ac_cv_prog_fc_real8='none needed'], + [ac_cv_prog_fc_real8='unsupported' + for ac_option in "-fdefault-real-8 -fdefault-double-8" -r8 "-real-kind 64" -Mr8 "-s real64" -double; do + ac_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS $ac_option" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([], [ + real :: x(4) + double precision :: y(4) + integer, parameter :: & + m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & + n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) + print *, x(::m) + print *, y(::n) + ])], + [ac_cv_prog_fc_real8=$ac_option] + ) + FCFLAGS=$ac_save_FCFLAGS + if test "$ac_cv_prog_fc_real8" != unsupported; then + break + fi + done]) + ]) + case $ac_cv_prog_fc_real8 in #( + "none needed" | unsupported) + ;; #( + *) + REAL8_FCFLAGS=$ac_cv_prog_fc_real8 ;; + esac + fi + AC_SUBST(REAL8_FCFLAGS) +]) diff --git a/ac/m4/ax_mpi.m4 b/ac/m4/ax_mpi.m4 new file mode 100644 index 0000000000..3d9966a19d --- /dev/null +++ b/ac/m4/ax_mpi.m4 @@ -0,0 +1,176 @@ +# =========================================================================== +# https://www.gnu.org/software/autoconf-archive/ax_mpi.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_MPI([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) +# +# DESCRIPTION +# +# This macro tries to find out how to compile programs that use MPI +# (Message Passing Interface), a standard API for parallel process +# communication (see http://www-unix.mcs.anl.gov/mpi/) +# +# On success, it sets the MPICC, MPICXX, MPIF77, or MPIFC output variable +# to the name of the MPI compiler, depending upon the current language. +# (This may just be $CC/$CXX/$F77/$FC, but is more often something like +# mpicc/mpiCC/mpif77/mpif90.) It also sets MPILIBS to any libraries that +# are needed for linking MPI (e.g. -lmpi or -lfmpi, if a special +# MPICC/MPICXX/MPIF77/MPIFC was not found). +# +# Note that this macro should be used only if you just have a few source +# files that need to be compiled using MPI. In particular, you should +# neither overwrite CC/CXX/F77/FC with the values of +# MPICC/MPICXX/MPIF77/MPIFC, nor assume that you can use the same flags +# etc. as the standard compilers. If you want to compile a whole program +# using the MPI compiler commands, use one of the macros +# AX_PROG_{CC,CXX,FC}_MPI. +# +# ACTION-IF-FOUND is a list of shell commands to run if an MPI library is +# found, and ACTION-IF-NOT-FOUND is a list of commands to run if it is not +# found. If ACTION-IF-FOUND is not specified, the default action will +# define HAVE_MPI. +# +# LICENSE +# +# Copyright (c) 2008 Steven G. Johnson +# Copyright (c) 2008 Julian C. Cummings +# +# This program is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the +# Free Software Foundation, either version 3 of the License, or (at your +# option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General +# Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program. If not, see . +# +# As a special exception, the respective Autoconf Macro's copyright owner +# gives unlimited permission to copy, distribute and modify the configure +# scripts that are the output of Autoconf when processing the Macro. You +# need not follow the terms of the GNU General Public License when using +# or distributing such scripts, even though portions of the text of the +# Macro appear in them. The GNU General Public License (GPL) does govern +# all other use of the material that constitutes the Autoconf Macro. +# +# This special exception to the GPL applies to versions of the Autoconf +# Macro released by the Autoconf Archive. When you make and distribute a +# modified version of the Autoconf Macro, you may extend this special +# exception to the GPL to apply to your modified version as well. + +#serial 9 + +AU_ALIAS([ACX_MPI], [AX_MPI]) +AC_DEFUN([AX_MPI], [ +AC_PREREQ([2.50]) dnl for AC_LANG_CASE + +AC_LANG_CASE([C], [ + AC_REQUIRE([AC_PROG_CC]) + AC_ARG_VAR(MPICC,[MPI C compiler command]) + AC_CHECK_PROGS(MPICC, mpicc cc hcc mpxlc_r mpxlc mpcc cmpicc, $CC) + ax_mpi_save_CC="$CC" + CC="$MPICC" + AC_SUBST(MPICC) +], +[C++], [ + AC_REQUIRE([AC_PROG_CXX]) + AC_ARG_VAR(MPICXX,[MPI C++ compiler command]) + AC_CHECK_PROGS(MPICXX, mpic++ mpicxx mpiCC hcp mpxlC_r mpxlC mpCC cmpic++, $CXX) + ax_mpi_save_CXX="$CXX" + CXX="$MPICXX" + AC_SUBST(MPICXX) +], +[Fortran 77], [ + AC_REQUIRE([AC_PROG_F77]) + AC_ARG_VAR(MPIF77,[MPI Fortran 77 compiler command]) + AC_CHECK_PROGS(MPIF77, mpif77 hf77 mpxlf_r mpxlf mpf77 cmpifc, $F77) + ax_mpi_save_F77="$F77" + F77="$MPIF77" + AC_SUBST(MPIF77) +], +[Fortran], [ + AC_REQUIRE([AC_PROG_FC]) + AC_ARG_VAR(MPIFC,[MPI Fortran compiler command]) + AC_CHECK_PROGS(MPIFC, mpifort mpif90 ftn mpxlf95_r mpxlf90_r mpxlf95 mpxlf90 mpf90 cmpif90c, $FC) + ax_mpi_save_FC="$FC" + FC="$MPIFC" + AC_SUBST(MPIFC) +]) + +if test x = x"$MPILIBS"; then + AC_LANG_CASE([C], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [C++], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [Fortran 77], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])], + [Fortran], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])]) +fi +AC_LANG_CASE([Fortran 77], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpich, MPI_Init, [MPILIBS="-lfmpich"]) + fi +], +[Fortran], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpichf90, MPI_Init, [MPILIBS="-lmpichf90"]) + fi +]) +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpi, MPI_Init, [MPILIBS="-lmpi"]) +fi +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) +fi + +dnl We have to use AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[],[]) and not AC_CHECK_HEADER because the +dnl latter uses $CPP, not $CC (which may be mpicc). +AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[]])],[AC_MSG_RESULT(yes)],[MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[C++], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[]])],[AC_MSG_RESULT(yes)],[MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran 77], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi]) + +AC_LANG_CASE([C], [CC="$ax_mpi_save_CC"], + [C++], [CXX="$ax_mpi_save_CXX"], + [Fortran 77], [F77="$ax_mpi_save_F77"], + [Fortran], [FC="$ax_mpi_save_FC"]) + +AC_SUBST(MPILIBS) + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x = x"$MPILIBS"; then + $2 + : +else + ifelse([$1],,[AC_DEFINE(HAVE_MPI,1,[Define if you have the MPI library.])],[$1]) + : +fi +])dnl AX_MPI diff --git a/ac/makedep b/ac/makedep new file mode 100755 index 0000000000..e0d350857e --- /dev/null +++ b/ac/makedep @@ -0,0 +1,669 @@ +#!/usr/bin/env python + +from __future__ import print_function + +import argparse +import glob +import io +import os +import re +import sys + + +# Fortran tokenization + +re_module = re.compile(r"^ *module +([a-z_0-9]+)") +re_use = re.compile(r"^ *use +([a-z_0-9]+)") +re_cpp_define = re.compile(r"^ *# *define +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_undef = re.compile(r"^ *# *undef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_ifdef = re.compile(r"^ *# *ifdef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_ifndef = re.compile(r"^ *# *ifndef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_if = re.compile(r"^ *# *if +") +re_cpp_else = re.compile(r"^ *# *else") +re_cpp_endif = re.compile(r"^ *# *endif") +re_cpp_include = re.compile(r"^ *# *include *[<\"']([a-zA-Z_0-9\.]+)[>\"']") +re_f90_include = re.compile(r"^ *include +[\"']([a-zA-Z_0-9\.]+)[\"']") +re_program = re.compile(r"^ *program +([a-z_0-9]+)", re.IGNORECASE) +re_end = re.compile(r"^ *end *(module|procedure) ", re.IGNORECASE) +# NOTE: This excludes comments and tokens with substrings containing `function` +# or `subroutine`, but will fail if the keywords appear in other contexts. +re_procedure = re.compile( + r"^[^!]*(?>', lambda scanner, token: token), + (r'>=', lambda scanner, token: token), + (r'>', lambda scanner, token: token), + (r'<<', lambda scanner, token: token), + (r'<=', lambda scanner, token: token), + (r'<', lambda scanner, token: token), + (r'==', lambda scanner, token: token), + (r'&&', lambda scanner, token: token), + (r'&', lambda scanner, token: token), + (r'\|\|', lambda scanner, token: token), + (r'\|', lambda scanner, token: token), + (r'^ *\# *if', None), + (r'\s+', None), +]) + + +cpp_operate = { + '(': lambda x: x, + '!': lambda x: not x, + 'defined': lambda x, y: x in y, + '*': lambda x, y: x * y, + '/': lambda x, y: x // y, + '+': lambda x, y: x + y, + '-': lambda x, y: x - y, + '>>': lambda x, y: x >> y, + '<<': lambda x, y: x << y, + '==': lambda x, y: x == y, + '>': lambda x, y: x > y, + '>=': lambda x, y: x >= y, + '<': lambda x, y: x < y, + '<=': lambda x, y: x <= y, + '&': lambda x, y: x & y, + '^': lambda x, y: x ^ y, + '|': lambda x, y: x | y, + '&&': lambda x, y: x and y, + '||': lambda x, y: x or y, +} + + +cpp_op_rank = { + '(': 13, + '!': 12, + 'defined': 12, + '*': 11, + '/': 11, + '+': 10, + '-': 10, + '>>': 9, + '<<': 9, + '>': 8, + '>=': 8, + '<': 8, + '<=': 8, + '==': 7, + '&': 6, + '^': 5, + '|': 4, + '&&': 2, + '||': 2, + ')': 1, + '$': 1, + None: 0, +} + + +def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, + link_externals, defines): + """Create "makefile" after scanning "src_dis".""" + + # Scan everything Fortran related + all_files = find_files(src_dirs, skip_dirs) + + # Lists of things + # ... all F90 source + F90_files = [ + f for f in all_files + if f.endswith('.f90') or f.endswith('.F90') + or f.endswith('.f') or f.endswith('.F') + ] + # ... all C source + c_files = [f for f in all_files if f.endswith('.c')] + + # Dictionaries for associating files to files + # maps basename of file to full path to file + f2F = dict(zip([os.path.basename(f) for f in all_files], all_files)) + # maps basename of file to directory + f2dir = dict(zip([os.path.basename(f) for f in all_files], + [os.path.dirname(f) for f in all_files])) + + # Check for duplicate files in search path + if not len(f2F) == len(all_files): + a = [] + for f in all_files: + if os.path.basename(f) in a: + print('Warning: File {} was found twice! One is being ignored ' + 'but which is undefined.'.format(os.path.basename(f))) + a.append(os.path.basename(f)) + + # maps object file to F90 source + o2F90 = dict(zip([object_file(f) for f in F90_files], F90_files)) + # maps object file to C source + o2c = dict(zip([object_file(f) for f in c_files], c_files)) + + o2mods, o2uses, o2h, o2inc, o2prg, prg2o, mod2o = {}, {}, {}, {}, {}, {}, {} + externals, all_modules = [], [] + for f in F90_files: + mods, used, cpp, inc, prg, has_externals = scan_fortran_file(f, defines) + # maps object file to modules produced + o2mods[object_file(f)] = mods + # maps module produced to object file + for m in mods: + mod2o[m] = object_file(f) + # maps object file to modules used + o2uses[object_file(f)] = used + # maps object file to .h files included + o2h[object_file(f)] = cpp + # maps object file to .inc files included + o2inc[object_file(f)] = inc + # maps object file to executables produced + o2prg[object_file(f)] = prg + if prg: + for p in prg: + if p in prg2o.keys(): + # raise ValueError("Files %s and %s both create the same program '%s'"%( + # f,o2F90[prg2o[p]],p)) + print("Warning: Files {} and {} both create the same " + "program '{}'".format(f, o2F90[prg2o[p]], p)) + o = prg2o[p] + del prg2o[p] + # del o2prg[o] - need to keep so modifying instead + o2prg[o] = ['[ignored %s]' % (p)] + else: + prg2o[p] = object_file(f) + if has_externals: + externals.append(object_file(f)) + all_modules += mods + + for f in c_files: + _, _, cpp, inc, _, _ = scan_fortran_file(f, defines) + # maps object file to .h files included + o2h[object_file(f)] = cpp + externals.append(object_file(f)) + + # Are we building a library, single or multiple executables? + targ_libs = [] + if exec_target: + if exec_target.endswith('.a'): + targ_libs.append(exec_target) + else: + if len(prg2o.keys()) == 1: + o = prg2o.values()[0] + del prg2o[o2prg[o][0]] + prg2o[exec_target] = o + o2prg[o] = exec_target + else: + raise ValueError("Option -x specified an executable name but " + "none or multiple programs were found") + targets = [exec_target] + else: + if len(prg2o.keys()) == 0: + print("Warning: No programs were found and -x did not specify a " + "library to build") + targets = prg2o.keys() + + # Create new makefile + with open(makefile, 'w') as file: + print("# %s created by makedep" % (makefile), file=file) + print("", file=file) + print("# Invoked as", file=file) + print('# '+' '.join(sys.argv), file=file) + print("", file=file) + print("all:", " ".join(targets), file=file) + print("", file=file) + + # print("# SRC_DIRS is usually set in the parent Makefile but in case is it not we", file=file) + # print("# record it here from when makedep was previously invoked.", file=file) + # print("SRC_DIRS ?= ${SRC_DIRS}", file=file) + # print("", file=file) + + # print("# all_files:", ' '.join(all_files), file=file) + # print("", file=file) + + # Write rule for each object from Fortran + for o in sorted(o2F90.keys()): + found_mods = [m for m in o2uses[o] if m in all_modules] + found_objs = [mod2o[m] for m in o2uses[o] if m in all_modules] + found_deps = [ + dep for pair in zip(found_mods, found_objs) for dep in pair + ] + missing_mods = [m for m in o2uses[o] if m not in all_modules] + + incs, inc_used = nested_inc(o2h[o] + o2inc[o], f2F, defines) + inc_mods = [u for u in inc_used if u not in found_mods and u in all_modules] + + incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) + incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) + if debug: + print("# Source file {} produces:".format(o2F90[o]), file=file) + print("# object:", o, file=file) + print("# modules:", ' '.join(o2mods[o]), file=file) + print("# uses:", ' '.join(o2uses[o]), file=file) + print("# found mods:", ' '.join(found_mods), file=file) + print("# found objs:", ' '.join(found_objs), file=file) + print("# missing:", ' '.join(missing_mods), file=file) + print("# includes_all:", ' '.join(incs), file=file) + print("# includes_pth:", ' '.join(incdeps), file=file) + print("# incargs:", ' '.join(incargs), file=file) + print("# program:", ' '.join(o2prg[o]), file=file) + if o2mods[o]: + print(' '.join(o2mods[o])+':', o, file=file) + print(o + ':', o2F90[o], ' '.join(inc_mods + incdeps + found_deps), file=file) + print('\t'+fc_rule, ' '.join(incargs), file=file) + + # Write rule for each object from C + for o in sorted(o2c.keys()): + incdeps = sorted(set([f2F[h] for h in o2h[o] if h in f2F])) + incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) + if debug: + print("# Source file %s produces:" % (o2c[o]), file=file) + print("# object:", o, file=file) + print("# includes_all:", ' '.join(o2h[o]), file=file) + print("# includes_pth:", ' '.join(incdeps), file=file) + print("# incargs:", ' '.join(incargs), file=file) + print(o+':', o2c[o], ' '.join(incdeps), file=file) + print('\t$(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS) -c $<', ' '.join(incargs), file=file) + + # Externals (so called) + if link_externals: + print("", file=file) + print("# Note: The following object files are not associated with " + "modules so we assume we should link with them:", file=file) + print("# ", ' '.join(externals), file=file) + o2x = None + else: + externals = [] + + # Write rules for linking executables + for p in sorted(prg2o.keys()): + o = prg2o[p] + print("", file=file) + print(p+':', ' '.join(link_obj(o, o2uses, mod2o, all_modules) + externals), file=file) + print('\t$(LD) $(LDFLAGS) -o $@ $^ $(LIBS)', file=file) + + # Write rules for building libraries + for lb in sorted(targ_libs): + print("", file=file) + print(lb+':', ' '.join(list(o2F90.keys()) + list(o2c.keys())), file=file) + print('\t$(AR) $(ARFLAGS) $@ $^', file=file) + + # Write cleanup rules + print("", file=file) + print("clean:", file=file) + print('\trm -f *.mod *.o', ' '.join(list(prg2o.keys()) + targ_libs), file=file) + + # Write re-generation rules + print("", file=file) + print("remakedep:", file=file) + print('\t'+' '.join(sys.argv), file=file) + + +def link_obj(obj, o2uses, mod2o, all_modules): + """List of all objects needed to link "obj",""" + def recur(obj, depth=0): + if obj not in olst: + olst.append(obj) + else: + return + uses = [m for m in o2uses[obj] if m in all_modules] + if len(uses) > 0: + ouses = [mod2o[m] for m in uses] + for m in uses: + o = mod2o[m] + recur(o, depth=depth+1) + # if o not in olst: + # recur(o, depth=depth+1) + # olst.append(o) + return + return + olst = [] + recur(obj) + return sorted(set(olst)) + + +def nested_inc(inc_files, f2F, defines): + """List of all files included by "inc_files", either by #include or F90 + include.""" + hlst = [] + used_mods = set() + + def recur(hfile): + if hfile not in f2F.keys(): + return + + _, used, cpp, inc, _, _ = scan_fortran_file(f2F[hfile], defines) + + # Record any module updates inside of include files + used_mods.update(used) + + if len(cpp) + len(inc) > 0: + for h in cpp+inc: + if h not in hlst and h in f2F.keys(): + recur(h) + hlst.append(h) + return + return + + for h in inc_files: + recur(h) + + return inc_files + sorted(set(hlst)), used_mods + + +def scan_fortran_file(src_file, defines=None): + """Scan the Fortran file "src_file" and return lists of module defined, + module used, and files included.""" + module_decl, used_modules, cpp_includes, f90_includes, programs = [], [], [], [], [] + + cpp_defines = defines if defines is not None else [] + + #cpp_macros = [define.split('=')[0] for define in cpp_defines] + cpp_macros = dict([t.split('=') for t in cpp_defines]) + cpp_group_stack = [] + + with io.open(src_file, 'r', errors='replace') as file: + lines = file.readlines() + + external_namespace = True + # True if we are in the external (i.e. global) namespace + + file_has_externals = False + # True if the file contains any external objects + + cpp_exclude = False + # True if the parser excludes the subsequent lines + + cpp_group_stack = [] + # Stack of condition group exclusion states + + for line in lines: + # Start of #ifdef condition group + match = re_cpp_ifdef.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + # If outer group is excluding or macro is missing, then exclude + macro = line.lstrip()[1:].split()[1] + cpp_exclude = cpp_exclude or macro not in cpp_macros + + # Start of #ifndef condition group + match = re_cpp_ifndef.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + # If outer group is excluding or macro is present, then exclude + macro = line.lstrip()[1:].split()[1] + cpp_exclude = cpp_exclude or macro in cpp_macros + + # Start of #if condition group + match = re_cpp_if.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + cpp_expr_value = cpp_expr_eval(line, cpp_macros) + + cpp_exclude = not cpp_expr_value + + # Complement #else condition group + match = re_cpp_else.match(line) + if match: + # Reverse the exclude state, if there is no outer exclude state + outer_grp_exclude = cpp_group_stack and cpp_group_stack[-1] + cpp_exclude = not cpp_exclude or outer_grp_exclude + + # Restore exclude state when exiting conditional block + match = re_cpp_endif.match(line) + if match: + cpp_exclude = cpp_group_stack.pop() + + # Skip lines inside of false condition blocks + if cpp_exclude: + continue + + # Activate a new macro (ignoring the value) + match = re_cpp_define.match(line) + if match: + 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 + cpp_macros[macro] = value + + # Deactivate a macro + match = re_cpp_undef.match(line) + if match: + new_macro = line.lstrip()[1:].split()[1] + try: + cpp_macros.remove(new_macro) + except: + # Ignore missing macros (for now?) + continue + + match = re_module.match(line.lower()) + if match: + if match.group(1) not in 'procedure': # avoid "module procedure" statements + module_decl.append(match.group(1)) + external_namespace = False + + match = re_use.match(line.lower()) + if match: + used_modules.append(match.group(1)) + + match = re_cpp_include.match(line) + if match: + cpp_includes.append(match.group(1)) + + match = re_f90_include.match(line) + if match: + f90_includes.append(match.group(1)) + + match = re_program.match(line) + if match: + programs.append(match.group(1)) + external_namespace = False + + match = re_end.match(line) + if match: + external_namespace = True + + # Check for any external procedures; if present, flag the file + # as a potential source of + # NOTE: This a very weak test that needs further modification + if external_namespace and not file_has_externals: + match = re_procedure.match(line) + if match: + file_has_externals = True + + used_modules = [m for m in sorted(set(used_modules)) if m not in module_decl] + return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs, file_has_externals + # return add_suff(module_decl, '.mod'), add_suff(sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs + + +def object_file(src_file): + """Return the name of an object file that results from compiling + src_file.""" + return os.path.splitext(os.path.basename(src_file))[0] + '.o' + + +def find_files(src_dirs, skip_dirs): + """Return sorted list of all source files starting from each directory in + the list "src_dirs".""" + + if skip_dirs is not None: + skip = [os.path.normpath(s) for s in skip_dirs] + else: + skip = [] + + # TODO: Make this a user-defined argument + extensions = ('.f90', '.f', '.c', '.inc', '.h', '.fh') + + files = [] + + for path in src_dirs: + if not os.path.isdir(path): + raise ValueError("Directory '{}' was not found".format(path)) + for p, d, f in os.walk(os.path.normpath(path), followlinks=True): + d[:] = [s for s in d if os.path.join(p, s) not in skip] + + for file in f: + if any(file.lower().endswith(ext) for ext in extensions): + files.append(p+'/'+file) + return sorted(set(files)) + + +def add_suff(lst, suff): + """Add "suff" to each item in the list""" + return [f + suff for f in lst] + + +def cpp_expr_eval(expr, macros=None): + if macros is None: + macros = {} + + results, remainder = cpp_scanner.scan(expr.strip()) + + # Abort if any characters are not tokenized + if remainder: + print('There are untokenized characters!') + print('Expression:', repr(expr)) + print('Tokens:', results) + print('Unscanned:', remainder) + raise + + # Add an "end of line" character to force evaluation of the final tokens. + results.append('$') + + stack = [] + prior_op = None + + tokens = iter(results) + for tok in tokens: + if tok in cpp_op_rank.keys(): + while cpp_op_rank[tok] <= cpp_op_rank[prior_op]: + + # Unary operators are "look ahead" so we always skip them. + # (However, `op` below could be a unary operator.) + if tok in ('!', 'defined', '('): + break + + second = stack.pop() + op = stack.pop() + + if op == '(': + value = second + + elif op == '!': + if isinstance(second, str): + if second.isidentifier(): + second = macros.get(second, '0') + if second.isdigit(): + second = int(second) + + value = cpp_operate[op](second) + + elif op == 'defined': + value = cpp_operate[op](second, macros) + + else: + first = stack.pop() + + if isinstance(first, str): + if first.isidentifier(): + first = macros.get(first, '0') + if first.isdigit(): + first = int(first) + + if isinstance(second, str): + if second.isidentifier(): + second = macros.get(second, '0') + if second.isdigit(): + second = int(second) + + value = cpp_operate[op](first, second) + + prior_op = stack[-1] if stack else None + stack.append(value) + + # The ) "operator" has already been applied, so it can be dropped. + if tok != ')': + stack.append(tok) + prior_op = tok + + elif tok.isdigit() or tok.isidentifier(): + stack.append(tok) + + else: + print("Unsupported token:", tok) + raise + + # Remove the tail value + eol = stack.pop() + assert eol == '$' + value = stack.pop() + + return value + + +# Parse arguments +parser = argparse.ArgumentParser( + description="Generate make dependencies for F90 source code." +) +parser.add_argument( + 'path', + nargs='+', + help="Directories to search for source code." +) +parser.add_argument( + '-o', '--makefile', + default='Makefile.dep', + help="Name of Makefile to put dependencies in to. Default is Makefile.dep." +) +parser.add_argument( + '-f', '--fc_rule', + default="$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<", + help="String to use in the compilation rule. Default is: " + "'$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<'" +) +parser.add_argument( + '-x', '--exec_target', + help="Name of executable to build. Fails if more than one program is " + "found. If EXEC ends in .a then a library is built." +) +parser.add_argument( + '-e', '--link_externals', + action='store_true', + help="Always compile and link any files that do not produce modules " + "(externals)." +) +parser.add_argument( + '-d', '--debug', + action='store_true', + help="Annotate the makefile with extra information." +) +parser.add_argument( + '-s', '--skip', + action='append', + help="Skip directory in source code search." +) +parser.add_argument( + '-D', '--define', + action='append', + help="Apply preprocessor define macros (of the form -DMACRO[=value])", +) +args = parser.parse_args() + +# Do the thing +create_deps(args.path, args.skip, args.makefile, args.debug, args.exec_target, + args.fc_rule, args.link_externals, args.define) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 similarity index 61% rename from config_src/coupled_driver/MOM_surface_forcing.F90 rename to config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index bb6270c177..58b21892be 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -1,29 +1,36 @@ -module MOM_surface_forcing +module MOM_surface_forcing_gfdl ! This file is part of MOM6. See LICENSE.md for the license. !#CTRL# use MOM_controlled_forcing, only : apply_ctrl_forcing, register_ctrl_forcing_restarts !#CTRL# use MOM_controlled_forcing, only : controlled_forcing_init, controlled_forcing_end !#CTRL# use MOM_controlled_forcing, only : ctrl_forcing_CS -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf +use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_spawn +use MOM_coupler_types, only : coupler_type_copy_data use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT -use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_mediator, only : safe_alloc_ptr, time_type +use MOM_data_override, only : data_override_init, data_override +use MOM_diag_mediator, only : diag_ctrl, safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type +use MOM_interpolate, only : init_external_field, time_interp_external +use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : read_netCDF_data +use MOM_io, only : stdout_if_root use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state use MOM_string_functions, only : uppercase @@ -32,15 +39,7 @@ module MOM_surface_forcing use MOM_variables, only : surface use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS - -use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn -use coupler_types_mod, only : coupler_type_copy_data -use data_override_mod, only : data_override_init, data_override -use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init +use iso_fortran_env, only : int64 implicit none ; private @@ -63,16 +62,17 @@ module MOM_surface_forcing !! from MOM_domains) to indicate the staggering of !! the winds that are being provided in calls to !! update_ocean_model. - logical :: use_temperature !< If true, temp and saln used as state variables + logical :: use_temperature !< If true, temp and saln used as state variables. + logical :: nonBous !< If true, this run is fully non-Boussinesq real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress [nondim]. - real :: Rho0 !< Boussinesq reference density [kg m-3] + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: area_surf = -1.0 !< Total ocean surface area [m2] - real :: latent_heat_fusion !< Latent heat of fusion [J kg-1] - real :: latent_heat_vapor !< Latent heat of vaporization [J kg-1] + real :: latent_heat_fusion !< Latent heat of fusion [Q ~> J kg-1] + real :: latent_heat_vapor !< Latent heat of vaporization [Q ~> J kg-1] - real :: max_p_surf !< The maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice [Pa]. + real :: max_p_surf !< The maximum surface pressure that can be exerted by + !! the atmosphere and floating sea-ice [R L2 T-2 ~> Pa]. !! This is needed because the FMS coupling structure !! does not limit the water that can be frozen out !! of the ocean and the ice-ocean heat fluxes are @@ -85,35 +85,41 @@ module MOM_surface_forcing !! type without any further adjustments to drive the ocean dynamics. !! The actual net mass source may differ due to corrections. - real :: gust_const !< Constant unresolved background gustiness for ustar [Pa] + real :: gust_const !< Constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL() !< Turbulent kinetic energy introduced to the bottom boundary layer - !! by drag on the tidal flows [W m-2]. + !! by drag on the tidal flows [R Z3 T-3 ~> W m-2]. real, pointer, dimension(:,:) :: & gust => NULL() !< A spatially varying unresolved background gustiness that - !! contributes to ustar [Pa]. gust is used when read_gust_2d is true. + !! contributes to ustar [R L Z T-2 ~> Pa]. gust is used when read_gust_2d is true. real, pointer, dimension(:,:) :: & - ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [m s-1] - real :: cd_tides !< Drag coefficient that applies to the tides (nondimensional) - real :: utide !< Constant tidal velocity to use if read_tideamp is false [m s-1]. + ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] + real :: cd_tides !< Drag coefficient that applies to the tides [nondim] + real :: utide !< Constant tidal velocity to use if read_tideamp is false [Z T-1 ~> m s-1]. logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts to damp surface !! deflections (especially surface gravity waves). The default is false. - real :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< Typical density of sea-ice [kg m-3]. The value is only used to convert + real :: g_Earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< Typical density of sea-ice [R ~> kg m-3]. The value is only used to convert !! the ice pressure into appropriate units for use with Kv_sea_ice. real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which sea-ice viscosity - !! becomes effective [kg m-2], typically of order 1000 kg m-2. + !! 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 :: restore_salt !< If true, the coupled MOM driver adds a term to restore surface !! salinity to a specified value. logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea !! surface temperature to a specified value. - real :: Flux_const !< Piston velocity for surface restoring [m s-1] + real :: Flux_const_salt !< Piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: Flux_const_temp !< Piston velocity for surface temperature restoring [Z T-1 ~> m s-1] + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] + logical :: trestore_SPEAR_ECDA !< If true, modify restoring data wrt local SSS + real :: SPEAR_dTf_dS !< The derivative of the freezing temperature with + !! salinity [C S-1 ~> degC ppt-1]. logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux logical :: adjust_net_srestore_to_zero !< Adjust srestore to zero (for both salt_flux or vprec) logical :: adjust_net_srestore_by_scaling !< Adjust srestore w/o moving zero contour @@ -124,12 +130,16 @@ module MOM_surface_forcing !! for salinity restoring. real :: ice_salt_concentration !< Salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< If true, then mask SSS restoring in marginal seas - real :: max_delta_srestore !< Maximum delta salinity used for restoring - real :: max_delta_trestore !< Maximum delta sst used for restoring - real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover - !! the answers from the end of 2018. Otherwise, use a simpler - !! expression to calculate gustiness. + real :: max_delta_srestore !< Maximum delta salinity used for restoring [S ~> ppt] + real :: max_delta_trestore !< Maximum delta sst used for restoring [C ~> degC] + real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin [nondim] + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! gustiness calculations. Values below 20190101 recover the answers + !! from the end of 2018, while higher values use a simpler expression + !! to calculate gustiness. + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the + !! gustless wind friction velocity. + logical :: check_no_land_fluxes !< Return warning if IOB flux over land is non-zero type(diag_ctrl), pointer :: diag => NULL() !< Structure to regulate diagnostic output timing character(len=200) :: inputdir !< Directory where NetCDF input files are @@ -139,16 +149,18 @@ module MOM_surface_forcing !! salinity restoring fluxes. The masking file should be !! in inputdir/salt_restore_mask.nc and the field should !! be named 'mask' - real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring + real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring [nondim] character(len=200) :: temp_restore_file !< Filename for sst restoring data character(len=30) :: temp_restore_var_name !< Name of surface temperature in temp_restore_file logical :: mask_trestore !< If true, apply a 2-dimensional mask to the surface !! temperature restoring fluxes. The masking file should be !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' - real, pointer, dimension(:,:) :: trestore_mask => NULL() !< Mask for SST restoring - integer :: id_srestore = -1 !< An id number for time_interp_external. - integer :: id_trestore = -1 !< An id number for time_interp_external. + real, pointer, dimension(:,:) :: trestore_mask => NULL() !< Mask for SST restoring [nondim] + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field type(forcing_diags), public :: handles !< Diagnostics handles @@ -166,6 +178,7 @@ module MOM_surface_forcing real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W m-2] real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux [kg m-2 s-1] real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux [kg m-2 s-1] + real, pointer, dimension(:,:) :: excess_salt =>NULL() !< salt left behind by brine rejection [kg m-2 s-1] real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation [W m-2] real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation [W m-2] real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation [W m-2] @@ -188,6 +201,10 @@ module MOM_surface_forcing !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model [m3 s-1] + real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< + real, pointer, dimension(:,:,:) :: ustkb => NULL() !< + real, pointer, dimension(:,:,:) :: vstkb => NULL() !< + integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of named fields !! used for passive tracer fluxes. @@ -195,6 +212,7 @@ module MOM_surface_forcing !! This flag may be set by the flux-exchange code, based on what !! the sea-ice model is providing. Otherwise, the value from !! the surface_forcing_CS is used. + integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler end type ice_ocean_boundary_type integer :: id_clock_forcing !< A CPU time clock @@ -204,7 +222,7 @@ module MOM_surface_forcing !> This subroutine translates the Ice_ocean_boundary_type into a MOM !! thermodynamic forcing type, including changes of units, sign conventions, !! and putting the fields into arrays with MOM-standard halos. -subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc_state) +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, US, CS, sfc_state) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -214,6 +232,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. + real, intent(in) :: valid_time !< The amount of time over which these fluxes + !! should be applied [T ~> s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -222,15 +242,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc !! surface state of the ocean. real, dimension(SZI_(G),SZJ_(G)) :: & - data_restore, & ! The surface value toward which to restore [ppt] or [degC] - SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value [degC] - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value [ppt] + data_restore, & ! The surface value toward which to restore [S ~> ppt] or [C ~> degC] + SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value [C ~> degC] + SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value [S ~> ppt] SSS_mean, & ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation anomalies [ppt] - PmE_adj, & ! The adjustment to PminusE that will cause the salinity - ! to be restored toward its target value [kg m-1 s-1] + ! anomalies when calculating restorative precipitation anomalies [S ~> ppt] net_FW, & ! The area integrated net freshwater flux into the ocean [kg s-1] - net_FW2, & ! The area integrated net freshwater flux into the ocean [kg s-1] + net_FW2, & ! The net freshwater flux into the ocean [kg m-2 s-1] work_sum, & ! A 2-d array that is used as the work space for global sums [m2] or [kg s-1] open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria [nondim] @@ -238,11 +256,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - real :: delta_sss ! temporary storage for sss diff from restoring value [ppt] - real :: delta_sst ! temporary storage for sst diff from restoring value [degC] + real :: delta_sss ! temporary storage for sss diff from restoring value [S ~> ppt] + real :: delta_sst ! temporary storage for sst diff from restoring value [C ~> degC] - real :: C_p ! heat capacity of seawater [J degC-1 kg-1] - real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. + real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling + ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1] + real :: rhoXcp ! Reference density times heat capacity times unit scaling + ! factors [Q R C-1 ~> J m-3 degC-1] + real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1 [nondim] call cpu_clock_begin(id_clock_forcing) @@ -254,9 +275,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc 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 - C_p = fluxes%C_p + kg_m2_s_conversion = US%kg_m2s_to_RZ_T + if (CS%restore_temp) rhoXcp = CS%rho_restore * fluxes%C_p open_ocn_mask(:,:) = 1.0 - pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 fluxes%vPrecGlobalScl = 0.0 fluxes%saltFluxGlobalAdj = 0.0 @@ -267,8 +288,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc ! allocation and initialization if this is the first time that this ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) + 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) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -285,24 +306,21 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) - if (CS%allow_flux_adjustments) then - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - endif + call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + + if (associated(IOB%excess_salt)) call safe_alloc_ptr(fluxes%salt_left_behind,isd,ied,jsd,jed) do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) - fluxes%ustar_tidal(i,j) = US%m_to_Z*US%T_to_s*CS%ustar_tidal(i,j) + fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo - if (CS%restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - fluxes%dt_buoy_accum = 0.0 endif ! endif for allocation and initialization @@ -313,25 +331,27 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc if ((.not.coupler_type_initialized(fluxes%tr_fluxes)) .and. & coupler_type_initialized(IOB%fluxes)) & - call coupler_type_spawn(IOB%fluxes, fluxes%tr_fluxes, & - (/is,is,ie,ie/), (/js,js,je,je/)) + call coupler_type_spawn(IOB%fluxes, fluxes%tr_fluxes, (/is,is,ie,ie/), (/js,js,je,je/)) ! It might prove valuable to use the same array extents as the rest of the ! ocean model, rather than using haloless arrays, in which case the last line ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 - endif - ! allocation and initialization on first call to this routine if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie - work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) + work_sum(i,j) = US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) endif ! endif for allocation and initialization + + ! Indicate that there are new unused fluxes. + fluxes%fluxes_used = .false. + fluxes%dt_buoy_accum = valid_time + + fluxes%heat_added(:,:) = 0.0 + fluxes%salt_flux_added(:,:) = 0.0 + do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 @@ -339,51 +359,56 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc ! Salinity restoring logic if (CS%restore_salt) then - call time_interp_external(CS%id_srestore,Time,data_restore) + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie - if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + if (sfc_state%SST(i,j) <= CS%SPEAR_dTf_dS*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie - delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & - (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 + delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const_salt)* & + (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) * delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) + call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & + unit_scale=US%RZ_T_to_kg_m2s) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & + G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) * G%mask2dT(is:ie,js:je) fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - & + kg_m2_s_conversion * fluxes%saltFluxGlobalAdj * G%mask2dT(is:ie,js:je) endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & + (CS%rho_restore*CS%Flux_const_salt) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) + call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & + unit_scale=US%RZ_T_to_kg_m2s) fluxes%vPrecGlobalAdj = 0. else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & + US%RZ_T_to_kg_m2s*fluxes%vprec(is:ie,js:je) fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif endif @@ -392,12 +417,20 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc ! SST restoring logic if (CS%restore_temp) then - call time_interp_external(CS%id_trestore,Time,data_restore) + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) + if ( CS%trestore_SPEAR_ECDA ) then + do j=js,je ; do i=is,ie + if (abs(data_restore(i,j)+1.8*US%degC_to_C) < 0.0001*US%degC_to_C) then + data_restore(i,j) = CS%SPEAR_dTf_dS*sfc_state%SSS(i,j) + endif + enddo ; enddo + endif + do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- sfc_state%SST(i,j) - delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) + delta_sst = data_restore(i,j) - sfc_state%SST(i,j) + delta_sst = sign(1.0,delta_sst) * min(abs(delta_sst), CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & - (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + rhoXcp * delta_sst * CS%Flux_const_temp ! [Q R Z T-1 ~> W m-2] enddo ; enddo endif @@ -406,68 +439,122 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc i0 = is - isc_bnd ; j0 = js - jsc_bnd do j=js,je ; do i=is,ie - if (associated(IOB%lprec)) & - fluxes%lprec(i,j) = IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%lprec)) then + fluxes%lprec(i,j) = kg_m2_s_conversion * IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%lprec(i-i0,j-j0), G%mask2dT(i,j), i, j, 'lprec', G) + endif - if (associated(IOB%fprec)) & - fluxes%fprec(i,j) = IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%fprec)) then + fluxes%fprec(i,j) = kg_m2_s_conversion * IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%fprec(i-i0,j-j0), G%mask2dT(i,j), i, j, 'fprec', G) + endif - if (associated(IOB%q_flux)) & - fluxes%evap(i,j) = - IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%q_flux)) then + fluxes%evap(i,j) = - kg_m2_s_conversion * IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%q_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'q_flux', G) + endif - if (associated(IOB%runoff)) & - fluxes%lrunoff(i,j) = IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%runoff)) then + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%runoff(i-i0,j-j0), G%mask2dT(i,j), i, j, 'runoff', G) + endif - if (associated(IOB%calving)) & - fluxes%frunoff(i,j) = IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%calving)) then + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%calving(i-i0,j-j0), G%mask2dT(i,j), i, j, 'calving', G) + endif - if (associated(IOB%ustar_berg)) & + if (associated(IOB%ustar_berg)) then fluxes%ustar_berg(i,j) = US%m_to_Z*US%T_to_s * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%ustar_berg(i-i0,j-j0), G%mask2dT(i,j), i, j, 'ustar_berg', G) + endif - if (associated(IOB%area_berg)) & + if (associated(IOB%area_berg)) then fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%area_berg(i-i0,j-j0), G%mask2dT(i,j), i, j, 'area_berg', G) + endif - if (associated(IOB%mass_berg)) & - fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%mass_berg)) then + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%mass_berg(i-i0,j-j0), G%mask2dT(i,j), i, j, 'mass_berg', G) + endif - if (associated(IOB%runoff_hflx)) & - fluxes%heat_content_lrunoff(i,j) = IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%runoff_hflx)) then + fluxes%heat_content_lrunoff(i,j) = US%W_m2_to_QRZ_T * IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + 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%calving_hflx)) & - fluxes%heat_content_frunoff(i,j) = IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + 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) & + call check_mask_val_consistency(IOB%calving_hflx(i-i0,j-j0), G%mask2dT(i,j), i, j, 'calving_hflx', G) + endif - if (associated(IOB%lw_flux)) & - fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%lw_flux)) then + fluxes%LW(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%lw_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'lw_flux', G) + endif - if (associated(IOB%t_flux)) & - fluxes%sens(i,j) = - IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%t_flux)) then + fluxes%sens(i,j) = -US%W_m2_to_QRZ_T* IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%t_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 't_flux', G) + endif fluxes%latent(i,j) = 0.0 if (associated(IOB%fprec)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = -G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%fprec(i-i0,j-j0)*kg_m2_s_conversion * CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*kg_m2_s_conversion * CS%latent_heat_fusion endif if (associated(IOB%calving)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -G%mask2dT(i,j) * IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%calving(i-i0,j-j0)*kg_m2_s_conversion * CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -G%mask2dT(i,j) * IOB%calving(i-i0,j-j0)*kg_m2_s_conversion * & + CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = -G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor + fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%q_flux(i-i0,j-j0)*kg_m2_s_conversion * CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = -G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*kg_m2_s_conversion * CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) - if (associated(IOB%sw_flux_vis_dir)) & - fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dir(i-i0,j-j0) - if (associated(IOB%sw_flux_vis_dif)) & - fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dif(i-i0,j-j0) - if (associated(IOB%sw_flux_nir_dir)) & - fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dir(i-i0,j-j0) - if (associated(IOB%sw_flux_nir_dif)) & - fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dif(i-i0,j-j0) - fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & - fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) + if (associated(IOB%sw_flux_vis_dir)) then + fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_vis_dir(i-i0,j-j0) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%sw_flux_vis_dir(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_vis_dir', G) + endif + if (associated(IOB%sw_flux_vis_dif)) then + fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_vis_dif(i-i0,j-j0) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%sw_flux_vis_dif(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_vis_dif', G) + endif + if (associated(IOB%sw_flux_nir_dir)) then + fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_nir_dir(i-i0,j-j0) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%sw_flux_nir_dir(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_nir_dir', G) + endif + if (associated(IOB%sw_flux_nir_dif)) then + fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_nir_dif(i-i0,j-j0) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%sw_flux_nir_dif(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_nir_dif', G) + endif + if (CS%answer_date < 20190101) then + fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & + fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) + else + fluxes%sw(i,j) = (fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j)) + & + (fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j)) + endif enddo ; enddo @@ -475,13 +562,17 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) enddo ; enddo else do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) enddo ; enddo endif fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. @@ -490,8 +581,15 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc ! more salt restoring logic if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie - fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) - IOB%salt_flux(i-i0,j-j0)) - fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( -IOB%salt_flux(i-i0,j-j0) ) + fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) - kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0)) + fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( -kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0) ) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%salt_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'salt_flux', G) + enddo ; enddo + endif + if (associated(IOB%excess_salt)) then + do j=js,je ; do i=is,ie + fluxes%salt_left_behind(i,j) = G%mask2dT(i,j)*(kg_m2_s_conversion*IOB%excess_salt(i-i0,j-j0)) enddo ; enddo endif @@ -501,8 +599,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc !#CTRL# SSS_anom(i,j) = sfc_state%SSS(i,j) - CS%S_Restore(i,j) !#CTRL# SSS_mean(i,j) = 0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j)) !#CTRL# enddo ; enddo -!#CTRL# call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_restore, & -!#CTRL# fluxes%vprec, day, dt, G, CS%ctrl_forcing_CSp) +!#CTRL# call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_added, & +!#CTRL# fluxes%vprec, day, valid_time, G, US, CS%ctrl_forcing_CSp) !#CTRL# endif ! adjust the NET fresh-water flux to zero, if flagged @@ -510,9 +608,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc sign_for_net_FW_bug = 1. if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie - net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & + net_FW(i,j) = US%RZ_T_to_kg_m2s* & + (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & - (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) + (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) ! The following contribution appears to be calculating the volume flux of sea-ice ! melt. This calculation is clearly WRONG if either sea-ice has variable ! salinity or the sea-ice is completely fresh. @@ -520,33 +619,37 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc ! is constant. ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA if (associated(IOB%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & - net_FW(i,j) = net_FW(i,j) + sign_for_net_FW_bug * G%areaT(i,j) * & + net_FW(i,j) = net_FW(i,j) + sign_for_net_FW_bug * US%L_to_m**2*G%areaT(i,j) * & (IOB%salt_flux(i-i0,j-j0) / CS%ice_salt_concentration) - net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) + net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + kg_m2_s_conversion * & + (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) enddo ; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif endif ! Set the wind stresses and ustar. - if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless)) then + if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) .and. associated(fluxes%tau_mag)) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar, & - gustless_ustar=fluxes%ustar_gustless) - elseif (associated(fluxes%ustar)) then - call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) - elseif (associated(fluxes%ustar_gustless)) then - call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) + mag_tau=fluxes%tau_mag, gustless_ustar=fluxes%ustar_gustless) + else + if (associated(fluxes%ustar)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) + if (associated(fluxes%ustar_gustless)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) + if (associated(fluxes%tau_mag)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=fluxes%tau_mag) endif if (coupler_type_initialized(fluxes%tr_fluxes) .and. & @@ -555,7 +658,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc if (CS%allow_flux_adjustments) then ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, fluxes) + call apply_flux_adjustments(G, US, CS, Time, fluxes) endif ! Allow for user-written code to alter fluxes after all the above @@ -582,23 +685,26 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ !! previous call to surface_forcing_init. real, optional, intent(in) :: dt_forcing !< A time interval over which to apply the !! current value of ustar as a weighted running - !! average [s], or if 0 do not average ustar. + !! average [T ~> s], or if 0 do not average ustar. !! Missing is equivalent to 0. logical, optional, intent(in) :: reset_avg !< If true, reset the time average. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & ! Ice rigidity at tracer points [m3 s-1] - net_mass_src, & ! A temporary of net mass sources [kg m-2 s-1]. - ustar_tmp ! A temporary array of ustar values [Z T-1 ~> m s-1]. - - real :: I_GEarth ! 1.0 / G_Earth [s2 m-1] - real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] - real :: mass_ice ! mass of sea ice at a face [kg m-2] - real :: mass_eff ! effective mass of sea ice for rigidity [kg m-2] - real :: wt1, wt2 ! Relative weights of previous and current values of ustar, ND. - - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + rigidity_at_h, & ! Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] + net_mass_src, & ! A temporary of net mass sources [R Z T-1 ~> kg m-2 s-1]. + ustar_tmp, & ! A temporary array of ustar values [Z T-1 ~> m s-1]. + tau_mag_tmp ! A temporary array of surface stress magnitudes [R Z L T-2 ~> Pa] + + real :: I_GEarth ! The inverse of the gravitational acceleration [T2 Z L-2 ~> s2 m-1] + real :: Kv_rho_ice ! (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice ! mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff ! effective mass of sea ice for rigidity [R Z ~> kg m-2] + real :: wt1, wt2 ! Relative weights of previous and current values of ustar [nondim]. + real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling + ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1] + + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0, istk integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -613,11 +719,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 i0 = is - isc_bnd ; j0 = js - jsc_bnd + kg_m2_s_conversion = US%kg_m2s_to_RZ_T + ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, & + press=.true., tau_mag=CS%nonBous) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) @@ -639,6 +747,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & call allocate_mech_forcing(G, forces, iceberg=.true.) + if ( associated(IOB%ustkb) ) & + call allocate_mech_forcing(G, forces, waves=.true., num_stk_bands=IOB%num_stk_bands) + if (associated(IOB%ice_rigidity)) then rigidity_at_h(:,:) = 0.0 call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -670,12 +781,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -690,14 +801,35 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! Set the wind stresses and ustar. if (wt1 <= 0.0) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=forces%ustar, tau_halo=1) + tau_halo=1) + if (associated(forces%ustar)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=forces%ustar) + if (associated(forces%tau_mag)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=forces%tau_mag) else call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=ustar_tmp, tau_halo=1) - do j=js,je ; do i=is,ie - forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) - enddo ; enddo + tau_halo=1) + if (associated(forces%ustar)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=ustar_tmp) + do j=js,je ; do i=is,ie + forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) + enddo ; enddo + endif + if (associated(forces%tau_mag)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=tau_mag_tmp) + do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = wt1*forces%tau_mag(i,j) + wt2*tau_mag_tmp(i,j) + enddo ; enddo + endif endif + forces%stk_wavenumbers(:) = IOB%stk_wavenumbers + do istk = 1,IOB%num_stk_bands + do j=js,je; do i=is,ie + forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) + forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) + enddo; enddo + call pass_vector(forces%ustkb(:,:,istk),forces%vstkb(:,:,istk), G%domain, stagger=AGRID) + enddo ! Find the net mass source in the input forcing without other adjustments. if (CS%approx_net_mass_src .and. associated(forces%net_mass_src)) then @@ -705,15 +837,15 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ i0 = is - isc_bnd ; j0 = js - jsc_bnd do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (associated(IOB%lprec)) & - net_mass_src(i,j) = net_mass_src(i,j) + IOB%lprec(i-i0,j-j0) + net_mass_src(i,j) = net_mass_src(i,j) + kg_m2_s_conversion * IOB%lprec(i-i0,j-j0) if (associated(IOB%fprec)) & - net_mass_src(i,j) = net_mass_src(i,j) + IOB%fprec(i-i0,j-j0) + net_mass_src(i,j) = net_mass_src(i,j) + kg_m2_s_conversion * IOB%fprec(i-i0,j-j0) if (associated(IOB%runoff)) & - net_mass_src(i,j) = net_mass_src(i,j) + IOB%runoff(i-i0,j-j0) + net_mass_src(i,j) = net_mass_src(i,j) + kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) if (associated(IOB%calving)) & - net_mass_src(i,j) = net_mass_src(i,j) + IOB%calving(i-i0,j-j0) + net_mass_src(i,j) = net_mass_src(i,j) + kg_m2_s_conversion * IOB%calving(i-i0,j-j0) if (associated(IOB%q_flux)) & - net_mass_src(i,j) = net_mass_src(i,j) - IOB%q_flux(i-i0,j-j0) + net_mass_src(i,j) = net_mass_src(i,j) - kg_m2_s_conversion * IOB%q_flux(i-i0,j-j0) endif ; enddo ; enddo if (wt1 <= 0.0) then do j=js,je ; do i=is,ie @@ -735,13 +867,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ enddo ; enddo ; endif if (associated(IOB%mass_berg)) then ; do j=js,je ; do i=is,ie - forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) enddo ; enddo ; endif ! Obtain sea ice related dynamic fields if (associated(IOB%ice_rigidity)) then do j=js,je ; do i=is,ie - rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) enddo ; enddo call pass_var(rigidity_at_h, G%Domain, halo=1) do I=is-1,ie ; do j=js,je @@ -756,14 +888,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%G_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + I_GEarth = 1.0 / CS%g_Earth + Kv_rho_ice = (CS%Kv_sea_ice / CS%density_sea_ice) do I=is-1,ie ; do j=js,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff enddo ; enddo @@ -771,8 +902,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff enddo ; enddo @@ -780,7 +910,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (CS%allow_flux_adjustments) then ! Apply adjustments to forces - call apply_force_adjustments(G, CS, Time, forces) + call apply_force_adjustments(G, US, CS, Time, forces) endif !### ! Allow for user-written code to alter fluxes after all the above @@ -794,7 +924,7 @@ end subroutine convert_IOB_to_forces !! Ice_ocean_boundary_type into optional argument arrays, including changes of units, sign !! conventions, and putting the fields into arrays with MOM-standard sized halos. subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ustar, & - gustless_ustar, tau_halo) + gustless_ustar, mag_tau, tau_halo) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -806,30 +936,34 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a !! previous call to surface_forcing_init. real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(inout) :: taux !< The zonal wind stresses on a C-grid [Pa]. + optional, intent(inout) :: taux !< The zonal wind stresses on a C-grid [R Z L T-2 ~> Pa]. real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(inout) :: tauy !< The meridional wind stresses on a C-grid [Pa]. + optional, intent(inout) :: tauy !< The meridional wind stresses on a C-grid [R Z L T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(inout) :: ustar !< The surface friction velocity [Z T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: gustless_ustar !< The surface friction velocity without !! any contributions from gustiness [Z T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: mag_tau !< The magintude of the wind stress at tracer points + !! including subgridscale variability and gustiness [R Z L T-2 ~> Pa] integer, optional, intent(in) :: tau_halo !< The halo size of wind stresses to set, 0 by default. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: taux_in_A ! Zonal wind stresses [Pa] at h points - real, dimension(SZI_(G),SZJ_(G)) :: tauy_in_A ! Meridional wind stresses [Pa] at h points - real, dimension(SZIB_(G),SZJ_(G)) :: taux_in_C ! Zonal wind stresses [Pa] at u points - real, dimension(SZI_(G),SZJB_(G)) :: tauy_in_C ! Meridional wind stresses [Pa] at v points - real, dimension(SZIB_(G),SZJB_(G)) :: taux_in_B ! Zonal wind stresses [Pa] at q points - real, dimension(SZIB_(G),SZJB_(G)) :: tauy_in_B ! Meridional wind stresses [Pa] at q points - - real :: gustiness ! unresolved gustiness that contributes to ustar [Pa] - real :: Irho0 ! Inverse of the mean density rescaled to [Z2 s2 m T-2 kg-1 ~> m3 kg-1] - real :: taux2, tauy2 ! squared wind stresses [Pa2] - real :: tau_mag ! magnitude of the wind stress [Pa] - - logical :: do_ustar, do_gustless + real, dimension(SZI_(G),SZJ_(G)) :: taux_in_A ! Zonal wind stresses [R Z L T-2 ~> Pa] at h points + real, dimension(SZI_(G),SZJ_(G)) :: tauy_in_A ! Meridional wind stresses [R Z L T-2 ~> Pa] at h points + real, dimension(SZIB_(G),SZJ_(G)) :: taux_in_C ! Zonal wind stresses [R Z L T-2 ~> Pa] at u points + real, dimension(SZI_(G),SZJB_(G)) :: tauy_in_C ! Meridional wind stresses [R Z L T-2 ~> Pa] at v points + real, dimension(SZIB_(G),SZJB_(G)) :: taux_in_B ! Zonal wind stresses [R Z L T-2 ~> Pa] at q points + real, dimension(SZIB_(G),SZJB_(G)) :: tauy_in_B ! Meridional wind stresses [R Z L T-2 ~> Pa] at q points + + real :: gustiness ! unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] + real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] + real :: taux2, tauy2 ! squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] + real :: tau_mag ! magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] + + logical :: do_ustar, do_gustless, do_tau_mag integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, ish, ieh, jsh, jeh, Isqh, Ieqh, Jsqh, Jeqh, i0, j0, halo @@ -839,9 +973,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, Isqh = G%IscB-halo ; Ieqh = G%IecB+halo ; Jsqh = G%JscB-halo ; Jeqh = G%JecB+halo i0 = is - index_bounds(1) ; j0 = js - index_bounds(3) - Irho0 = (US%m_to_Z*US%T_to_s)**2 / CS%Rho0 + IRho0 = US%L_to_Z / CS%Rho0 + stress_conversion = US%Pa_to_RLZ_T2 * CS%wind_stress_multiplier - do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) + do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) ; do_tau_mag = present(mag_tau) wind_stagger = CS%wind_stagger if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & @@ -854,14 +989,14 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ! Set surface momentum stress related fields as a function of staggering. if (present(taux) .or. present(tauy) .or. & - ((do_ustar.or.do_gustless) .and. .not.associated(IOB%stress_mag)) ) then + ((do_ustar .or. do_tau_mag .or. do_gustless) .and. .not.associated(IOB%stress_mag)) ) then if (wind_stagger == BGRID_NE) then taux_in_B(:,:) = 0.0 ; tauy_in_B(:,:) = 0.0 if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then do J=js,je ; do I=is,ie - taux_in_B(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - tauy_in_B(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + taux_in_B(I,J) = IOB%u_flux(i-i0,j-j0) * stress_conversion + tauy_in_B(I,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion enddo ; enddo endif @@ -871,13 +1006,13 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux).and.present(tauy)) then do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & taux(I,j) = (G%mask2dBu(I,J)*taux_in_B(I,J) + G%mask2dBu(I,J-1)*taux_in_B(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & tauy(i,J) = (G%mask2dBu(I,J)*tauy_in_B(I,J) + G%mask2dBu(I-1,J)*tauy_in_B(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo @@ -886,8 +1021,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, taux_in_A(:,:) = 0.0 ; tauy_in_A(:,:) = 0.0 if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then do j=js,je ; do i=is,ie - taux_in_A(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - tauy_in_A(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + taux_in_A(i,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + tauy_in_A(i,j) = IOB%v_flux(i-i0,j-j0) * stress_conversion enddo ; enddo endif @@ -899,14 +1034,14 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & taux(I,j) = (G%mask2dT(i,j)*taux_in_A(i,j) + G%mask2dT(i+1,j)*taux_in_A(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo ; endif if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & tauy(i,J) = (G%mask2dT(i,j)*tauy_in_A(i,j) + G%mask2dT(i,J+1)*tauy_in_A(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo ; endif @@ -915,8 +1050,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, taux_in_C(:,:) = 0.0 ; tauy_in_C(:,:) = 0.0 if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then do j=js,je ; do i=is,ie - taux_in_C(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - tauy_in_C(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + taux_in_C(I,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + tauy_in_C(i,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion enddo ; enddo endif @@ -934,38 +1069,41 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif ! endif for extracting wind stress fields with various staggerings endif - if (do_ustar .or. do_gustless) then + if (do_ustar .or. do_tau_mag .or. do_gustless) then ! Set surface friction velocity directly or as a function of staggering. ! ustar is required for the bulk mixed layer formulation and other turbulent mixing ! parametizations. The background gustiness (for example with a relatively small value ! of 0.02 Pa) is intended to give reasonable behavior in regions of very weak winds. if (associated(IOB%stress_mag)) then - if (do_ustar) then ; do j=js,je ; do i=is,ie + if (do_ustar .or. do_tau_mag) then ; do j=js,je ; do i=is,ie gustiness = CS%gust_const if (CS%read_gust_2d) then if ((wind_stagger == CGRID_NE) .or. & - ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & + ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0.0)) .or. & ((wind_stagger == BGRID_NE) .and. & (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0)) ) & gustiness = CS%gust(i,j) endif - ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*IOB%stress_mag(i-i0,j-j0)) + if (do_tau_mag) & + mag_tau(i,j) = gustiness + US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0) + if (do_ustar) & + ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(IOB%stress_mag(i-i0,j-j0) / CS%Rho0) + gustless_ustar(i,j) = sqrt(US%Pa_to_RLZ_T2*US%L_to_Z*IOB%stress_mag(i-i0,j-j0) / CS%Rho0) enddo ; enddo ; endif else if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = sqrt(Irho0 * IOB%stress_mag(i-i0,j-j0)) + gustless_ustar(i,j) = sqrt(IRho0 * US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif endif elseif (wind_stagger == BGRID_NE) then do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_in_B(I,J)**2 + tauy_in_B(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_in_B(I-1,J-1)**2 + tauy_in_B(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_in_B(I,J-1)**2 + tauy_in_B(I,J-1)**2) + & @@ -973,32 +1111,34 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) - if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(tau_mag / CS%Rho0) + if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (CS%answer_date < 20190101) then + if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif enddo ; enddo elseif (wind_stagger == AGRID) then do j=js,je ; do i=is,ie tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2) gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) - if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(tau_mag / CS%Rho0) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) + if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (CS%answer_date < 20190101) then + if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif enddo ; enddo else ! C-grid wind stresses. do j=js,je ; do i=is,ie taux2 = 0.0 ; tauy2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*taux_in_C(I-1,j)**2 + G%mask2dCu(I,j)*taux_in_C(I,j)**2) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*tauy_in_C(i,J-1)**2 + G%mask2dCv(i,J)*tauy_in_C(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) tau_mag = sqrt(taux2 + tauy2) @@ -1006,11 +1146,12 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, gustiness = CS%gust_const if (CS%read_gust_2d) gustiness = CS%gust(i,j) - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) - if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(tau_mag / CS%Rho0) + if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (CS%answer_date < 20190101) then + if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif enddo ; enddo endif ! endif for wind friction velocity fields @@ -1025,38 +1166,40 @@ end subroutine extract_IOB_stresses !! - hflx_adj (Heat flux into the ocean [W m-2]) !! - sflx_adj (Salt flux into the ocean [kg salt m-2 s-1]) !! - prcme_adj (Fresh water flux into the ocean [kg m-2 s-1]) -subroutine apply_flux_adjustments(G, CS, Time, fluxes) +subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(forcing), intent(inout) :: fluxes !< Surface fluxes structure ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Various fluxes at h points [W m-2] or [kg m-2 s-1] + real, dimension(G%isc:G%iec,G%jsc:G%jec) :: temp_at_h ! Various fluxes at h points + ! [Q R Z T-1 ~> W m-2] or [R Z T-1 ~> kg m-2 s-1] integer :: isc, iec, jsc, jec, i, j logical :: overrode_h 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) + call data_override(G%Domain, 'hflx_adj', temp_at_h, Time, override=overrode_h, & + scale=US%W_m2_to_QRZ_T) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j) * G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) - overrode_h = .false. - call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + call data_override(G%Domain, 'sflx_adj', temp_at_h, Time, override=overrode_h, & + scale=US%kg_m2s_to_RZ_T) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j) * G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) - overrode_h = .false. - call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + call data_override(G%Domain, 'prcme_adj', temp_at_h, Time, override=overrode_h, & + scale=US%kg_m2s_to_RZ_T) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) @@ -1069,18 +1212,22 @@ end subroutine apply_flux_adjustments !! Available adjustments are: !! - taux_adj (Zonal wind stress delta, positive to the east [Pa]) !! - tauy_adj (Meridional wind stress delta, positive to the north [Pa]) -subroutine apply_force_adjustments(G, CS, Time, forces) +subroutine apply_force_adjustments(G, US, CS, Time, forces) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points [Pa] - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points [Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points [R Z L T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points [R Z L T-2 ~> Pa] integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + real :: dLonDx, dLonDy ! The change in longitude across the cell in the x- and y-directions [degrees_E] + real :: rDlon ! The magnitude of the change in longitude [degrees_E] and then its inverse [degrees_E-1] + real :: cosA, sinA ! The cosine and sine of the angle between the grid and true north [nondim] + real :: zonal_tau, merid_tau ! True zonal and meridional wind stresses [R Z L T-2 ~> Pa] logical :: overrode_x, overrode_y isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec @@ -1088,8 +1235,10 @@ subroutine apply_force_adjustments(G, CS, Time, forces) tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged overrode_x = .false. ; overrode_y = .false. - call data_override('OCN', 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x) - call data_override('OCN', 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y) + call data_override(G%Domain, 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, & + override=overrode_x, scale=US%Pa_to_RLZ_T2) + call data_override(G%Domain, 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, & + override=overrode_y, scale=US%Pa_to_RLZ_T2) if (overrode_x .or. overrode_y) then if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& @@ -1143,7 +1292,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart !> Initialize the surface forcing, including setting parameters and allocating permanent memory. -subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) +subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1152,13 +1301,25 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) !! diagnostic output type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module + integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds + !! that are being provided in calls to update_ocean_model ! Local variables - real :: utide ! The RMS tidal velocity [m s-1]. - type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags - logical :: default_2018_answers + real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. + real :: Flux_const_dflt ! A default piston velocity for restoring surface properties [m day-1] + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq + real :: rho_TKE_tidal ! The constant bottom density used to translate tidal amplitudes into the + ! tidal bottom TKE input used with INT_TIDE_DISSIPATION [R ~> kg m-3] + logical :: new_sim ! False if this simulation was started from a restart file + ! or other equivalent files. + logical :: iceberg_flux_diags ! If true, diagnostics of fluxes from icebergs are available. + logical :: fix_ustar_gustless_bug ! If false, include a bug using an older run-time parameter. + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. type(time_type) :: Time_frc + type(directories) :: dirs ! A structure containing relevant directory paths and input filenames. character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1184,7 +1345,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call write_version_number(version) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & @@ -1193,24 +1354,32 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, mdl, "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + CS%nonBous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) + "The latent heat of fusion.", units="J/kg", default=hlf, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & - "The latent heat of fusion.", units="J/kg", default=hlv) + "The latent heat of fusion.", units="J/kg", default=hlv, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "MAX_P_SURF", CS%max_p_surf, & "The maximum surface pressure that can be exerted by the "//& "atmosphere and floating sea-ice or ice shelves. This is "//& "needed because the FMS coupling structure does not "//& "limit the water that can be frozen out of the ocean and "//& "the ice-ocean heat fluxes are treated explicitly. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "RESTORE_SALINITY", CS%restore_salt, & "If true, the coupled driver will add a globally-balanced "//& "fresh-water flux that drives sea-surface salinity "//& @@ -1237,7 +1406,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.true.) + "the net fresh-water.", default=.false.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& @@ -1259,26 +1428,45 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "the ocean dynamics. The actual net mass source may differ "//& "due to internal corrections.", default=.false.) - call get_param(param_file, mdl, "WIND_STAGGER", 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 - 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 = "// & - trim(stagger)//" is invalid.") ; endif + if (present(wind_stagger)) then + 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 + call log_param(param_file, mdl, "WIND_STAGGER", stagger, & + "The staggering of the input wind stress field "//& + "from the coupler that is actually used.") + CS%wind_stagger = wind_stagger + else + call get_param(param_file, mdl, "WIND_STAGGER", 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 + 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 = "// & + trim(stagger)//" is invalid.") ; endif + endif + call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) + "production runs.", units="nondim", default=1.0) if (CS%restore_salt) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + call get_param(param_file, mdl, "FLUXCONST", Flux_const_dflt, & + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", default=0.0) + call get_param(param_file, mdl, "FLUXCONST_SALT", CS%Flux_const_salt, & + "The constant that relates the restoring surface salt fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", default=Flux_const_dflt, scale=US%m_to_Z*US%T_to_s) + ! Finish converting CS%Flux_const_salt from m day-1 to [Z T-1 ~> m s-1]. Ideally this would be + ! included in the scale factors above, but doing so would change answers because a/b /= a*(1/b). + CS%Flux_const_salt = CS%Flux_const_salt / 86400.0 call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1286,17 +1474,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "The name of the surface salinity variable to read from "//& "SALT_RESTORE_FILE for restoring salinity.", & default="salt") -! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & "If true, the restoring of salinity is applied as a salt "//& "flux instead of as a freshwater flux.", default=.false.) call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0) - call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & - CS%mask_srestore_under_ice, & + units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", CS%mask_srestore_under_ice, & "If true, disables SSS restoring under sea-ice based on a frazil "//& "criteria (SST<=Tf). Only used when RESTORE_SALINITY is True.", & default=.false.) @@ -1322,11 +1507,17 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) endif if (CS%restore_temp) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + call get_param(param_file, mdl, "FLUXCONST", Flux_const_dflt, & + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", default=0.0) + call get_param(param_file, mdl, "FLUXCONST_TEMP", CS%Flux_const_temp, & + "The constant that relates the restoring surface temperature fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", default=Flux_const_dflt, scale=US%m_to_Z*US%T_to_s) + ! Finish converting CS%Flux_const_temp from [m day-1] to [Z T-1 ~> m s-1]. Ideally this would be + ! included in the scale factors above, but doing so would change answers because a/b /= a*(1/b). + CS%Flux_const_temp = CS%Flux_const_temp / 86400.0 call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") @@ -1334,22 +1525,36 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "The name of the surface temperature variable to read from "//& "SST_RESTORE_FILE for restoring sst.", & default="temp") - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & "The maximum sst difference used in restoring terms.", & - units="degC ", default=999.0) + units="degC ", default=999.0, scale=US%degC_to_C) call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & "If true, read a file (temp_restore_mask) containing "//& "a mask for SST restoring.", default=.false.) + call get_param(param_file, mdl, "SPEAR_ECDA_SST_RESTORE_TFREEZE", CS%trestore_SPEAR_ECDA, & + "If true, modify SST restoring field using SSS state. This only modifies the "//& + "restoring data that is within 0.0001degC of -1.8degC.", default=.false.) + else + CS%trestore_SPEAR_ECDA = .false. ! Needed to toggle logging of SPEAR_DTFREEZE_DS endif - -! Optionally read tidal amplitude from input file [m s-1] on model grid. -! Otherwise use default tidal amplitude for bottom frictionally-generated -! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of -! work done against tides globally using OSU tidal amplitude. + call get_param(param_file, mdl, "SPEAR_DTFREEZE_DS", CS%SPEAR_dTf_dS, & + "The derivative of the freezing temperature with salinity.", & + units="degC ppt-1", default=-0.054, scale=US%degC_to_C*US%S_to_ppt, & + do_not_log=.not.CS%trestore_SPEAR_ECDA) + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=.not.(CS%restore_temp.or.CS%restore_salt)) + + ! Optionally read tidal amplitude from input file [Z T-1 ~> m s-1] on model grid. + ! Otherwise use default tidal amplitude for bottom frictionally-generated + ! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of + ! work done against tides globally using OSU tidal amplitude. + ! Note that the slightly unusual length scaling is deliberate, because the tidal + ! amplitudes are used to set the friction velocity. call get_param(param_file, mdl, "CD_TIDES", CS%cd_tides, & "The drag coefficient that applies to the tides.", & units="nondim", default=1.0e-4) @@ -1365,53 +1570,92 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) else call get_param(param_file, mdl, "UTIDE", CS%utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) endif + call get_param(param_file, mdl, "TKE_TIDAL_RHO", rho_TKE_tidal, & + "The constant bottom density used to translate tidal amplitudes into the tidal "//& + "bottom TKE input used with INT_TIDE_DISSIPATION.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=.not.(CS%read_TIDEAMP.or.(CS%utide>0.0))) call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) if (CS%read_TIDEAMP) then TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1) + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(TideAmp_file, 'tideamp', CS%TKE_tidal, G%Domain, & + rescale=US%m_to_Z*US%T_to_s) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied - utide=CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + utide = CS%utide + CS%TKE_tidal(i,j) = rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif - call time_interp_external_init + call time_interp_external_init() ! Optionally read a x-y gustiness field in place of a global constant. call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& - "variable gustiness.") + "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1) ! units should be Pa + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(gust_file, 'gustiness', CS%gust, G%Domain, & + rescale=US%Pa_to_RLZ_T2) ! units in file should be [Pa] + endif + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "SURFACE_FORCING_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the gustiness "//& + "calculations. Values below 20190101 recover the answers from the end "//& + "of 2018, while higher values use a simpler expression to calculate gustiness.", & + default=default_answer_date) + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & + "If true correct a bug in the time-averaging of the gustless wind friction velocity", & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug endif - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) - call get_param(param_file, mdl, "SURFACE_FORCING_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use a simpler expression to calculate gustiness.", & - default=default_2018_answers) + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) + ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & @@ -1421,18 +1665,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%rigid_sea_ice) then call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + units="m s-2", default=9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & "A typical density of sea ice, used with the kinematic "//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) + "viscosity, when USE_RIGID_SEA_ICE is true.", & + units="kg m-3", default=900.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & "The mass of sea-ice per unit area at which the sea-ice "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & @@ -1445,11 +1690,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "If true, allows flux adjustments to specified via the "//& "data_table using the component name 'OCN'.", default=.false.) - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + call get_param(param_file, mdl, "CHECK_NO_LAND_FLUXES", CS%check_no_land_fluxes, & + "If true, checks that values from IOB fluxes are zero "//& + "above land points (i.e. G%mask2dT = 0).", default=.false., & + debuggingParam=.true.) + + call data_override_init(G%Domain) if (CS%restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) + CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, MOM_domain=G%Domain) call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' @@ -1459,7 +1709,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) + CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, MOM_domain=G%Domain) call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' @@ -1485,7 +1735,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) endif endif -!#CTRL# call controlled_forcing_init(Time, G, param_file, diag, CS%ctrl_forcing_CSp) +!#CTRL# call controlled_forcing_init(Time, G, US, param_file, diag, CS%ctrl_forcing_CSp) call user_revise_forcing_init(param_file, CS%urf_CS) @@ -1510,7 +1760,7 @@ subroutine surface_forcing_end(CS, fluxes) end subroutine surface_forcing_end -!> Write out a set of messages with checksums of the fields in an ice_ocen_boundary type +!> Write out a set of messages with checksums of the fields in an ice_ocean_boundary type subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) character(len=*), intent(in) :: id !< An identifying string for this call @@ -1518,36 +1768,75 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) type(ice_ocean_boundary_type), & intent(in) :: iobt !< An ice-ocean boundary type with fluxes to drive the !! ocean in a coupled model whose checksums are reported - integer :: n,m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ', mpp_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ', mpp_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ', mpp_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ', mpp_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ', mpp_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%lw_flux ', mpp_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir', mpp_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif', mpp_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir', mpp_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif', mpp_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ', mpp_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ', mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%runoff ', mpp_chksum( iobt%runoff ) - write(outunit,100) 'iobt%calving ', mpp_chksum( iobt%calving ) - write(outunit,100) 'iobt%p ', mpp_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + root = is_root_pe() + outunit = stdout_if_root() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + 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%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 + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%runoff ) ; if (root) write(outunit,100) 'iobt%runoff ', chks + chks = field_chksum( iobt%calving ) ; if (root) write(outunit,100) 'iobt%calving ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif + if (associated(iobt%excess_salt)) then + chks = field_chksum( iobt%excess_salt ) ; if (root) write(outunit,100) 'iobt%excess_salt ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') end subroutine ice_ocn_bnd_type_chksum -end module MOM_surface_forcing +!> Check the values passed by IOB over land are zero +subroutine check_mask_val_consistency(val, mask, i, j, varname, G) + + real, intent(in) :: val !< value of flux/variable passed by IOB [various] + real, intent(in) :: mask !< value of ocean mask [nondim] + integer, intent(in) :: i !< model grid cell indices + integer, intent(in) :: j !< model grid cell indices + character(len=*), intent(in) :: varname !< variable name + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + ! Local variables + character(len=48) :: ci, cj !< model local grid cell indices as strings + character(len=48) :: ciglo, cjglo !< model global grid cell indices as strings + character(len=48) :: cval !< value to be displayed + character(len=256) :: error_message !< error message to be displayed + + if ((mask == 0.) .and. (val /= 0.)) then + write(ci, '(I8)') i + write(cj, '(I8)') j + write(ciglo, '(I8)') i + G%HI%idg_offset + write(cjglo, '(I8)') j + G%HI%jdg_offset + write(cval, '(E22.16)') val + error_message = "MOM_surface_forcing: found non-zero value (="//trim(cval)//") over land "//& + "for variable "//trim(varname)//" at local point (i, j) = ("//trim(ci)//", "//trim(cj)//& + ", global point (iglo, jglo) = ("//trim(ciglo)//", "//trim(cjglo)//")" + call MOM_error(WARNING, error_message) + endif + +end subroutine + +end module MOM_surface_forcing_gfdl diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 similarity index 70% rename from config_src/coupled_driver/ocean_model_MOM.F90 rename to config_src/drivers/FMS_cap/ocean_model_MOM.F90 index f9b84a97e1..615d71e4e5 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -15,13 +15,20 @@ module ocean_model_mod use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart +use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end -use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE -use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_domains, only : MOM_domain_type, domain2d, clone_MOM_domain, get_domain_extent +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE, TO_ALL, Omit_Corners use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type use MOM_forcing_type, only : forcing, mech_forcing, allocate_forcing_type use MOM_forcing_type, only : fluxes_accumulate, get_net_mass_forcing @@ -29,14 +36,13 @@ module ocean_model_mod use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_io, only : write_version_number, stdout_if_root use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase -use MOM_surface_forcing, only : surface_forcing_init, convert_IOB_to_fluxes -use MOM_surface_forcing, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum -use MOM_surface_forcing, only : ice_ocean_boundary_type, surface_forcing_CS -use MOM_surface_forcing, only : forcing_save_restart +use MOM_surface_forcing_gfdl, only : surface_forcing_init, convert_IOB_to_fluxes +use MOM_surface_forcing_gfdl, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum +use MOM_surface_forcing_gfdl, only : ice_ocean_boundary_type, surface_forcing_CS +use MOM_surface_forcing_gfdl, only : forcing_save_restart 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(<) @@ -47,19 +53,12 @@ module ocean_model_mod use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS +use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data -use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain -use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux -use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_ice_shelf, only : ice_sheet_calving_to_ocean_sfc use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves +use MOM_wave_interface, only: Update_Surface_Waves +use iso_fortran_env, only : int64 #include @@ -77,6 +76,8 @@ module ocean_model_mod public ice_ocn_bnd_type_chksum public ocean_public_type_chksum public ocean_model_data_get +public get_ocean_grid +public ocean_model_get_UV_surf !> This interface extracts a named scalar field or array from the ocean surface or public type interface ocean_model_data_get @@ -87,7 +88,7 @@ module ocean_model_mod !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence -!! the persistnce of things like the cutsy element name "avg_kount". +!! the persistence of things like the cutesy element name "avg_kount". type, public :: ocean_public_type type(domain2d) :: Domain !< The domain for the surface fields. logical :: is_ocean_pe !< .true. on processors that run the ocean model. @@ -105,21 +106,26 @@ module ocean_model_mod !! points of the two velocity components. Valid entries !! include AGRID, BGRID_NE, CGRID_NE, BGRID_SW, and CGRID_SW, !! corresponding to the community-standard Arakawa notation. - !! (These are named integers taken from mpp_parameter_mod.) + !! (These are named integers taken from the MOM_domains module.) !! Following MOM5, stagger is BGRID_NE by default when the !! ocean is initialized, but here it is set to -999 so that !! a global max across ocean and non-ocean processors can be !! used to determine its value. real, pointer, dimension(:,:) :: & - t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) - s_surf => NULL(), & !< SSS on t-cell (psu) + t_surf => NULL(), & !< SST on t-cell [degrees Kelvin] + s_surf => NULL(), & !< SSS on t-cell [ppt] u_surf => NULL(), & !< i-velocity at the locations indicated by stagger [m s-1]. v_surf => NULL(), & !< j-velocity at the locations indicated by stagger [m s-1]. sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, !! i.e. dzt(1) + eta_t + patm/rho0/grav [m] frazil =>NULL(), & !< Accumulated heating [J m-2] from frazil !! formation in the ocean. - area => NULL() !< cell area of the ocean surface [m2]. + melt_potential => NULL(), & !< Instantaneous heat used to melt sea ice [J m-2]. + OBLD => NULL(), & !< Ocean boundary layer depth [m]. + area => NULL(), & !< cell area of the ocean surface [m2]. + calving => NULL(), &!< The mass per unit area of the ice shelf to convert to + !! bergs [kg m-2]. + calving_hflx => NULL() !< Calving heat flux [W m-2]. type(coupler_2d_bc_type) :: fields !< A structure that may contain named !! arrays of tracer-related surface fields. integer :: avg_kount !< A count of contributions to running @@ -153,8 +159,10 @@ module ocean_model_mod logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the !! ocean dynamics and forcing fluxes. - real :: press_to_z !< A conversion factor between pressure and ocean - !! depth in m, usually 1/(rho_0*g) [m Pa-1]. + real :: press_to_z !< A conversion factor between pressure and ocean depth, + !! usually 1/(rho_0*g) [Z T2 R-1 L-2 ~> m Pa-1]. + logical :: calve_ice_shelf_bergs = .false. !< If true, bergs are initialized according to + !! ice shelf flux through the ice front real :: C_p !< The heat capacity of seawater [J degC-1 kg-1]. logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode !! with the barotropic and baroclinic dynamics, thermodynamics, @@ -169,21 +177,21 @@ module ocean_model_mod !! If false, the two phases are advanced with !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. - real :: dt !< (baroclinic) dynamics time step [s] - real :: dt_therm !< thermodynamics time step [s] + real :: dt !< (baroclinic) dynamics time step [T ~> s] + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. type(directories) :: dirs !< A structure containing several relevant directory paths. - type(mech_forcing) :: forces !< A structure with the driving mechanical surface forces - type(forcing) :: fluxes !< A structure containing pointers to - !! the thermodynamic ocean forcing fields. - type(forcing) :: flux_tmp !< A secondary structure containing pointers to the + type(mech_forcing) :: forces !< A structure with the driving mechanical surface forces + type(forcing) :: fluxes !< A structure containing pointers to + !! the thermodynamic ocean forcing fields. + type(forcing) :: flux_tmp !< A secondary structure containing pointers to the !! ocean forcing fields for when multiple coupled !! timesteps are taken per thermodynamic step. - type(surface) :: sfc_state !< A structure containing pointers to + type(surface) :: sfc_state !< A structure containing pointers to !! the ocean surface state fields. type(ocean_grid_type), pointer :: & grid => NULL() !< A pointer to a grid structure containing metrics @@ -194,8 +202,8 @@ module ocean_model_mod type(unit_scale_type), pointer :: & US => NULL() !< A pointer to a structure containing dimensional !! unit scaling factors. - type(MOM_control_struct), pointer :: & - MOM_CSp => NULL() !< A pointer to the MOM control structure + type(MOM_control_struct) :: MOM_CSp + !< MOM control structure type(ice_shelf_CS), pointer :: & Ice_shelf_CSp => NULL() !< A pointer to the control structure for the !! ice shelf model that couples with MOM6. This @@ -204,12 +212,9 @@ module ocean_model_mod marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. type(wave_parameters_cs), pointer :: & - Waves !< A structure containing pointers to the surface wave fields + Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -220,9 +225,9 @@ module ocean_model_mod !! for restarts and reading restart files if appropriate. !! !! This subroutine initializes both the ocean state and the ocean surface type. -!! Because of the way that indicies and domains are handled, Ocean_sfc must have +!! Because of the way that indices and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn, calve_ice_shelf_bergs) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -232,23 +237,28 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) !! contain all information about the ocean's interior state. type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. + integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds that are + !! being provided in calls to update_ocean_model type(coupler_1d_bc_type), & optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. + logical, optional, intent(in) :: calve_ice_shelf_bergs !< If true, track ice shelf flux through a + !! static ice shelf, so that it can be converted into icebergs ! Local variables - real :: Rho0 ! The Boussinesq ocean density [kg m-3]. - real :: G_Earth ! The gravitational acceleration [m s-2]. - real :: HFrz !< If HFrz > 0 (m), melt potential will be computed. + real :: Rho0 ! The Boussinesq ocean density [R ~> kg m-3] + real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: HFrz !< If HFrz > 0 [Z ~> m], melt potential will be computed. !! The actual depth over which melt potential is computed will !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. - logical :: use_melt_pot!< If true, allocate melt_potential array + logical :: use_melt_pot !< If true, allocate melt_potential array + logical :: point_calving ! Equals calve_ice_shelf_bergs if calve_ice_shelf_bergs is present -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "ocean_model_init" ! This module's name. character(len=48) :: stagger ! A string indicating the staggering locations for the ! surface velocities returned to the coupler. @@ -263,16 +273,23 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) endif allocate(OS) +! allocate(OS%fluxes) +! allocate(OS%forces) +! allocate(OS%flux_tmp) + OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return OS%Time = Time_in ; OS%Time_dyn = Time_in + ! Call initialize MOM with an optional Ice Shelf CS which, if present triggers + ! initialization of ice shelf parameters and arrays. + point_calving=.false.; if (present(calve_ice_shelf_bergs)) point_calving=calve_ice_shelf_bergs call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & - diag_ptr=OS%diag, count_calls=.true.) + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + diag_ptr=OS%diag, count_calls=.true., ice_shelf_CSp=OS%ice_shelf_CSp, & + waves_CSp=OS%Waves, calve_ice_shelf_bergs=point_calving) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & - use_temp=use_temperature) - OS%fluxes%C_p = OS%C_p + C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -282,16 +299,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that "//& - "is actually used will be an integer fraction of the "//& - "forcing time-step.", units="s", fail_if_missing=.true.) + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & "The thermodynamic and tracer advection time step. "//& "Ideally DT_THERM should be an integer multiple of DT "//& "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=OS%dt) + "default DT_THERM is set to DT.", & + units="s", scale=OS%US%s_to_T, default=OS%US%T_to_s*OS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -325,10 +343,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=OS%US%kg_m3_to_R) call get_param(param_file, mdl, "G_EARTH", G_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + units="m s-2", default=9.80, scale=OS%US%m_s_to_L_T**2*OS%US%Z_to_m) call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & "If true, enables the ice shelf model.", default=.false.) @@ -336,7 +354,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_alter_ocean, & "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) - OS%press_to_z = 1.0/(Rho0*G_Earth) + OS%press_to_z = 1.0 / (Rho0*G_Earth) ! 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. @@ -344,24 +362,32 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) "If HFREEZE > 0, melt potential will be computed. The actual depth "//& "over which melt potential is computed will be min(HFREEZE, OBLD), "//& "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& - "melt potential will not be computed.", units="m", default=-1.0, do_not_log=.true.) + "melt potential will not be computed.", & + units="m", default=-1.0, scale=OS%US%m_to_Z, do_not_log=.true.) - if (HFrz .gt. 0.0) then + if (HFrz > 0.0) then use_melt_pot=.true. else use_melt_pot=.false. endif + !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) - call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & - OS%forcing_CSp) + if (present(wind_stagger)) then + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp, wind_stagger) + else + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp) + endif if (OS%use_ice_shelf) then - call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + call initialize_ice_shelf_fluxes(OS%ice_shelf_CSp, OS%grid, OS%US, OS%fluxes) + call initialize_ice_shelf_forces(OS%ice_shelf_CSp, OS%grid, OS%US, OS%forces) endif + if (OS%icebergs_alter_ocean) then call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) if (.not. OS%use_ice_shelf) & @@ -370,20 +396,12 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) - if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - if (associated(OS%grid%Domain%maskmap)) then - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, maskmap=OS%grid%Domain%maskmap, & - gas_fields_ocn=gas_fields_ocn) - else - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, gas_fields_ocn=gas_fields_ocn) - endif + call initialize_ocean_public_type(OS%grid%Domain, Ocean_sfc, OS%diag, & + gas_fields_ocn=gas_fields_ocn) ! This call can only occur here if the coupler_bc_type variables have been ! initialized already using the information from gas_fields_ocn. @@ -393,8 +411,15 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) + + endif + if (present(calve_ice_shelf_bergs)) then + if (calve_ice_shelf_bergs) then + call convert_shelf_state_to_ocean_type(Ocean_sfc, OS%Ice_shelf_CSp, OS%US) + OS%calve_ice_shelf_bergs=.true. + endif endif call close_param_file(param_file) @@ -450,12 +475,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! internal modules. type(time_type) :: Time1 ! The value of the ocean model's time at the start of a call to step_MOM. integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocean boundary type. - real :: weight ! Flux accumulation weight of the current fluxes. - real :: dt_coupling ! The coupling time step [s]. - real :: dt_therm ! A limited and quantized version of OS%dt_therm [s]. - real :: dt_dyn ! The dynamics time step [s]. - real :: dtdia ! The diabatic time step [s]. - real :: t_elapsed_seg ! The elapsed time in this update segment [s]. + real :: weight ! Flux accumulation weight of the current fluxes [nondim]. + real :: dt_coupling ! The coupling time step [T ~> s]. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s]. + real :: dt_dyn ! The dynamics time step [T ~> s]. + real :: dtdia ! The diabatic time step [T ~> s]. + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s]. integer :: n ! The internal iteration counter. integer :: nts ! The number of baroclinic dynamics time steps in a thermodynamic step. integer :: n_max ! The number of calls to step_MOM dynamics in this call to update_ocean_model. @@ -467,7 +492,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda integer :: is, ie, js, je call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") - dt_coupling = time_type_to_real(Ocean_coupling_time_step) + dt_coupling = OS%US%s_to_T*time_type_to_real(Ocean_coupling_time_step) if (.not.associated(OS)) then call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & @@ -498,14 +523,13 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) ! Translate Ice_ocean_boundary into fluxes and forces. - call mpp_get_compute_domain(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), & - index_bnds(3), index_bnds(4)) + call get_domain_extent(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), index_bnds(3), index_bnds(4)) if (do_dyn) then call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time_dyn, OS%grid, OS%US, & OS%forcing_CSp, dt_forcing=dt_coupling, reset_avg=OS%fluxes%fluxes_used) if (OS%use_ice_shelf) & - call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) if (OS%icebergs_alter_ocean) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) @@ -513,38 +537,35 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (do_thermo) then if (OS%fluxes%fluxes_used) then - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) ! Add ice shelf fluxes if (OS%use_ice_shelf) & call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & - call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) ! Here weight=1, so just store the current fluxes call disable_averaging(OS%diag) #endif - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = dt_coupling else ! The previous fluxes have not been used yet, so translate the input fluxes ! into a temporary type and then accumulate them in about 20 lines. OS%flux_tmp%C_p = OS%fluxes%C_p - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) if (OS%use_ice_shelf) & - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time,dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & - call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) - call fluxes_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) + call fluxes_accumulate(OS%flux_tmp, OS%fluxes, OS%grid, weight) #ifdef _USE_GENERIC_TRACER ! Incorporate the current tracer fluxes into the running averages call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) @@ -554,17 +575,17 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! The net mass forcing is not currently used in the MOM6 dynamics solvers, so this is may be unnecessary. if (do_dyn .and. associated(OS%forces%net_mass_src) .and. .not.OS%forces%net_mass_src_set) & - call get_net_mass_forcing(OS%fluxes, OS%grid, OS%forces%net_mass_src) + call get_net_mass_forcing(OS%fluxes, OS%grid, OS%US, OS%forces%net_mass_src) if (OS%use_waves .and. do_thermo) then ! For now, the waves are only updated on the thermodynamics steps, because that is where ! the wave intensities are actually used to drive mixing. At some point, the wave updates ! might also need to become a part of the ocean dynamics, according to B. Reichl. - call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves, OS%forces) endif if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif Time_thermo_start = OS%Time @@ -575,10 +596,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + if (present(cycle_length)) then + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & - start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & + start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=OS%US%s_to_T*cycle_length, & reset_therm=Ocn_fluxes_used) + else + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & + start_cycle=start_cycle, end_cycle=end_cycle, reset_therm=Ocn_fluxes_used) + endif elseif (OS%single_step_call) then call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else ! Step both the dynamics and thermodynamics with separate calls. @@ -627,7 +654,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. - Time1 = Time1 - real_to_time(dtdia - dt_dyn) + Time1 = Time1 - real_to_time(OS%US%T_to_s*(dtdia - dt_dyn)) 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) @@ -635,7 +662,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time1 = Time_seg_start + real_to_time(t_elapsed_seg) + Time1 = Time_seg_start + real_to_time(OS%US%T_to_s*t_elapsed_seg) enddo endif @@ -646,22 +673,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (do_thermo) OS%nstep_thermo = OS%nstep_thermo + 1 if (do_dyn) then - call enable_averaging(dt_coupling, OS%Time_dyn, OS%diag) - call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time_dyn, OS%diag, OS%forcing_CSp%handles) endif if (OS%fluxes%fluxes_used .and. do_thermo) then - call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) - call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) endif ! 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) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) +! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US, & +! OS%fluxes%p_surf_full, OS%press_to_z) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) + if (OS%calve_ice_shelf_bergs) call convert_shelf_state_to_ocean_type(Ocean_sfc,OS%Ice_shelf_CSp, OS%US) Time1 = OS%Time ; if (do_dyn) Time1 = OS%Time_dyn call coupler_type_send_data(Ocean_sfc%fields, Time1) @@ -684,8 +707,8 @@ subroutine ocean_model_restart(OS, timestamp) "restart files can only be created after the buoyancy forcing is applied.") if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -693,8 +716,8 @@ subroutine ocean_model_restart(OS, timestamp) endif endif if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -726,7 +749,7 @@ end subroutine ocean_model_end subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the !! internal ocean state (in). - type(time_type), intent(in) :: Time !< The model time at this call, needed for mpp_write calls. + type(time_type), intent(in) :: Time !< The model time at this call, needed for writing files. character(len=*), optional, intent(in) :: directory !< An optional directory into which to !! write these restart files. character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time-stamp) @@ -747,27 +770,22 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - end subroutine ocean_model_save_restart !> Initialize the public ocean type -subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & - gas_fields_ocn) - type(domain2D), intent(in) :: input_domain !< The ocean model domain description +subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, gas_fields_ocn) + type(MOM_domain_type), intent(in) :: input_domain !< The ocean model domain description type(ocean_public_type), intent(inout) :: Ocean_sfc !< A structure containing various publicly - !! visible ocean surface properties after initialization, whose - !! elements are allocated here. - type(diag_ctrl), intent(in) :: diag !< A structure that regulates diagnsotic output - logical, dimension(:,:), & - optional, intent(in) :: maskmap !< A mask indicating which virtual processors - !! are actually in use. If missing, all are used. + !! visible ocean surface properties after + !! initialization, whose elements are allocated here. + type(diag_ctrl), intent(in) :: diag !< A structure that regulates diagnostic output type(coupler_1d_bc_type), & optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate @@ -775,34 +793,37 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, !! tracer fluxes. integer :: xsz, ysz, layout(2) - ! ice-ocean-boundary fields are always allocated using absolute indicies + ! ice-ocean-boundary fields are always allocated using absolute indices ! and have no halos. integer :: isc, iec, jsc, jec - call mpp_get_layout(input_domain,layout) - call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) - if (PRESENT(maskmap)) then - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) - else - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) - endif - call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) + call clone_MOM_domain(input_domain, Ocean_sfc%Domain, halo_size=0, symmetric=.false.) + + call get_domain_extent(Ocean_sfc%Domain, isc, iec, jsc, jec) allocate ( Ocean_sfc%t_surf (isc:iec,jsc:jec), & Ocean_sfc%s_surf (isc:iec,jsc:jec), & Ocean_sfc%u_surf (isc:iec,jsc:jec), & Ocean_sfc%v_surf (isc:iec,jsc:jec), & Ocean_sfc%sea_lev(isc:iec,jsc:jec), & + Ocean_sfc%calving(isc:iec,jsc:jec), & + Ocean_sfc%calving_hflx(isc:iec,jsc:jec), & Ocean_sfc%area (isc:iec,jsc:jec), & + Ocean_sfc%melt_potential(isc:iec,jsc:jec), & + Ocean_sfc%OBLD (isc:iec,jsc:jec), & Ocean_sfc%frazil (isc:iec,jsc:jec)) - Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model - Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models - Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav - Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model - Ocean_sfc%area = 0.0 + Ocean_sfc%t_surf(:,:) = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model + Ocean_sfc%s_surf(:,:) = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models + Ocean_sfc%u_surf(:,:) = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%v_surf(:,:) = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%sea_lev(:,:) = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav + Ocean_sfc%calving(:,:) = 0.0 ! time accumulated ice sheet calving (kg m-2) passed to ice model + Ocean_sfc%calving_hflx(:,:) = 0.0 ! time accumulated ice sheet calving heat flux (W m-2) passed to ice model + Ocean_sfc%frazil(:,:) = 0.0 ! time accumulated frazil (J/m^2) passed to ice model + Ocean_sfc%melt_potential(:,:) = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model + Ocean_sfc%OBLD(:,:) = 0.0 ! ocean boundary layer depth (m) + Ocean_sfc%area(:,:) = 0.0 Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics if (present(gas_fields_ocn)) then @@ -816,8 +837,8 @@ end subroutine initialize_ocean_public_type !! surface state variable. This may eventually be folded into the MOM !! code that calculates the surface state in the first place. !! Note the offset in the arrays because the ocean_data_type has no -!! halo points in its arrays and always uses absolute indicies. -subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z) +!! halo points in its arrays and always uses absolute indices. +subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_to_z) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(ocean_public_type), & @@ -825,11 +846,11 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z !! visible ocean surface fields, whose elements !! have their data set here. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, optional, intent(in) :: patm(:,:) !< The pressure at the ocean surface [Pa]. - real, optional, intent(in) :: press_to_z !< A conversion factor between pressure and - !! ocean depth in m, usually 1/(rho_0*g) [m Pa-1]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: patm(:,:) !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + real, optional, intent(in) :: press_to_z !< A conversion factor between pressure and ocean + !! depth, usually 1/(rho_0*g) [Z T2 R-1 L-2 ~> m Pa-1] ! Local variables - real :: IgR0 character(len=48) :: val_str integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd integer :: i, j, i0, j0, is, ie, js, je @@ -837,8 +858,7 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call pass_vector(sfc_state%u, sfc_state%v, G%Domain) - call mpp_get_compute_domain(Ocean_sfc%Domain, isc_bnd, iec_bnd, & - jsc_bnd, jec_bnd) + call get_domain_extent(Ocean_sfc%Domain, isc_bnd, iec_bnd, jsc_bnd, jec_bnd) if (present(patm)) then ! Check that the inidicies in patm are (isc_bnd:iec_bnd,jsc_bnd:jec_bnd). if (.not.present(press_to_z)) call MOM_error(FATAL, & @@ -849,61 +869,73 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z if (sfc_state%T_is_conT) then ! Convert the surface T from conservative T to potential T. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(sfc_state%SSS(i+i0,j+j0), & - sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0), & + US%C_to_degC*sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = US%C_to_degC*sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET enddo ; enddo endif if (sfc_state%S_is_absS) then ! Convert the surface S from absolute salinity to practical salinity. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(sfc_state%SSS(i+i0,j+j0)) + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0)) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = sfc_state%SSS(i+i0,j+j0) + Ocean_sfc%s_surf(i,j) = US%S_to_ppt*sfc_state%SSS(i+i0,j+j0) enddo ; enddo endif if (present(patm)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z - Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * (sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) + enddo ; enddo + endif + + if (allocated(sfc_state%frazil)) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) enddo ; enddo endif - if (associated(sfc_state%frazil)) then + if (allocated(sfc_state%melt_potential)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) + Ocean_sfc%melt_potential(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%melt_potential(i+i0,j+j0) + enddo ; enddo + endif + + if (allocated(sfc_state%Hml)) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%OBLD(i,j) = US%Z_to_m * sfc_state%Hml(i+i0,j+j0) enddo ; enddo endif if (Ocean_sfc%stagger == AGRID) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == BGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == CGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*sfc_state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*sfc_state%v(i+i0,J+j0) + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) enddo ; enddo else write(val_str, '(I8)') Ocean_sfc%stagger @@ -921,6 +953,24 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z end subroutine convert_state_to_ocean_type +!> Converts the ice-shelf-to-ocean calving and calving_hflx variables from the ice-shelf state (ISS) type +!! to the ocean public type +subroutine convert_shelf_state_to_ocean_type(Ocean_sfc, CS, US) + type(ocean_public_type), & + target, intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface fields, whose elements + !! have their data set here. + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd, i, j + + call get_domain_extent(Ocean_sfc%Domain, isc_bnd, iec_bnd, jsc_bnd, jec_bnd) + + call ice_sheet_calving_to_ocean_sfc(CS,US,Ocean_sfc%calving(isc_bnd:iec_bnd,jsc_bnd:jec_bnd),& + Ocean_sfc%calving_hflx(isc_bnd:iec_bnd,jsc_bnd:jec_bnd)) + +end subroutine convert_shelf_state_to_ocean_type + !> This subroutine extracts the surface properties from the ocean's internal !! state and stores them in the ocean type returned to the calling ice model. !! It has to be separate from the ocean_initialization call because the coupler @@ -938,13 +988,13 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) end subroutine ocean_model_init_sfc !> ocean_model_flux_init is used to initialize properties of the air-sea fluxes !! as determined by various run-time parameters. It can be called from -!! non-ocean PEs, or PEs that have not yet been initialzed, and it can safely +!! non-ocean PEs, or PEs that have not yet been initialized, and it can safely !! be called multiple times. subroutine ocean_model_flux_init(OS, verbosity) type(ocean_state_type), optional, pointer :: OS !< An optional pointer to the ocean state, @@ -973,7 +1023,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) type(ocean_state_type), pointer :: OS !< A structure containing the internal ocean state. !! The data in OS is intent in. integer, intent(in) :: index !< The stock index for the quantity of interest. - real, intent(out) :: value !< Sum returned for the conservation quantity of interest. + real, intent(out) :: value !< Sum returned for the conservation quantity of interest [various] integer, optional, intent(in) :: time_index !< An unused optional argument, present only for !! interfacial compatibility with other models. ! Arguments: OS - A structure containing the internal ocean state. @@ -981,24 +1031,24 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) ! (in) value - Sum returned for the conservation quantity of interest. ! (in,opt) time_index - Index for time level to use if this is necessary. - real :: salt + real :: salt ! The total salt in the ocean [kg] value = 0.0 if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return select case (index) - case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in kg. + case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in [kg]. if (OS%GV%Boussinesq) then call get_ocean_stocks(OS%MOM_CSp, mass=value, on_PE_only=.true.) else ! In non-Boussinesq mode, the mass of salt needs to be subtracted. call get_ocean_stocks(OS%MOM_CSp, mass=value, salt=salt, on_PE_only=.true.) value = value - salt endif - case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. + case (ISTOCK_HEAT) ! Return the heat content of the ocean in [J]. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) - case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in [kg]. + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on @@ -1016,45 +1066,56 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the field to extract real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain + !! cover only the computational domain [various] integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j + integer :: g_isc, g_iec, g_jsc, g_jec, g_isd, g_ied, g_jsd, g_jed, i, j if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) + ! The problem is that %areaT is on MOM domain but Ice_Ocean_Boundary%... is on a haloless domain. + ! We want to return the MOM data on the haloless (compute) domain + call get_domain_extent(OS%grid%Domain, g_isc, g_iec, g_jsc, g_jec, g_isd, g_ied, g_jsd, g_jed) g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - select case(name) - case('area') - array2D(isc:,jsc:) = OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) + case('area') + array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) + case('mask') + array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) !OR same result ! do j=g_jsc,g_jec ; do i=g_isc,g_iec ! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) ! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case default - call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) + case('t_surf') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_pme') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_runoff') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_calving') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('btfHeat') + array2D(isc:,jsc:) = 0 + case('cos_rot') + array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 + case('sin_rot') + array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 + case('s_surf') + array2D(isc:,jsc:) = Ocean%s_surf(isc:,jsc:) + case('sea_lev') + array2D(isc:,jsc:) = Ocean%sea_lev(isc:,jsc:) + case('frazil') + array2D(isc:,jsc:) = Ocean%frazil(isc:,jsc:) + case('melt_pot') + array2D(isc:,jsc:) = Ocean%melt_potential(isc:,jsc:) + case('obld') + array2D(isc:,jsc:) = Ocean%OBLD(isc:,jsc:) + case default + call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) end select end subroutine ocean_model_data2D_get @@ -1065,43 +1126,128 @@ subroutine ocean_model_data1D_get(OS, Ocean, name, value) !! internal ocean state (intent in). type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field + character(len=*), intent(in) :: name !< The name of the field to extract + real, intent(out):: value !< The value of the named field [various] if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return select case(name) case('c_p') - value = OS%C_p + value = OS%C_p case default - call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) + call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) end select end subroutine ocean_model_data1D_get -!> Write out FMS-format checsums on fields from the ocean surface state +!> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + root = is_root_pe() + outunit = stdout_if_root() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) end subroutine ocean_public_type_chksum +!> This subroutine gives a handle to the grid from ocean state +subroutine get_ocean_grid(OS, Gridp) + ! Obtain the ocean grid. + type(ocean_state_type) :: OS !< A structure containing the + !! internal ocean state + type(ocean_grid_type) , pointer :: Gridp !< The ocean's grid structure + + Gridp => OS%grid + return +end subroutine get_ocean_grid + +!> This subroutine extracts a named (u- or v-) 2-D surface current from ocean internal state +subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) + + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the current (ua or va) to extract + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain [L T-1 ~> m s-1] + integer , intent(in) :: isc !< The starting i-index of array2D + integer , intent(in) :: jsc !< The starting j-index of array2D + + type(ocean_grid_type) , pointer :: G !< The ocean's grid structure + type(surface), pointer :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + integer :: i, j, i0, j0 + integer :: is, ie, js, je + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + G => OS%grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + call get_domain_extent(Ocean%Domain, isc_bnd, iec_bnd, jsc_bnd, jec_bnd) + + i0 = is - isc_bnd ; j0 = js - jsc_bnd + + sfc_state => OS%sfc_state + + call pass_vector(sfc_state%u, sfc_state%v, G%Domain) + + select case(name) + case('ua') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dT(i+i0,j+j0) * & + 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) + enddo ; enddo + case('va') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dT(i+i0,j+j0) * & + 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) + enddo ; enddo + case('ub') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dBu(I+i0,J+j0) * & + 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) + enddo ; enddo + case('vb') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dBu(I+i0,J+j0) * & + 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) + enddo ; enddo + case('uc') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dCu(I+i0,J+j0) * sfc_state%u(I+i0,j+j0) + enddo ; enddo + case('vc') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dCv(I+i0,J+j0) * sfc_state%v(i+i0,J+j0) + enddo ; enddo + case default + call MOM_error(FATAL,'ocean_model_get_UV_surf: unknown argument name='//name) + end select + +end subroutine ocean_model_get_UV_surf + end module ocean_model_mod 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 new file mode 100644 index 0000000000..d1c46f4254 --- /dev/null +++ b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 @@ -0,0 +1,1076 @@ +!> Top-level module for the MOM6 ocean model in coupled mode. +module MOM_ocean_model_mct + +! This file is part of MOM6. See LICENSE.md for the license. + +! This is the top level module for the MOM6 ocean model. It contains routines +! for initialization, termination and update of ocean model state. This +! particular version wraps all of the calls for MOM6 in the calls that had +! been used for MOM4. +! +! This code is a stop-gap wrapper of the MOM6 code to enable it to be called +! in the same way as MOM4. + +use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end +use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization +use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized +use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart +use MOM_coms, only : field_chksum +use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging +use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields +use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing +use MOM_forcing_type, only : set_derived_forcing_fields +use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS +use MOM_string_functions, only : uppercase +use MOM_surface_forcing_mct, only : surface_forcing_init, convert_IOB_to_fluxes +use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum +use MOM_surface_forcing_mct, only : ice_ocean_boundary_type, surface_forcing_CS +use MOM_surface_forcing_mct, only : forcing_save_restart +use MOM_time_manager, only : time_type, get_time, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) +use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init +use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data +use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain +use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain +use MOM_io, only : stdout +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only : Update_Surface_Waves +use MOM_interpolate, only : time_interp_external_init + +! MCT specfic routines +use MOM_domains, only : MOM_infra_end +use iso_fortran_env, only : int64 + +#include + +#ifdef _USE_GENERIC_TRACER +use MOM_generic_tracer, only : MOM_generic_tracer_fluxes_accumulate +#endif + +implicit none ; public + +public ocean_model_init, ocean_model_end, update_ocean_model +public ocean_model_save_restart, Ocean_stock_pe +public ice_ocean_boundary_type +public ocean_model_init_sfc, ocean_model_flux_init +public ocean_model_restart +public ice_ocn_bnd_type_chksum +public ocean_public_type_chksum +public get_ocean_grid + +!> This type is used for communication with other components via the FMS coupler. +!! The element names and types can be changed only with great deliberation, hence +!! the persistnce of things like the cutsy element name "avg_kount". +type, public :: ocean_public_type + type(domain2d) :: Domain !< The domain for the surface fields. + logical :: is_ocean_pe !< .true. on processors that run the ocean model. + character(len=32) :: instance_name = '' !< A name that can be used to identify + !! this instance of an ocean model, for example + !! in ensembles when writing messages. + integer, pointer, dimension(:) :: pelist => NULL() !< The list of ocean PEs. + logical, pointer, dimension(:,:) :: maskmap =>NULL() !< A pointer to an array + !! indicating which logical processors are actually used for + !! the ocean code. The other logical processors would be all + !! land points and are not assigned to actual processors. + !! This need not be assigned if all logical processors are used. + + integer :: stagger = -999 !< The staggering relative to the tracer points + !! points of the two velocity components. Valid entries + !! include AGRID, BGRID_NE, CGRID_NE, BGRID_SW, and CGRID_SW, + !! corresponding to the community-standard Arakawa notation. + !! (These are named integers taken from mpp_parameter_mod.) + !! Following MOM5, stagger is BGRID_NE by default when the + !! ocean is initialized, but here it is set to -999 so that + !! a global max across ocean and non-ocean processors can be + !! used to determine its value. + real, pointer, dimension(:,:) :: & + t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) + s_surf => NULL(), & !< SSS on t-cell (psu) + u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. + v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. + sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, + !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) + frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil + !! formation in the ocean. + melt_potential => NULL(), & !< Instantaneous heat used to melt sea ice (in J/m^2) + area => NULL(), & !< cell area of the ocean surface, in m2. + OBLD => NULL() !< Ocean boundary layer depth, in m. + type(coupler_2d_bc_type) :: fields !< A structure that may contain named + !! arrays of tracer-related surface fields. + integer :: avg_kount !< A count of contributions to running + !! sums, used externally by the FMS coupler + !! for accumulating averages of this type. + integer, dimension(2) :: axes = 0 !< Axis numbers that are available + !! for I/O using this surface data. +end type ocean_public_type + +!> 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 ; + ! 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. + integer :: Restart_control !< An integer that is bit-tested to determine whether + !! incremental restart files are saved and whether they + !! have a time stamped name. +1 (bit 0) for generic + !! files and +2 (bit 1) for time-stamped files. A + !! restart file is saved at the end of a run segment + !! unless Restart_control is negative. + + integer :: nstep = 0 !< The number of calls to update_ocean. + logical :: use_ice_shelf !< If true, the ice shelf model is enabled. + logical :: use_waves !< If true use wave coupling. + + logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the + !! ocean dynamics and forcing fluxes. + logical :: restore_salinity !< If true, the coupled MOM driver adds a term to + !! restore salinity to a specified value. + logical :: restore_temp !< If true, the coupled MOM driver adds a term to + !! restore sst to a specified value. + real :: press_to_z !< A conversion factor between pressure and ocean + !! depth in m, usually 1/(rho_0*g), in m Pa-1. + real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. + logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode + !! with the barotropic and baroclinic dynamics, thermodynamics, + !! etc. stepped forward integrated in time. + !! If true, all of the above are bypassed with all + !! fields necessary to integrate only the tracer advection + !! and diffusion equation read in from files stored from + !! a previous integration of the prognostic model. + + logical :: single_step_call !< If true, advance the state of MOM with a single + !! step including both dynamics and thermodynamics. + !! If false, the two phases are advanced with + !! separate calls. The default is true. + ! The following 3 variables are only used here if single_step_call is false. + real :: dt !< (baroclinic) dynamics time step [T ~> s] + real :: dt_therm !< thermodynamics time step [T ~> s] + logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time + !! steps can span multiple coupled time steps. + logical :: diabatic_first !< If true, apply diabatic and thermodynamic + !! processes before time stepping the dynamics. + + type(directories) :: dirs !< A structure containing several relevant directory paths. + type(mech_forcing) :: forces !< A structure with the driving mechanical surface forces + type(forcing) :: fluxes !< A structure containing pointers to + !! the thermodynamic ocean forcing fields. + type(forcing) :: flux_tmp !< A secondary structure containing pointers to the + !! ocean forcing fields for when multiple coupled + !! timesteps are taken per thermodynamic step. + type(surface) :: sfc_state !< A structure containing pointers to + !! the ocean surface state fields. + type(ocean_grid_type), pointer :: & + grid => NULL() !< A pointer to a grid structure containing metrics + !! and related information. + type(verticalGrid_type), pointer :: & + GV => NULL() !< A pointer to a structure containing information + !! about the vertical grid. + type(unit_scale_type), pointer :: US => NULL() !< A pointer to a structure containing + !! dimensional unit scaling factors. + type(MOM_control_struct) :: MOM_CSp + !< MOM control structure + type(ice_shelf_CS), pointer :: & + Ice_shelf_CSp => NULL() !< A pointer to the control structure for the + !! ice shelf model that couples with MOM6. This + !! is null if there is no ice shelf. + type(marine_ice_CS), pointer :: & + marine_ice_CSp => NULL() !< A pointer to the control structure for the + !! marine ice effects module. + type(wave_parameters_cs), pointer :: & + Waves => NULL() !< A pointer to the surface wave control structure + type(surface_forcing_CS), pointer :: & + forcing_CSp => NULL() !< A pointer to the MOM forcing control structure + type(diag_ctrl), pointer :: & + diag => NULL() !< A pointer to the diagnostic regulatory structure +end type ocean_state_type + +contains + +!> ocean_model_init initializes the ocean model, including registering fields +!! for restarts and reading restart files if appropriate. +!! +!! This subroutine initializes both the ocean state and the ocean surface type. +!! Because of the way that indicies and domains are handled, Ocean_sfc must have +!! been used in a previous call to initialize_ocean_type. +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) + type(ocean_public_type), target, & + intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface properties after initialization, + !! the data in this type is intent out. + type(ocean_state_type), pointer :: OS !< A structure whose internal + !! contents are private to ocean_model_mod that may be used to + !! contain all information about the ocean's interior state. + type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar + type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. + type(coupler_1d_bc_type), & + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the + !! ocean and surface-ice fields that will participate + !! in the calculation of additional gas or other + !! tracer fluxes, and can be used to spawn related + !! internal variables in the ice model. + character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read + ! Local variables + real :: Rho0 ! The Boussinesq ocean density, in kg m-3. + real :: G_Earth ! The gravitational acceleration in m s-2. + real :: HFrz !< If HFrz > 0 (m), melt potential will be computed. + !! The actual depth over which melt potential is computed will + !! min(HFrz, OBLD), where OBLD is the boundary layer depth. + !! If HFrz <= 0 (default), melt potential will not be computed. + logical :: use_melt_pot!< If true, allocate melt_potential array + +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "ocean_model_init" ! This module's name. + character(len=48) :: stagger + integer :: secs, days + type(param_file_type) :: param_file !< A structure to parse for run-time parameters + logical :: use_temperature + + call callTree_enter("ocean_model_init(), MOM_ocean_model_mct.F90") + if (associated(OS)) then + call MOM_error(WARNING, "ocean_model_init called with an associated "// & + "ocean_state_type structure. Model is already initialized.") + return + endif + allocate(OS) + + OS%is_ocean_pe = Ocean_sfc%is_ocean_pe + if (.not.OS%is_ocean_pe) return + + call time_interp_external_init + + OS%Time = Time_in + call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + input_restart_file=input_restart_file, & + diag_ptr=OS%diag, count_calls=.true., waves_CSp=OS%Waves) + call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & + C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "SINGLE_STEPPING_CALL", OS%single_step_call, & + "If true, advance the state of MOM with a single step "//& + "including both dynamics and thermodynamics. If false, "//& + "the two phases are advanced with separate calls.", default=.true.) + call get_param(param_file, mdl, "DT", OS%dt, & + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) + call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & + "The thermodynamic and tracer advection time step. "//& + "Ideally DT_THERM should be an integer multiple of DT "//& + "and less than the forcing or coupling time-step, unless "//& + "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& + "can be an integer multiple of the coupling timestep. By "//& + "default DT_THERM is set to DT.", & + units="s", scale=OS%US%s_to_T, default=OS%US%T_to_s*OS%dt) + call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & + "If true, the MOM will take thermodynamic and tracer "//& + "timesteps that can be longer than the coupling timestep. "//& + "The actual thermodynamic timestep that is used in this "//& + "case is the largest integer multiple of the coupling "//& + "timestep that is less than or equal to DT_THERM.", default=.false.) + call get_param(param_file, mdl, "DIABATIC_FIRST", OS%diabatic_first, & + "If true, apply diabatic and thermodynamic processes, "//& + "including buoyancy forcing and mass gain or loss, "//& + "before stepping the dynamics forward.", default=.false.) + + call get_param(param_file, mdl, "RESTART_CONTROL", OS%Restart_control, & + "An integer whose bits encode which restart files are "//& + "written. Add 2 (bit 1) for a time-stamped file, and odd "//& + "(bit 0) for a non-time-stamped file. A restart file "//& + "will be saved at the end of the run segment for any "//& + "non-negative value.", default=1) + call get_param(param_file, mdl, "OCEAN_SURFACE_STAGGER", stagger, & + "A case-insensitive character string to indicate the "//& + "staggering of the surface velocity field that is "//& + "returned to the coupler. Valid values include "//& + "'A', 'B', or 'C'.", default="C") + if (uppercase(stagger(1:1)) == 'A') then ; Ocean_sfc%stagger = AGRID + elseif (uppercase(stagger(1:1)) == 'B') then ; Ocean_sfc%stagger = BGRID_NE + elseif (uppercase(stagger(1:1)) == 'C') then ; Ocean_sfc%stagger = CGRID_NE + else ; call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & + trim(stagger)//" is invalid.") ; endif + + call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & + "If true, the coupled driver will add a globally-balanced "//& + "fresh-water flux that drives sea-surface salinity "//& + "toward specified values.", default=.false.) + call get_param(param_file, mdl, "RESTORE_TEMPERATURE",OS%restore_temp, & + "If true, the coupled driver will add a "//& + "heat flux that drives sea-surface temperature "//& + "toward specified values.", default=.false.) + 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 "//& + "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, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default = 9.80) + + call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & + "If true, enables the ice shelf model.", default=.false.) + + call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_alter_ocean, & + "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) + + OS%press_to_z = 1.0/(Rho0*G_Earth) + + call get_param(param_file, mdl, "HFREEZE", HFrz, & + "If HFREEZE > 0, melt potential will be computed. The actual depth "//& + "over which melt potential is computed will be min(HFREEZE, OBLD), "//& + "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& + "melt potential will not be computed.", units="m", default=-1.0, do_not_log=.true.) + + if (HFrz .gt. 0.0) then + use_melt_pot=.true. + else + use_melt_pot=.false. + endif + + ! 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) + + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) + + if (OS%use_ice_shelf) then + call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & + OS%diag, Time_init, OS%dirs%output_directory, OS%forces, OS%fluxes) + endif + + if (OS%icebergs_alter_ocean) then + call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) + if (.not. OS%use_ice_shelf) & + call allocate_forcing_type(OS%grid, OS%fluxes, shelf=.true.) + endif + + call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & + "If true, enables surface wave modules.", default=.false.) + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) + + if (associated(OS%grid%Domain%maskmap)) then + call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & + OS%diag, maskmap=OS%grid%Domain%maskmap, & + gas_fields_ocn=gas_fields_ocn) + else + call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & + OS%diag, gas_fields_ocn=gas_fields_ocn) + endif + + ! This call can only occur here if the coupler_bc_type variables have been + ! initialized already using the information from gas_fields_ocn. + if (present(gas_fields_ocn)) then + call coupler_type_set_diags(Ocean_sfc%fields, "ocean_sfc", & + Ocean_sfc%axes(1:2), Time_in) + + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) + endif + + call close_param_file(param_file) + call diag_mediator_close_registration(OS%diag) + call callTree_leave("ocean_model_init(") +end subroutine ocean_model_init + +!> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the +!! ocean model's state from the input value of Ocean_state (which must be for +!! time time_start_update) for a time interval of Ocean_coupling_time_step, +!! returning the publicly visible ocean surface properties in Ocean_sfc and +!! storing the new ocean properties in Ocean_state. +subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & + time_start_update, Ocean_coupling_time_step, & + update_dyn, update_thermo, Ocn_fluxes_used) + type(ice_ocean_boundary_type), & + intent(in) :: Ice_ocean_boundary !< A structure containing the + !! various forcing fields coming from the ice. + type(ocean_state_type), & + pointer :: OS !< A pointer to a private structure containing + !! the internal ocean state. + type(ocean_public_type), & + intent(inout) :: Ocean_sfc !< A structure containing all the + !! publicly visible ocean surface fields after + !! a coupling time step. The data in this type is + !! intent out. + type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. + type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over + !! which to advance the ocean. + logical, optional, intent(in) :: update_dyn !< If present and false, do not do updates + !! due to the ocean dynamics. + logical, optional, intent(in) :: update_thermo !< If present and false, do not do updates + !! due to the ocean thermodynamics or remapping. + logical, optional, intent(in) :: Ocn_fluxes_used !< If present, this indicates whether the + !! cumulative thermodynamic fluxes from the ocean, + !! like frazil, have been used and should be reset. + ! Local variables + type(time_type) :: Master_time ! This allows step_MOM to temporarily change + ! the time that is seen by internal modules. + type(time_type) :: Time1 ! The value of the ocean model's time at the + ! start of a call to step_MOM. + integer :: index_bnds(4) ! The computational domain index bounds in the + ! ice-ocean boundary type. + real :: weight ! Flux accumulation weight + real :: dt_coupling ! The coupling time step [T ~> s] + integer :: nts ! The number of baroclinic dynamics time steps + ! within dt_coupling. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s] + real :: dt_dyn ! The dynamics time step [T ~> s] + real :: dtdia ! The diabatic time step [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s] + integer :: n, n_max, n_last_thermo + type(time_type) :: Time2 ! A temporary time. + logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans + ! multiple dynamic timesteps. + logical :: do_dyn ! If true, step the ocean dynamics and transport. + logical :: do_thermo ! If true, step the ocean thermodynamics. + logical :: step_thermo ! If true, take a thermodynamic step. + integer :: secs, days + integer :: is, ie, js, je + + call callTree_enter("update_ocean_model(), MOM_ocean_model_mct.F90") + call get_time(Ocean_coupling_time_step, secs, days) + dt_coupling = OS%US%s_to_T*(86400.0*real(days) + real(secs)) + + if (time_start_update /= OS%Time) then + call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& + "agree with time_start_update argument.") + endif + + if (.not.associated(OS)) then + call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & + "ocean_state_type structure. ocean_model_init must be "// & + "called first to allocate this structure.") + return + endif + + do_dyn = .true. ; if (present(update_dyn)) do_dyn = update_dyn + do_thermo = .true. ; if (present(update_thermo)) do_thermo = update_thermo + + ! This is benign but not necessary if ocean_model_init_sfc was called or if + ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. + is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec + call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + ! Translate Ice_ocean_boundary into fluxes. + call mpp_get_compute_domain(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), & + index_bnds(3), index_bnds(4)) + weight = 1.0 + + call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time, & + OS%grid, OS%US, OS%forcing_CSp) + + if (OS%fluxes%fluxes_used) then + + ! GMM, is enable_averaging needed now? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) + + if (do_thermo) & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & + OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, & + OS%restore_salinity, OS%restore_temp) + + ! Add ice shelf fluxes + if (OS%use_ice_shelf) then + if (do_thermo) & + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_dyn) & + call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) + endif + if (OS%icebergs_alter_ocean) then + if (do_dyn) & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + if (do_thermo) & + call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + endif + + ! Fields that exist in both the forcing and mech_forcing types must be copied. + call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) + +#ifdef _USE_GENERIC_TRACER + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes +#endif + + else + + OS%flux_tmp%C_p = OS%fluxes%C_p + + if (do_thermo) & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, dt_coupling, & + OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) + + if (OS%use_ice_shelf) then + if (do_thermo) & + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_dyn) & + call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) + endif + if (OS%icebergs_alter_ocean) then + if (do_dyn) & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + if (do_thermo) & + call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + endif + + call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, OS%grid, weight) + + ! Some of the fields that exist in both the forcing and mech_forcing types + ! (e.g., ustar) are time-averages must be copied back to the forces type. + call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) + +#ifdef _USE_GENERIC_TRACER + call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average +#endif + endif + + call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) + call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid, OS%US) + + if (OS%use_waves) then + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) + endif + + if (OS%nstep==0) then + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) + endif + + call disable_averaging(OS%diag) + Master_time = OS%Time ; Time1 = OS%Time + + if(OS%offline_tracer_mode) then + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) + + elseif ((.not.do_thermo) .or. (.not.do_dyn)) then + ! The call sequence is being orchestrated from outside of update_ocean_model. + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & + reset_therm=Ocn_fluxes_used) + + elseif (OS%single_step_call) then + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + + else + n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) + dt_dyn = dt_coupling / real(n_max) + thermo_does_span_coupling = (OS%thermo_spans_coupling .and. & + (OS%dt_therm > 1.5*dt_coupling)) + + if (thermo_does_span_coupling) then + dt_therm = dt_coupling * floor(OS%dt_therm / dt_coupling + 0.001) + nts = floor(dt_therm/dt_dyn + 0.001) + else + nts = MAX(1,MIN(n_max,floor(OS%dt_therm/dt_dyn + 0.001))) + n_last_thermo = 0 + endif + + Time2 = Time1 ; t_elapsed_seg = 0.0 + do n=1,n_max + if (OS%diabatic_first) then + if (thermo_does_span_coupling) call MOM_error(FATAL, & + "MOM is not yet set up to have restarts that work with "//& + "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") + if (modulo(n-1,nts)==0) then + dtdia = dt_dyn*min(nts,n_max-(n-1)) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + endif + + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + else + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + + step_thermo = .false. + if (thermo_does_span_coupling) then + dtdia = dt_therm + step_thermo = MOM_state_is_synchronized(OS%MOM_CSp, adv_dyn=.true.) + elseif ((modulo(n,nts)==0) .or. (n==n_max)) then + dtdia = dt_dyn*(n - n_last_thermo) + n_last_thermo = n + step_thermo = .true. + endif + + if (step_thermo) then + ! Back up Time2 to the start of the thermodynamic segment. + Time2 = Time2 - set_time(int(floor(OS%US%T_to_s*(dtdia - dt_dyn) + 0.5))) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + endif + endif + + t_elapsed_seg = t_elapsed_seg + dt_dyn + Time2 = Time1 + set_time(int(floor(OS%US%T_to_s*t_elapsed_seg + 0.5))) + enddo + endif + + OS%Time = Master_time + Ocean_coupling_time_step + OS%nstep = OS%nstep + 1 + + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) + + if (OS%fluxes%fluxes_used) then + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) + endif + +! 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) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) + call coupler_type_send_data(Ocean_sfc%fields, OS%Time) + + call callTree_leave("update_ocean_model()") +end subroutine update_ocean_model + +!> This subroutine writes out the ocean model restart file. +subroutine ocean_model_restart(OS, timestamp, restartname) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state being saved to a restart file + character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be + !! prepended to the file name. (Currently this is unused.) + character(len=*), optional, intent(in) :: restartname !< Name of restart file to use + !! This option distinguishes the cesm interface from the + !! non-cesm interface + + if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & + call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& + "dynamics and advective times. Additional restart fields "//& + "that have not been coded yet would be required for reproducibility.") + if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_restart "//& + "was called with unused buoyancy fluxes. For conservation, the ocean "//& + "restart files can only be created after the buoyancy forcing is applied.") + + if (present(restartname)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV, filename=restartname) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) ! Is this needed? + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & + OS%dirs%restart_output_dir) + endif + else + if (BTEST(OS%Restart_control,1)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, .true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif + endif + +end subroutine ocean_model_restart +! NAME="ocean_model_restart" + +!> ocean_model_end terminates the model run, saving the ocean state in a restart +!! and deallocating any data associated with the ocean. +subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) + type(ocean_public_type), intent(inout) :: Ocean_sfc !< An ocean_public_type structure that is + !! to be deallocated upon termination. + type(ocean_state_type), pointer :: Ocean_state !< A pointer to the structure containing + !! the internal ocean state to be deallocated + !! upon termination. + type(time_type), intent(in) :: Time !< The model time, used for writing restarts. + + 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) +end subroutine ocean_model_end + +!> ocean_model_save_restart causes restart files associated with the ocean to be +!! written out. +subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (in). + type(time_type), intent(in) :: Time !< The model time at this call, needed for mpp_write calls. + character(len=*), optional, intent(in) :: directory !< An optional directory into which to + !! write these restart files. + character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time-stamp) + !! to append to the restart file names. +! Note: This is a new routine - it will need to exist for the new incremental +! checkpointing. It will also be called by ocean_model_end, giving the same +! restart behavior as now in FMS. + character(len=200) :: restart_dir + + if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & + call MOM_error(WARNING, "ocean_model_save_restart called with inconsistent "//& + "dynamics and advective times. Additional restart fields "//& + "that have not been coded yet would be required for reproducibility.") + if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_save_restart "//& + "was called with unused buoyancy fluxes. For conservation, the ocean "//& + "restart files can only be created after the buoyancy forcing is applied.") + + if (present(directory)) then ; restart_dir = directory + else ; restart_dir = OS%dirs%restart_output_dir ; endif + + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) + + call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) + + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + +end subroutine ocean_model_save_restart + +!> Initialize the public ocean type +subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & + gas_fields_ocn) + type(domain2D), intent(in) :: input_domain !< The ocean model domain description + type(ocean_public_type), intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface properties after initialization, whose + !! elements are allocated here. + type(diag_ctrl), intent(in) :: diag !< A structure that regulates diagnsotic output + logical, dimension(:,:), & + optional, intent(in) :: maskmap !< A mask indicating which virtual processors + !! are actually in use. If missing, all are used. + type(coupler_1d_bc_type), & + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the + !! ocean and surface-ice fields that will participate + !! in the calculation of additional gas or other + !! tracer fluxes. + integer :: xsz, ysz, layout(2) + ! ice-ocean-boundary fields are always allocated using absolute indicies + ! and have no halos. + integer :: isc, iec, jsc, jec + + call mpp_get_layout(input_domain,layout) + call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) + if(PRESENT(maskmap)) then + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) + else + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) + endif + call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) + + allocate (Ocean_sfc%t_surf (isc:iec,jsc:jec), & + Ocean_sfc%s_surf (isc:iec,jsc:jec), & + Ocean_sfc%u_surf (isc:iec,jsc:jec), & + Ocean_sfc%v_surf (isc:iec,jsc:jec), & + Ocean_sfc%sea_lev(isc:iec,jsc:jec), & + Ocean_sfc%area (isc:iec,jsc:jec), & + Ocean_sfc%OBLD (isc:iec,jsc:jec), & + Ocean_sfc%melt_potential(isc:iec,jsc:jec), & + Ocean_sfc%frazil (isc:iec,jsc:jec)) + + Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model + Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models + Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav + Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model + Ocean_sfc%melt_potential = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model + Ocean_sfc%OBLD = 0.0 ! ocean boundary layer depth, in m + Ocean_sfc%area = 0.0 + Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics + + if (present(gas_fields_ocn)) then + call coupler_type_spawn(gas_fields_ocn, Ocean_sfc%fields, (/isc,isc,iec,iec/), & + (/jsc,jsc,jec,jec/), suffix = '_ocn', as_needed=.true.) + endif + +end subroutine initialize_ocean_public_type + +!> This subroutine translates the coupler's ocean_data_type into MOM's +!! surface state variable. This may eventually be folded into the MOM +!! code that calculates the surface state in the first place. +!! Note the offset in the arrays because the ocean_data_type has no +!! halo points in its arrays and always uses absolute indicies. +subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_to_z) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(ocean_public_type), & + target, intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface fields, whose elements + !! have their data set here. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: patm(:,:) !< The pressure at the ocean surface, in Pa. + real, optional, intent(in) :: press_to_z !< A conversion factor between pressure and + !! ocean depth in m, usually 1/(rho_0*g), in m Pa-1. + + ! Local variables + real :: IgR0 + character(len=48) :: val_str + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + integer :: i, j, i0, j0, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + call pass_vector(sfc_state%u,sfc_state%v,G%Domain) + + call mpp_get_compute_domain(Ocean_sfc%Domain, isc_bnd, iec_bnd, & + jsc_bnd, jec_bnd) + if (present(patm)) then + ! Check that the inidicies in patm are (isc_bnd:iec_bnd,jsc_bnd:jec_bnd). + if (.not.present(press_to_z)) call MOM_error(FATAL, & + 'convert_state_to_ocean_type: press_to_z must be present if patm is.') + endif + + i0 = is - isc_bnd ; j0 = js - jsc_bnd + if (sfc_state%T_is_conT) then + ! Convert the surface T from conservative T to potential T. + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0), & + US%C_to_degC*sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%t_surf(i,j) = US%C_to_degC*sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + enddo ; enddo + endif + if (sfc_state%S_is_absS) then + ! Convert the surface S from absolute salinity to practical salinity. + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0)) + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%s_surf(i,j) = US%S_to_ppt*sfc_state%SSS(i+i0,j+j0) + enddo ; enddo + endif + + if (present(patm)) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) + enddo ; enddo + endif + + if (allocated(sfc_state%frazil)) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) + enddo ; enddo + endif + + if (allocated(sfc_state%melt_potential)) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%melt_potential(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%melt_potential(i+i0,j+j0) + enddo ; enddo + endif + + if (allocated(sfc_state%Hml)) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%OBLD(i,j) = US%Z_to_m * sfc_state%Hml(i+i0,j+j0) + enddo ; enddo + endif + + if (Ocean_sfc%stagger == AGRID) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & + 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & + 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) + enddo ; enddo + elseif (Ocean_sfc%stagger == BGRID_NE) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & + 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & + 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) + enddo ; enddo + elseif (Ocean_sfc%stagger == CGRID_NE) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0) * US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0) * US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) + enddo ; enddo + else + write(val_str, '(I8)') Ocean_sfc%stagger + call MOM_error(FATAL, "convert_state_to_ocean_type: "//& + "Ocean_sfc%stagger has the unrecognized value of "//trim(val_str)) + endif + + if (coupler_type_initialized(sfc_state%tr_fields)) then + if (.not.coupler_type_initialized(Ocean_sfc%fields)) then + call MOM_error(FATAL, "convert_state_to_ocean_type: "//& + "Ocean_sfc%fields has not been initialized.") + endif + call coupler_type_copy_data(sfc_state%tr_fields, Ocean_sfc%fields) + endif + +end subroutine convert_state_to_ocean_type + +!> This subroutine extracts the surface properties from the ocean's internal +!! state and stores them in the ocean type returned to the calling ice model. +!! It has to be separate from the ocean_initialization call because the coupler +!! module allocates the space for some of these variables. +subroutine ocean_model_init_sfc(OS, Ocean_sfc) + type(ocean_state_type), pointer :: OS !< The structure with the complete ocean state + type(ocean_public_type), intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface properties after initialization, whose + !! elements have their data set here. + integer :: is, ie, js, je + + is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec + call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) + +end subroutine ocean_model_init_sfc + +!> ocean_model_flux_init is used to initialize properties of the air-sea fluxes +!! as determined by various run-time parameters. It can be called from +!! non-ocean PEs, or PEs that have not yet been initialzed, and it can safely +!! be called multiple times. +subroutine ocean_model_flux_init(OS, verbosity) + type(ocean_state_type), optional, pointer :: OS !< An optional pointer to the ocean state, + !! used to figure out if this is an ocean PE that + !! has already been initialized. + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + + logical :: OS_is_set + integer :: verbose + + OS_is_set = .false. ; if (present(OS)) OS_is_set = associated(OS) + + ! Use this to control the verbosity of output; consider rethinking this logic later. + verbose = 5 ; if (OS_is_set) verbose = 3 + if (present(verbosity)) verbose = verbosity + + call call_tracer_flux_init(verbosity=verbose) + +end subroutine ocean_model_flux_init + +!> Ocean_stock_pe - returns the integrated stocks of heat, water, etc. for conservation checks. +!! Because of the way FMS is coded, only the root PE has the integrated amount, +!! while all other PEs get 0. +subroutine Ocean_stock_pe(OS, index, value, time_index) + use stock_constants_mod, only : ISTOCK_WATER, ISTOCK_HEAT,ISTOCK_SALT + type(ocean_state_type), pointer :: OS !< A structure containing the internal ocean state. + !! The data in OS is intent in. + integer, intent(in) :: index !< The stock index for the quantity of interest. + real, intent(out) :: value !< Sum returned for the conservation quantity of interest. + integer, optional, intent(in) :: time_index !< An unused optional argument, present only for + !! interfacial compatibility with other models. +! Arguments: OS - A structure containing the internal ocean state. +! (in) index - Index of conservation quantity of interest. +! (in) value - Sum returned for the conservation quantity of interest. +! (in,opt) time_index - Index for time level to use if this is necessary. + + real :: salt + + value = 0.0 + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + select case (index) + case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in kg. + if (OS%GV%Boussinesq) then + call get_ocean_stocks(OS%MOM_CSp, mass=value, on_PE_only=.true.) + else ! In non-Boussinesq mode, the mass of salt needs to be subtracted. + call get_ocean_stocks(OS%MOM_CSp, mass=value, salt=salt, on_PE_only=.true.) + value = value - salt + endif + case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. + call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) + case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + case default ; value = 0.0 + end select + ! If the FMS coupler is changed so that Ocean_stock_PE is only called on + ! ocean PEs, uncomment the following and eliminate the on_PE_only flags above. + ! if (.not.is_root_pe()) value = 0.0 + +end subroutine Ocean_stock_pe + +!> Write out checksums for fields from the ocean surface state +subroutine ocean_public_type_chksum(id, timestep, ocn) + + character(len=*), intent(in) :: id !< An identifying string for this call + integer, intent(in) :: timestep !< The number of elapsed timesteps + type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly + !! visible ocean surface fields. + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks + call coupler_type_write_chksums(ocn%fields, stdout, 'ocean%') +100 FORMAT(" CHECKSUM::",A20," = ",Z20) + +end subroutine ocean_public_type_chksum + +subroutine get_ocean_grid(OS, Gridp) + ! Obtain the ocean grid. + type(ocean_state_type) :: OS + type(ocean_grid_type) , pointer :: Gridp + + Gridp => OS%grid + return +end subroutine get_ocean_grid + +end module MOM_ocean_model_mct diff --git a/config_src/nuopc_driver/MOM_surface_forcing.F90 b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 similarity index 70% rename from config_src/nuopc_driver/MOM_surface_forcing.F90 rename to config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 index 01cd79acb9..bb57810f5b 100644 --- a/config_src/nuopc_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 @@ -1,27 +1,33 @@ -!> Converts the input ESMF data (import data) to a MOM-specific data type (surface_forcing_CS). -module MOM_surface_forcing +module MOM_surface_forcing_mct ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf +use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_spawn +use MOM_coupler_types, only : coupler_type_copy_data use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT +use MOM_data_override, only : data_override_init, data_override use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type +use MOM_interpolate, only : init_external_field, time_interp_external +use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : stdout use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state use MOM_string_functions, only : uppercase @@ -30,15 +36,7 @@ module MOM_surface_forcing use MOM_variables, only : surface use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS - -use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn -use coupler_types_mod, only : coupler_type_copy_data -use data_override_mod, only : data_override_init, data_override -use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init +use iso_fortran_env, only : int64 implicit none ; private @@ -61,17 +59,17 @@ module MOM_surface_forcing !! from MOM_domains) to indicate the staggering of !! the winds that are being provided in calls to !! update_ocean_model. - logical :: use_temperature !! If true, temp and saln used as state variables - real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress (nondim). + logical :: use_temperature !< If true, temp and saln used as state variables + real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). - real :: Rho0 !< Boussinesq reference density [kg/m^3] - real :: area_surf = -1.0 !< total ocean surface area [m^2] - real :: latent_heat_fusion !< latent heat of fusion [J/kg] - real :: latent_heat_vapor !< latent heat of vaporization [J/kg] + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] + real :: area_surf = -1.0 !< total ocean surface area [m2] + real :: latent_heat_fusion !< latent heat of fusion [J kg-1] + real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] - real :: max_p_surf !< maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice, - !! in Pa. This is needed because the FMS coupling + real :: max_p_surf !< The maximum surface pressure that can be exerted by + !! the atmosphere and floating sea-ice [R L2 T-2 ~> Pa]. + !! This is needed because the FMS coupling !! structure does not limit the water that can be !! frozen out of the ocean and the ice-ocean heat !! fluxes are treated explicitly. @@ -79,57 +77,55 @@ module MOM_surface_forcing !! the correction for the atmospheric (and sea-ice) !! pressure limited by max_p_surf instead of the !! full atmospheric pressure. The default is true. - - real :: gust_const !< constant unresolved background gustiness for ustar [Pa] + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the - !! bottom boundary layer by drag on the tidal flows [W m-2] + !! bottom boundary layer by drag on the tidal flows [R Z3 T-3 ~> W m-2] gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar [Pa]. + !! gustiness that contributes to ustar [R L Z T-2 ~> Pa]. !! gust is used when read_gust_2d is true. - ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [m s-1] + ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) real :: utide !< constant tidal velocity to use if read_tideamp - !! is false [m s-1] - logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. - - logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts - !! to damp surface deflections (especially surface - !! gravity waves). The default is false. - real :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !! viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< typical density of sea-ice [kg m-3]. The value is + !! is false [Z T-1 ~> m s-1] + logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. + logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts + !! to damp surface deflections (especially surface + !! gravity waves). The default is false. + real :: g_Earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< Typical density of sea-ice [R ~> kg m-3]. The value is !! only used to convert the ice pressure into !! appropriate units for use with Kv_sea_ice. real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which - !! sea-ice viscosity becomes effective, in kg m-2, - !! typically of order 1000 [kg m-2]. + !! 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 - - real :: Flux_const !< piston velocity for surface restoring [m/s] + real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux logical :: adjust_net_srestore_to_zero !< adjust srestore to zero (for both salt_flux or vprec) logical :: adjust_net_srestore_by_scaling !< adjust srestore w/o moving zero contour logical :: adjust_net_fresh_water_to_zero !< adjust net surface fresh-water (w/ restoring) to zero logical :: use_net_FW_adjustment_sign_bug !< use the wrong sign when adjusting net FW - logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour + logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil - !< criteria for salinity restoring. + real :: ice_salt_concentration !< salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas - real :: max_delta_srestore !< maximum delta salinity used for restoring - real :: max_delta_trestore !< maximum delta sst used for restoring + real :: max_delta_srestore !< maximum delta salinity used for restoring [S ~> ppt] + real :: max_delta_trestore !< maximum delta sst used for restoring [C ~> degC] real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring by basin - - type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing - character(len=200) :: inputdir !< directory where NetCDF input files are - character(len=200) :: salt_restore_file !< filename for salt restoring data + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the + !! gustless wind friction velocity. + type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing + character(len=200) :: inputdir !< directory where NetCDF input files are + character(len=200) :: salt_restore_file !< filename for salt restoring data character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file logical :: mask_srestore !< if true, apply a 2-dimensional mask to the surface - !< salinity restoring fluxes. The masking file should be - !< in inputdir/salt_restore_mask.nc and the field should + !! salinity restoring fluxes. The masking file should be + !! in inputdir/salt_restore_mask.nc and the field should !! be named 'mask' real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring character(len=200) :: temp_restore_file !< filename for sst restoring data @@ -139,21 +135,21 @@ module MOM_surface_forcing !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' real, pointer, dimension(:,:) :: trestore_mask => NULL() !< mask for SST restoring - integer :: id_srestore = -1 !< id number for time_interp_external. - integer :: id_trestore = -1 !< id number for time_interp_external. - - ! Diagnostics handles - type(forcing_diags), public :: handles - - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(user_revise_forcing_CS), pointer :: urf_CS => NULL() + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field + + type(forcing_diags), public :: handles !< diagnostics handles + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< restart pointer + type(user_revise_forcing_CS), pointer :: urf_CS => NULL() !< user revise pointer end type surface_forcing_CS !> Structure corresponding to forcing, but with the elements, units, and conventions !! that exactly conform to the use for MOM-based coupled models. type, public :: ice_ocean_boundary_type - real, pointer, dimension(:,:) :: rofl_flux =>NULL() !< liquid runoff [W/m2] - real, pointer, dimension(:,:) :: rofi_flux =>NULL() !< ice runoff [W/m2] + real, pointer, dimension(:,:) :: rofl_flux =>NULL() !< liquid runoff [kg/m2/s] + real, pointer, dimension(:,:) :: rofi_flux =>NULL() !< ice runoff [kg/m2/s] real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress [Pa] real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress [Pa] real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W/m2] @@ -199,33 +195,33 @@ module MOM_surface_forcing !> This subroutine translates the Ice_ocean_boundary_type into a MOM !! thermodynamic forcing type, including changes of units, sign conventions, !! and putting the fields into arrays with MOM-standard halos. -subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, US, CS, & sfc_state, restore_salt, restore_temp) + type(ice_ocean_boundary_type), & - target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive - !! the ocean in a coupled model + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to all !! possible mass, heat or salt flux forcing fields. !! Unused fields have NULL ptrs. integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. + real, intent(in) :: valid_time !< The amount of time over which these fluxes + !! should be applied [T ~> s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a !! previous call to surface_forcing_init. type(surface), intent(in) :: sfc_state !< A structure containing fields that describe the - !! surface state of the ocean. + !! surface state of the ocean. logical, optional, intent(in) :: restore_salt !< If true, salinity is restored to a target value. logical, optional, intent(in) :: restore_temp !< If true, temperature is restored to a target value. - ! local varibles + ! local variables real, dimension(SZI_(G),SZJ_(G)) :: & - data_restore, & !< The surface value toward which to restore [g/kg or degC] - SST_anom, & !< Instantaneous sea surface temperature anomalies from a target value [deg C] - SSS_anom, & !< Instantaneous sea surface salinity anomalies from a target value [g/kg] - SSS_mean, & !< A (mean?) salinity about which to normalize local salinity - !! anomalies when calculating restorative precipitation anomalies [g/kg] + data_restore, & !< The surface value toward which to restore [S ~> ppt] or [C ~> degC] PmE_adj, & !< The adjustment to PminusE that will cause the salinity !! to be restored toward its target value [kg/(m^2 * s)] net_FW, & !< The area integrated net freshwater flux into the ocean [kg/s] @@ -242,10 +238,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & !! is present, or false (no restoring) otherwise. logical :: restore_sst !< local copy of the argument restore_temp, if it !! is present, or false (no restoring) otherwise. - real :: delta_sss !< temporary storage for sss diff from restoring value - real :: delta_sst !< temporary storage for sst diff from restoring value + real :: delta_sss !< temporary storage for sss diff from restoring value [S ~> ppt] + real :: delta_sst !< temporary storage for sst diff from restoring value [C ~> degC] - real :: C_p !< heat capacity of seawater ( J/(K kg) ) + real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling + !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. + real :: C_p !< heat capacity of seawater [J kg-1 degC-1] real :: sign_for_net_FW_bug !< Should be +1. but an old bug can be recovered by using -1. call cpu_clock_begin(id_clock_forcing) @@ -258,7 +256,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, 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 - C_p = fluxes%C_p + kg_m2_s_conversion = US%kg_m2s_to_RZ_T + C_p = US%Q_to_J_kg*US%degC_to_C*fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -276,20 +275,20 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! allocation and initialization if this is the first time that this ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) + call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & + press=.true., fix_accum_bug=.not.CS%ustar_gustless_bug, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_nir_dif,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then - fluxes%p_surf_SSH => fluxes%p_surf + fluxes%p_surf_SSH => fluxes%p_surf else - fluxes%p_surf_SSH => fluxes%p_surf_full + fluxes%p_surf_SSH => fluxes%p_surf_full endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) @@ -306,12 +305,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) - fluxes%ustar_tidal(i,j) = US%m_to_Z*US%T_to_s*CS%ustar_tidal(i,j) + fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - fluxes%dt_buoy_accum = 0.0 endif ! endif for allocation and initialization @@ -328,20 +326,24 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! ocean model, rather than using haloless arrays, in which case the last line ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) - - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 - endif - ! allocation and initialization on first call to this routine if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie - work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) + work_sum(i,j) = US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) endif ! endif for allocation and initialization + + ! Indicate that there are new unused fluxes. + fluxes%fluxes_used = .false. + fluxes%dt_buoy_accum = valid_time + + if (CS%allow_flux_adjustments) then + fluxes%heat_added(:,:) = 0.0 + fluxes%salt_flux_added(:,:) = 0.0 + endif + do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 @@ -349,51 +351,55 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! Salinity restoring logic if (restore_salinity) then - call time_interp_external(CS%id_srestore,Time,data_restore) + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie - if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + if (sfc_state%SST(i,j) <= -0.0539*US%degC_to_C*US%S_to_ppt*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie - delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) + delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & - (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 + 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 if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) + call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & + unit_scale=US%RZ_T_to_kg_m2s) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & + G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & - delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) + (CS%Rho0*CS%Flux_const) * & + delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) + call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & + unit_scale=US%RZ_T_to_kg_m2s) fluxes%vPrecGlobalAdj = 0. else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & + US%RZ_T_to_kg_m2s*fluxes%vprec(is:ie,js:je) fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif endif @@ -402,9 +408,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! SST restoring logic if (restore_sst) then - call time_interp_external(CS%id_trestore,Time,data_restore) + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- sfc_state%SST(i,j) + delta_sst = data_restore(i,j) - sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 @@ -412,31 +418,33 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & endif ! obtain fluxes from IOB; note the staggering of indices - i0 = is - isc_bnd ; j0 = js - jsc_bnd + i0 = 0; j0 = 0 do j=js,je ; do i=is,ie - + ! liquid precipitation (rain) if (associated(IOB%lprec)) & - fluxes%lprec(i,j) = IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lprec(i,j) = kg_m2_s_conversion * IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + ! frozen precipitation (snow) if (associated(IOB%fprec)) & - fluxes%fprec(i,j) = IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%fprec(i,j) = kg_m2_s_conversion * IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + ! evaporation if (associated(IOB%q_flux)) & - fluxes%evap(i,j) = IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%evap(i,j) = kg_m2_s_conversion * IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) ! liquid runoff flux if (associated(IOB%rofl_flux)) then - fluxes%lrunoff(i,j) = IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%runoff)) then - fluxes%lrunoff(i,j) = IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) - endif + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + end if ! ice runoff flux if (associated(IOB%rofi_flux)) then - fluxes%frunoff(i,j) = IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) - elseif (associated(IOB%calving)) then - fluxes%frunoff(i,j) = IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) - endif + 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 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) @@ -445,54 +453,68 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) - if (associated(IOB%runoff_hflx)) & - fluxes%heat_content_lrunoff(i,j) = IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) + ! GMM, cime does not not have an equivalent for heat_content_lrunoff and + ! heat_content_frunoff. I am setting these to zero for now. + if (associated(fluxes%heat_content_lrunoff)) & + fluxes%heat_content_lrunoff(i,j) = 0.0 * G%mask2dT(i,j) + if (associated(fluxes%heat_content_frunoff)) & + fluxes%heat_content_frunoff(i,j) = 0.0 * G%mask2dT(i,j) if (associated(IOB%calving_hflx)) & - fluxes%heat_content_frunoff(i,j) = IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + ! longwave radiation, sum up and down (W/m2) if (associated(IOB%lw_flux)) & - fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + ! sensible heat flux (W/m2) if (associated(IOB%t_flux)) & - fluxes%sens(i,j) = IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%sens(i,j) = US%W_m2_to_QRZ_T * IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) ! sea ice and snow melt heat flux [W/m2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%seaice_melt_heat(i-i0,j-j0) ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & - fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) + fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * kg_m2_s_conversion * IOB%seaice_melt(i-i0,j-j0) + ! latent heat flux (W/m^2) fluxes%latent(i,j) = 0.0 + ! contribution from frozen ppt (notice minus sign since fprec is positive into the ocean) if (associated(IOB%fprec)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif - if (associated(IOB%calving)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion + ! contribution from frozen runoff (notice minus sign since rofi_flux is positive into the ocean) + if (associated(fluxes%frunoff)) then + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%rofi_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -G%mask2dT(i,j) & + * IOB%rofi_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif + ! contribution from evaporation if (associated(IOB%q_flux)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor + fluxes%latent(i,j) = fluxes%latent(i,j) + & + IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) if (associated(IOB%sw_flux_vis_dir)) & - fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dir(i-i0,j-j0) + fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_vis_dir(i-i0,j-j0) if (associated(IOB%sw_flux_vis_dif)) & - fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dif(i-i0,j-j0) + fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_vis_dif(i-i0,j-j0) if (associated(IOB%sw_flux_nir_dir)) & - fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dir(i-i0,j-j0) + fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_nir_dir(i-i0,j-j0) if (associated(IOB%sw_flux_nir_dif)) & - fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dif(i-i0,j-j0) + fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_nir_dif(i-i0,j-j0) fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) @@ -501,24 +523,24 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! applied surface pressure from atmosphere and cryosphere if (associated(IOB%p)) then - if (CS%max_p_surf >= 0.0) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) - enddo; enddo - else - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) - enddo; enddo - endif - fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie - fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + IOB%salt_flux(i-i0,j-j0)) - fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( IOB%salt_flux(i-i0,j-j0) ) + fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0)) + fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0) ) enddo ; enddo endif @@ -527,36 +549,26 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & sign_for_net_FW_bug = 1. if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie - net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & - (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) - - ! The following contribution appears to be calculating the volume flux of sea-ice - ! melt. This calculation is clearly WRONG if either sea-ice has variable - ! salinity or the sea-ice is completely fresh. - ! Bob thinks this is trying ensure the net fresh-water of the ocean + sea-ice system - ! is constant. - ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA - ! GMM: as stated above, the following is wrong. CIME deals with volume/mass and - ! heat from sea ice/snow via seaice_melt and seaice_melt_heat, respectively. - if (associated(IOB%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & - net_FW(i,j) = net_FW(i,j) + sign_for_net_FW_bug * G%areaT(i,j) * & - (IOB%salt_flux(i-i0,j-j0) / CS%ice_salt_concentration) - net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) + net_FW(i,j) = US%RZ_T_to_kg_m2s * & + (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & + (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) + + net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + kg_m2_s_conversion * & + (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) enddo ; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif - endif if (coupler_type_initialized(fluxes%tr_fluxes) .and. & @@ -565,7 +577,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & if (CS%allow_flux_adjustments) then ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, fluxes) + call apply_flux_adjustments(G, US, CS, Time, fluxes) endif ! Allow for user-written code to alter fluxes after all the above @@ -593,22 +605,24 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! local variables real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & !< Zonal wind stresses at q points [Pa] - tauy_at_q !< Meridional wind stresses at q points [Pa] + taux_at_q, & !< Zonal wind stresses at q points [R Z L T-2 ~> Pa] + tauy_at_q !< Meridional wind stresses at q points [R Z L T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & !< Ice rigidity at tracer points (m3 s-1) - taux_at_h, & !< Zonal wind stresses at h points [Pa] - tauy_at_h !< Meridional wind stresses at h points [Pa] - - real :: gustiness !< unresolved gustiness that contributes to ustar [Pa] - real :: Irho0 !< inverse of the mean density in (m^3/kg) - real :: taux2, tauy2 !< squared wind stresses (Pa^2) - real :: tau_mag !< magnitude of the wind stress [Pa] - real :: I_GEarth !< 1.0 / G_Earth [s2 m-1] - real :: Kv_rho_ice !< (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) - real :: mass_ice !< mass of sea ice at a face (kg/m^2) - real :: mass_eff !< effective mass of sea ice for rigidity (kg/m^2) + rigidity_at_h, & !< Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] + taux_at_h, & !< Zonal wind stresses at h points [R Z L T-2 ~> Pa] + tauy_at_h !< Meridional wind stresses at h points [R Z L T-2 ~> Pa] + + real :: gustiness !< unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] + real :: Irho0 !< inverse of the mean density in [Z L-1 R-1 ~> m3 kg-1] + real :: taux2, tauy2 !< squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] + real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] + real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] + real :: I_GEarth !< The inverse of the gravitational acceleration [T2 Z L-2 ~> s2 m-1] + real :: Kv_rho_ice !< (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice !< mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff !< effective mass of sea ice for rigidity [R Z ~> kg m-2] integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 @@ -624,15 +638,18 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB 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 = is - isc_bnd ; j0 = js - jsc_bnd + i0 = 0; j0 = 0 - Irho0 = 1.0/CS%Rho0 + Irho0 = US%L_to_Z / CS%Rho0 + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + stress_conversion = Pa_conversion * CS%wind_stress_multiplier ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) @@ -658,21 +675,21 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 - ! applied surface pressure from atmosphere and cryosphere + !applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf + forces%p_surf_SSH => forces%p_surf else - forces%p_surf_SSH => forces%p_surf_full + forces%p_surf_SSH => forces%p_surf_full endif if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -684,9 +701,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) endif forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. - wind_stagger = CS%wind_stagger - if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & - (IOB%wind_stagger == CGRID_NE)) wind_stagger = IOB%wind_stagger + ! GMM, CIME uses AGRID. All the BGRID_NE code can be cleaned later + wind_stagger = AGRID + if (wind_stagger == BGRID_NE) then ! This is necessary to fill in the halo points. taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 @@ -702,20 +719,20 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%ice_rigidity)) & - rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) if (wind_stagger == BGRID_NE) then - if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion elseif (wind_stagger == AGRID) then - if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * stress_conversion else ! C-grid wind stresses. - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion endif enddo ; enddo @@ -728,7 +745,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) @@ -736,7 +753,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) @@ -749,24 +766,24 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & - ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) + G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & + (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & + G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(gustiness*Irho0 + Irho0*tau_mag) + forces%tau_mag(i,j) = gustiness + tau_mag + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) enddo ; enddo elseif (wind_stagger == AGRID) then - call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, & - stagger=AGRID, halo=1) + call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) @@ -774,7 +791,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) @@ -782,8 +799,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) + forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2) + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo ; enddo @@ -794,19 +812,21 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) + forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2) + forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) else - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) + forces%tau_mag(i,j) = CS%gust_const + sqrt(taux2 + tauy2) + forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif enddo ; enddo @@ -828,13 +848,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) I_GEarth = 1.0 / CS%g_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + Kv_rho_ice = (CS%Kv_sea_ice / CS%density_sea_ice) do I=is-1,ie ; do j=js,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff enddo ; enddo @@ -842,8 +861,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff enddo ; enddo @@ -851,7 +869,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%allow_flux_adjustments) then ! Apply adjustments to forces - call apply_force_adjustments(G, CS, Time, forces) + call apply_force_adjustments(G, US, CS, Time, forces) endif !### ! Allow for user-written code to alter fluxes after all the above @@ -866,8 +884,9 @@ end subroutine convert_IOB_to_forces !! - hflx_adj (Heat flux into the ocean, in W m-2) !! - sflx_adj (Salt flux into the ocean, in kg salt m-2 s-1) !! - prcme_adj (Fresh water flux into the ocean, in kg m-2 s-1) -subroutine apply_flux_adjustments(G, CS, Time, fluxes) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure +subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(forcing), intent(inout) :: fluxes !< Surface fluxes structure @@ -884,7 +903,7 @@ subroutine apply_flux_adjustments(G, CS, Time, fluxes) call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + US%W_m2_to_QRZ_T*temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) @@ -892,7 +911,8 @@ subroutine apply_flux_adjustments(G, CS, Time, fluxes) call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + & + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) @@ -900,9 +920,10 @@ subroutine apply_flux_adjustments(G, CS, Time, fluxes) call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) + end subroutine apply_flux_adjustments !> Adds mechanical forcing adjustments obtained via data_override @@ -910,21 +931,24 @@ end subroutine apply_flux_adjustments !! Available adjustments are: !! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) !! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_force_adjustments(G, CS, Time, forces) +subroutine apply_force_adjustments(G, US, CS, Time, forces) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h !< Delta to zonal wind stress at h points [Pa] - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h !< Delta to meridional wind stress at h points [Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h !< Delta to zonal wind stress at h points [R Z L T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h !< Delta to meridional wind stress at h points [R Z L T-2 ~> Pa] integer :: isc, iec, jsc, jec, i, j real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] logical :: overrode_x, overrode_y isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged @@ -945,8 +969,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) if (rDlon > 0.) rDlon = 1. / rDlon cosA = dLonDx * rDlon sinA = dLonDy * rDlon - zonal_tau = tempx_at_h(i,j) - merid_tau = tempy_at_h(i,j) + zonal_tau = Pa_conversion * tempx_at_h(i,j) + merid_tau = Pa_conversion * tempy_at_h(i,j) tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau enddo ; enddo @@ -999,14 +1023,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, !! restoring will be applied in this model. ! Local variables - real :: utide ! The RMS tidal velocity, in m s-1. + real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags + logical :: new_sim, iceberg_flux_diags, fix_ustar_gustless_bug + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. type(time_type) :: Time_frc character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_surface_forcing_mct" ! This module's name. character(len=48) :: stagger character(len=48) :: flnam character(len=240) :: basin_file @@ -1042,7 +1068,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + 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, & "The latent heat of fusion.", units="J/kg", default=hlf) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & @@ -1053,8 +1079,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "needed because the FMS coupling structure does not "//& "limit the water that can be frozen out of the ocean and "//& "the ice-ocean heat fluxes are treated explicitly. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & CS%adjust_net_srestore_to_zero, & "If true, adjusts the salinity restoring seen to zero "//& @@ -1102,14 +1128,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) + "production runs.", units="nondim", default=1.0) if (restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1117,15 +1142,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "The name of the surface salinity variable to read from "//& "SALT_RESTORE_FILE for restoring salinity.", & default="salt") -! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "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) + units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & CS%mask_srestore_under_ice, & "If true, disables SSS restoring under sea-ice based on a frazil "//& @@ -1154,10 +1177,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_temp) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") @@ -1165,16 +1187,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "The name of the surface temperature variable to read from "//& "SST_RESTORE_FILE for restoring sst.", & default="temp") - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & "The maximum sst difference used in restoring terms.", & - units="degC ", default=999.0) + units="degC ", default=999.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & "If true, read a file (temp_restore_mask) containing "//& "a mask for SST restoring.", default=.false.) - endif ! Optionally read tidal amplitude from input file (m s-1) on model grid. @@ -1196,7 +1216,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, else call get_param(param_file, mdl, "UTIDE", CS%utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) endif call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) @@ -1204,7 +1224,7 @@ 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) + call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) @@ -1212,7 +1232,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, enddo ; enddo else do j=jsd,jed; do i=isd,ied - utide=CS%utide + 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 enddo ; enddo @@ -1227,8 +1247,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", units="Pa", default=0.0, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& @@ -1236,9 +1256,36 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1) ! units should be Pa + call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & + "If true correct a bug in the time-averaging of the gustless wind friction velocity", & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) + ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & "If true, sea-ice is rigid enough to exert a "//& @@ -1247,18 +1294,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (CS%rigid_sea_ice) then call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + units="m s-2", default = 9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & "A typical density of sea ice, used with the kinematic "//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) + "viscosity, when USE_RIGID_SEA_ICE is true.", & + units="kg m-3", default=900.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & "The mass of sea-ice per unit area at which the sea-ice "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & @@ -1276,7 +1324,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%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) + CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' @@ -1286,7 +1334,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%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) + CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' @@ -1341,38 +1389,44 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) !! ocean in a coupled model whose checksums are reported ! local variables - integer :: n,m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ' , mpp_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ' , mpp_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ' , mpp_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ' , mpp_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ' , mpp_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%seaice_melt_heat' , mpp_chksum( iobt%seaice_melt_heat) - write(outunit,100) 'iobt%seaice_melt ' , mpp_chksum( iobt%seaice_melt ) - write(outunit,100) 'iobt%lw_flux ' , mpp_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir' , mpp_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif' , mpp_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir' , mpp_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif' , mpp_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ' , mpp_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ' , mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%runoff ' , mpp_chksum( iobt%runoff ) - write(outunit,100) 'iobt%calving ' , mpp_chksum( iobt%calving ) - write(outunit,100) 'iobt%p ' , mpp_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ' , mpp_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ' , mpp_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ' , mpp_chksum( iobt%mass_berg ) + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + outunit = stdout + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + 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) ; 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 + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%rofl_flux ) ; if (root) write(outunit,100) 'rofl_flux ', chks + chks = field_chksum( iobt%rofi_flux ) ; if (root) write(outunit,100) 'rofi_flux ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) - call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') + call coupler_type_write_chksums(iobt%fluxes, stdout, 'iobt%') end subroutine ice_ocn_bnd_type_chksum -end module MOM_surface_forcing +end module MOM_surface_forcing_mct diff --git a/config_src/mct_driver/ocn_cap_methods.F90 b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 similarity index 92% rename from config_src/mct_driver/ocn_cap_methods.F90 rename to config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 index 7723f51a6c..0b7a331458 100644 --- a/config_src/mct_driver/ocn_cap_methods.F90 +++ b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 @@ -1,13 +1,13 @@ module ocn_cap_methods - use ESMF, only: ESMF_clock, ESMF_time, ESMF_ClockGet, ESMF_TimeGet - use MOM_ocean_model, only: ocean_public_type, ocean_state_type - use MOM_surface_forcing, only: ice_ocean_boundary_type - use MOM_grid, only: ocean_grid_type - use MOM_domains, only: pass_var - use MOM_error_handler, only: is_root_pe - use mpp_domains_mod, only: mpp_get_compute_domain - use ocn_cpl_indices, only: cpl_indices_type + use ESMF, only: ESMF_clock, ESMF_time, ESMF_ClockGet, ESMF_TimeGet + use MOM_ocean_model_mct, only: ocean_public_type, ocean_state_type + use MOM_surface_forcing_mct, only: ice_ocean_boundary_type + use MOM_grid, only: ocean_grid_type + use MOM_domains, only: pass_var + use MOM_error_handler, only: is_root_pe + use mpp_domains_mod, only: mpp_get_compute_domain + use ocn_cpl_indices, only: cpl_indices_type implicit none private @@ -71,9 +71,6 @@ subroutine ocn_import(x2o, ind, grid, ice_ocean_boundary, ocean_public, logunit, ! sensible heat flux (W/m2) ice_ocean_boundary%t_flux(i,j) = x2o(ind%x2o_Foxx_sen,k) - ! latent heat flux (W/m^2) - ice_ocean_boundary%latent_flux(i,j) = x2o(ind%x2o_Foxx_lat,k) - ! snow&ice melt heat flux (W/m^2) ice_ocean_boundary%seaice_melt_heat(i,j) = x2o(ind%x2o_Fioi_melth,k) @@ -89,8 +86,8 @@ subroutine ocn_import(x2o, ind, grid, ice_ocean_boundary, ocean_public, logunit, ! surface pressure ice_ocean_boundary%p(i,j) = x2o(ind%x2o_Sa_pslv,k) * GRID%mask2dT(i,j) - ! salt flux (minus sign needed here -GMM) - ice_ocean_boundary%salt_flux(i,j) = -x2o(ind%x2o_Fioi_salt,k) * GRID%mask2dT(i,j) + ! salt flux + ice_ocean_boundary%salt_flux(i,j) = x2o(ind%x2o_Fioi_salt,k) * GRID%mask2dT(i,j) ! 1) visible, direct shortwave (W/m2) ! 2) visible, diffuse shortwave (W/m2) @@ -127,8 +124,6 @@ subroutine ocn_import(x2o, ind, grid, ice_ocean_boundary, ocean_public, logunit, day,secs,j,i,ice_ocean_boundary%seaice_melt_heat(i,j) write(logunit,F01)'import: day, secs, j, i, seaice_melt = ',& day,secs,j,i,ice_ocean_boundary%seaice_melt(i,j) - write(logunit,F01)'import: day, secs, j, i, latent_flux = ',& - day,secs,j,i,ice_ocean_boundary%latent_flux(i,j) write(logunit,F01)'import: day, secs, j, i, runoff = ',& day,secs,j,i,ice_ocean_boundary%rofl_flux(i,j) + ice_ocean_boundary%rofi_flux(i,j) write(logunit,F01)'import: day, secs, j, i, psurf = ',& @@ -217,7 +212,7 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day) ! d/dx ssh do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec ! This is a simple second-order difference - ! o2x(ind%o2x_So_dhdx, n) = 0.5 * (ssh(i+1,j) - ssh(i-1,j)) * grid%IdxT(i,j) * grid%mask2dT(i,j) + ! o2x(ind%o2x_So_dhdx, n) = 0.5 * (ssh(i+1,j) - ssh(i-1,j)) * grid%US%m_to_L*grid%IdxT(i,j) * grid%mask2dT(i,j) ! This is a PLM slope which might be less prone to the A-grid null mode slp_L = (ssh(I,j) - ssh(I-1,j)) * grid%mask2dCu(I-1,j) if (grid%mask2dCu(I-1,j)==0.) slp_L = 0. @@ -235,14 +230,14 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day) ! larger extreme values. slope = 0.0 endif - sshx(i,j) = slope * grid%IdxT(i,j) * grid%mask2dT(i,j) + 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 ! d/dy ssh do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec ! This is a simple second-order difference - ! o2x(ind%o2x_So_dhdy, n) = 0.5 * (ssh(i,j+1) - ssh(i,j-1)) * grid%IdyT(i,j) * grid%mask2dT(i,j) + ! o2x(ind%o2x_So_dhdy, n) = 0.5 * (ssh(i,j+1) - ssh(i,j-1)) * grid%US%m_to_L*grid%IdyT(i,j) * grid%mask2dT(i,j) ! This is a PLM slope which might be less prone to the A-grid null mode slp_L = ssh(i,J) - ssh(i,J-1) * grid%mask2dCv(i,J-1) if (grid%mask2dCv(i,J-1)==0.) slp_L = 0. @@ -262,7 +257,7 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day) ! larger extreme values. slope = 0.0 endif - sshy(i,j) = slope * grid%IdyT(i,j) * grid%mask2dT(i,j) + 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 diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 similarity index 81% rename from config_src/mct_driver/ocn_comp_mct.F90 rename to config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 index 5698335b6f..85b7350b77 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 @@ -24,8 +24,6 @@ module ocn_comp_mct shr_file_getLogUnit, shr_file_getLogLevel, & shr_file_setLogUnit, shr_file_setLogLevel -use MOM_surface_forcing, only: IOB_allocate, ice_ocean_boundary_type - ! MOM6 modules use MOM, only: extract_surface_state use MOM_variables, only: surface @@ -38,29 +36,27 @@ module ocn_comp_mct use MOM_time_manager, only: time_type, set_date, set_time, set_calendar_type, NOLEAP use MOM_time_manager, only: operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only: operator(==), operator(/=), operator(>), get_time -use MOM_file_parser, only: get_param, log_version, param_file_type +use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file use MOM_get_input, only: Get_MOM_Input, directories use MOM_EOS, only: gsw_sp_from_sr, gsw_pt_from_ct use MOM_constants, only: CELSIUS_KELVIN_OFFSET use MOM_domains, only: AGRID, BGRID_NE, CGRID_NE, pass_vector use mpp_domains_mod, only: mpp_get_compute_domain +use MOM_io, only: stdout ! Previously inlined - now in separate modules -use MOM_ocean_model, only: ocean_public_type, ocean_state_type -use MOM_ocean_model, only: ocean_model_init , update_ocean_model, ocean_model_end -use MOM_ocean_model, only: convert_state_to_ocean_type -use MOM_surface_forcing, only: surface_forcing_CS, forcing_save_restart +use MOM_ocean_model_mct, only: ocean_public_type, ocean_state_type +use MOM_ocean_model_mct, only: ocean_model_init , update_ocean_model, ocean_model_end +use MOM_ocean_model_mct, only: convert_state_to_ocean_type +use MOM_surface_forcing_mct, only: surface_forcing_CS, forcing_save_restart, ice_ocean_boundary_type use ocn_cap_methods, only: ocn_import, ocn_export -! FMS modules -use time_interp_external_mod, only : time_interp_external - ! MCT indices structure and import and export routines that access mom data use ocn_cpl_indices, only : cpl_indices_type, cpl_indices_init ! GFDL coupler modules -use coupler_types_mod, only : coupler_type_spawn -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_spawn +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data ! By default make data private implicit none; private @@ -90,7 +86,6 @@ module ocn_comp_mct type(cpl_indices_type) :: ind !< Variable IDs logical :: sw_decomp !< Controls whether shortwave is decomposed into 4 components real :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition i/o - integer :: stdout !< standard output unit. (by default, points to ocn.log.* ) character(len=384) :: pointer_filename !< Name of the ascii file that contains the path !! and filename of the latest restart file. end type MCT_MOM_Data @@ -111,8 +106,9 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) type(mct_aVect) , intent(inout) :: o2x_o !< Fluxes from ocean to coupler, computed by ocean character(len=*), optional , intent(in) :: NLFilename !< Namelist filename - ! local variables - type(time_type) :: time0 !< Model start time + ! local variable + type(time_type) :: time0 !< Start time of coupled model's calendar. + type(time_type) :: time_start !< The time at which to initialize the ocean model type(ESMF_time) :: time_var !< ESMF_time variable to query time type(ESMF_time) :: time_in_ESMF !< Initial time for ocean type(ESMF_timeInterval) :: ocn_cpl_interval !< Ocean coupling interval @@ -120,7 +116,9 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) integer :: year, month, day, hour, minute, seconds, seconds_n, seconds_d, rc character(len=240) :: runid !< Run ID character(len=32) :: runtype !< Run type - character(len=240) :: restartfile !< Path/Name of restart file + character(len=512) :: restartfile !< Path/Name of restart file + character(len=2048) :: restartfiles !< Path/Name of restart files. + !! (same as restartfile if a single restart file is to be read in) integer :: nu !< i/o unit to read pointer file character(len=240) :: restart_pointer_file !< File name for restart pointer file character(len=240) :: restartpath !< Path of the restart file @@ -165,6 +163,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) !logical :: lsend_precip_fact !< If T,send precip_fact to cpl for use in fw balance !! (partially-coupled option) character(len=128) :: err_msg !< Error message + integer :: iostat ! set the cdata pointers: call seq_cdata_setptrs(cdata_o, id=MOM_MCT_ID, mpicom=mpicom_ocn, & @@ -192,42 +191,47 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) call shr_file_getLogUnit (shrlogunit) call shr_file_getLogLevel(shrloglev) - glb%stdout = shr_file_getUnit() ! get an unused unit number + stdout = shr_file_getUnit() ! get an unused unit number ! open the ocn_modelio.nml file and then open a log file associated with stdout ocn_modelio_name = 'ocn_modelio.nml' // trim(inst_suffix) - call shr_file_setIO(ocn_modelio_name,glb%stdout) + call shr_file_setIO(ocn_modelio_name,stdout) ! set the shr log io unit number - call shr_file_setLogUnit(glb%stdout) + call shr_file_setLogUnit(stdout) end if call set_calendar_type(NOLEAP) !TODO: confirm this - ! Get the initial time - call ESMF_ClockGet(EClock, currTime=time_var, rc=rc) + ! Get start time + call ESMF_ClockGet(EClock, StartTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) time0 = set_date(year, month, day, hour, minute, seconds, err_msg=err_msg) + ! Get current time + call ESMF_ClockGet(EClock, currTime=time_var, rc=rc) + call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) + time_start = set_date(year, month, day, hour, minute, seconds, err_msg=err_msg) + ! Debugging clocks if (debug .and. is_root_pe()) then - write(glb%stdout,*) 'ocn_init_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_init_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, StartTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_init_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, StopTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_init_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, PrevTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_init_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, TimeStep=ocn_cpl_interval, rc=rc) call ESMF_TimeIntervalGet(ocn_cpl_interval, yy=year, mm=month, d=day, s=seconds, sn=seconds_n, sd=seconds_d, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d + write(stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d endif npes = num_pes() @@ -277,30 +281,45 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) 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. + call close_param_file(param_file) + ! Initialize the MOM6 model runtype = get_runtype() if (runtype == "initial") then ! startup (new run) - 'n' is needed below since we don't specify input_filename in input.nml - call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time0, input_restart_file = 'n') + call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file = 'n') else ! hybrid or branch or continuos runs ! get output path root call seq_infodata_GetData( glb%infodata, outPathRoot=restartpath ) ! read name of restart file in the pointer file nu = shr_file_getUnit() restart_pointer_file = trim(glb%pointer_filename) - if (is_root_pe()) write(glb%stdout,*) 'Reading ocn pointer file: ',restart_pointer_file + if (is_root_pe()) write(stdout,*) 'Reading ocn pointer file: ',restart_pointer_file + restartfile = ""; restartfiles = ""; open(nu, file=restart_pointer_file, form='formatted', status='unknown') - read(nu,'(a)') restartfile + do + read(nu,'(a)', iostat=iostat) restartfile + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else if (iostat/=0) then + call MOM_error(FATAL, 'Error reading rpointer.ocn') + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo close(nu) - !restartfile = trim(restartpath) // trim(restartfile) if (is_root_pe()) then - write(glb%stdout,*) 'Reading restart file: ',trim(restartfile) + write(stdout,*) 'Reading restart file(s): ',trim(restartfiles) end if call shr_file_freeUnit(nu) - call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time0, input_restart_file=trim(restartfile)) + 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(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + write(stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' end if ! Initialize ocn_state%sfc_state out of sight @@ -361,7 +380,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ncouple_per_day = seconds_in_day / ocn_cpl_dt mom_cpl_dt = seconds_in_day / ncouple_per_day if (mom_cpl_dt /= ocn_cpl_dt) then - write(glb%stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' + write(stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' call exit(0) end if @@ -382,10 +401,8 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) if (debug .and. root_pe().eq.pe_here()) print *, "calling seq_infodata_putdata" - call seq_infodata_PutData( glb%infodata, & - ocn_nx = ni , ocn_ny = nj) - call seq_infodata_PutData( glb%infodata, & - ocn_prognostic=.true., ocnrof_prognostic=.true.) + call seq_infodata_PutData(glb%infodata, ocn_nx=ni, ocn_ny=nj) + call seq_infodata_PutData(glb%infodata, ocn_prognostic=.true., ocnrof_prognostic=.true.) if (debug .and. root_pe().eq.pe_here()) print *, "leaving ocean_init_mct" @@ -427,12 +444,15 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) integer :: ocn_cpl_dt !< one ocn coupling interval in seconds. (to be received from cesm) real (kind=8) :: mom_cpl_dt !< one ocn coupling interval in seconds. (internal) integer :: ncouple_per_day !< number of ocean coupled call in one day (non-dim) + integer :: num_rest_files !< number of restart files written + integer :: i + character(len=8) :: suffix ! reset shr logging to ocn log file: if (is_root_pe()) then call shr_file_getLogUnit(shrlogunit) call shr_file_getLogLevel(shrloglev) - call shr_file_setLogUnit(glb%stdout) + call shr_file_setLogUnit(stdout) endif ! Query the beginning time of the current coupling interval @@ -459,7 +479,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) if (runtype /= "continue" .and. runtype /= "branch") then if (debug .and. is_root_pe()) then - write(glb%stdout,*) 'doubling first interval duration!' + write(stdout,*) 'doubling first interval duration!' endif ! shift back the start time by one coupling interval (to align the start time with other components) @@ -475,19 +495,19 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) if (debug .and. is_root_pe()) then call ESMF_ClockGet(EClock, CurrTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_run_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_run_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, StartTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_run_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_run_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, StopTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_run_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_run_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, PrevTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) - write(glb%stdout,*) 'ocn_run_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + write(stdout,*) 'ocn_run_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds call ESMF_ClockGet(EClock, TimeStep=ocn_cpl_interval, rc=rc) call ESMF_TimeIntervalGet(ocn_cpl_interval, yy=year, mm=month, d=day, s=seconds, sn=seconds_n, sd=seconds_d, rc=rc) - write(glb%stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d + write(stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d endif ! set the cdata pointers: @@ -500,10 +520,10 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) !glb%sw_decomp = .false. !END TODO: if (glb%sw_decomp) then - call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, glb%stdout, Eclock, & + call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, stdout, Eclock, & 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, glb%stdout, Eclock ) + call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, stdout, Eclock ) end if ! Update internal ocean @@ -515,7 +535,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) !--- write out intermediate restart file when needed. ! Check alarms for flag to write restart at end of day write_restart_at_eod = seq_timemgr_RestartAlarmIsOn(EClock) - if (debug .and. is_root_pe()) write(glb%stdout,*) 'ocn_run_mct, write_restart_at_eod=', write_restart_at_eod + if (debug .and. is_root_pe()) write(stdout,*) 'ocn_run_mct, write_restart_at_eod=', write_restart_at_eod if (write_restart_at_eod) then ! case name @@ -527,7 +547,8 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV) + glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV, & + num_rest_files=num_rest_files) ! write name of restart file in the rpointer file nu = shr_file_getUnit() @@ -535,8 +556,21 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) restart_pointer_file = trim(glb%pointer_filename) open(nu, file=restart_pointer_file, form='formatted', status='unknown') write(nu,'(a)') trim(restartname) //'.nc' + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(nu,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(nu) - write(glb%stdout,*) 'ocn restart pointer file written: ',trim(restartname) + write(stdout,*) 'ocn restart pointer file written: ',trim(restartname) endif call shr_file_freeUnit(nu) @@ -638,7 +672,7 @@ subroutine ocn_domain_mct( lsize, gsMap_ocn, dom_ocn) integer, pointer :: idata(:) integer :: i,j,k real(kind=SHR_REAL_R8), pointer :: data(:) - real(kind=SHR_REAL_R8) :: m2_to_rad2 + real(kind=SHR_REAL_R8) :: L2_to_rad2 type(ocean_grid_type), pointer :: grid => NULL() ! A pointer to a grid structure grid => glb%grid ! for convenience @@ -683,11 +717,11 @@ subroutine ocn_domain_mct( lsize, gsMap_ocn, dom_ocn) call mct_gGrid_importRattr(dom_ocn,"lat",data,lsize) k = 0 - m2_to_rad2 = 1./grid%Rad_Earth**2 + L2_to_rad2 = 1.0 / grid%Rad_Earth_L**2 do j = grid%jsc, grid%jec do i = grid%isc, grid%iec k = k + 1 ! Increment position within gindex - data(k) = grid%AreaT(i,j) * m2_to_rad2 + data(k) = grid%AreaT(i,j) * L2_to_rad2 enddo enddo call mct_gGrid_importRattr(dom_ocn,"area",data,lsize) @@ -715,15 +749,15 @@ end subroutine ocn_domain_mct call seq_infodata_GetData( glb%infodata, start_type=starttype) - if ( trim(starttype) == trim(seq_infodata_start_type_start)) then - get_runtype = "initial" + if ( trim(starttype) == trim(seq_infodata_start_type_start)) then + get_runtype = "initial" else if (trim(starttype) == trim(seq_infodata_start_type_cont) ) then - get_runtype = "continue" + get_runtype = "continue" else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then - get_runtype = "branch" + get_runtype = "branch" else - write(glb%stdout,*) 'ocn_comp_mct ERROR: unknown starttype' - call exit(0) + write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype' + call exit(0) end if return @@ -745,7 +779,7 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) end subroutine ocean_model_init_sfc @@ -813,4 +847,61 @@ end subroutine ocean_model_init_sfc !! CO2 !! DMS +!> Allocates ice-ocean boundary type containers and sets to 0. +subroutine IOB_allocate(IOB, isc, iec, jsc, jec) + type(ice_ocean_boundary_type), intent(inout) :: IOB !< An ice-ocean boundary type with fluxes to drive + integer, intent(in) :: isc, iec, jsc, jec !< The ocean's local grid size + + allocate ( IOB% rofl_flux (isc:iec,jsc:jec), & + IOB% rofi_flux (isc:iec,jsc:jec), & + IOB% u_flux (isc:iec,jsc:jec), & + IOB% v_flux (isc:iec,jsc:jec), & + IOB% t_flux (isc:iec,jsc:jec), & + IOB% seaice_melt_heat (isc:iec,jsc:jec),& + IOB% seaice_melt (isc:iec,jsc:jec), & + IOB% q_flux (isc:iec,jsc:jec), & + IOB% salt_flux (isc:iec,jsc:jec), & + IOB% lw_flux (isc:iec,jsc:jec), & + IOB% sw_flux_vis_dir (isc:iec,jsc:jec), & + IOB% sw_flux_vis_dif (isc:iec,jsc:jec), & + IOB% sw_flux_nir_dir (isc:iec,jsc:jec), & + IOB% sw_flux_nir_dif (isc:iec,jsc:jec), & + IOB% lprec (isc:iec,jsc:jec), & + IOB% fprec (isc:iec,jsc:jec), & + IOB% ustar_berg (isc:iec,jsc:jec), & + IOB% area_berg (isc:iec,jsc:jec), & + IOB% mass_berg (isc:iec,jsc:jec), & + IOB% calving (isc:iec,jsc:jec), & + IOB% runoff_hflx (isc:iec,jsc:jec), & + IOB% calving_hflx (isc:iec,jsc:jec), & + IOB% mi (isc:iec,jsc:jec), & + IOB% p (isc:iec,jsc:jec)) + + IOB%rofl_flux = 0.0 + IOB%rofi_flux = 0.0 + IOB%u_flux = 0.0 + IOB%v_flux = 0.0 + IOB%t_flux = 0.0 + IOB%seaice_melt_heat = 0.0 + IOB%seaice_melt = 0.0 + IOB%q_flux = 0.0 + IOB%salt_flux = 0.0 + IOB%lw_flux = 0.0 + IOB%sw_flux_vis_dir = 0.0 + IOB%sw_flux_vis_dif = 0.0 + IOB%sw_flux_nir_dir = 0.0 + IOB%sw_flux_nir_dif = 0.0 + IOB%lprec = 0.0 + IOB%fprec = 0.0 + IOB%ustar_berg = 0.0 + IOB%area_berg = 0.0 + IOB%mass_berg = 0.0 + IOB%calving = 0.0 + IOB%runoff_hflx = 0.0 + IOB%calving_hflx = 0.0 + IOB%mi = 0.0 + IOB%p = 0.0 + +end subroutine IOB_allocate + end module ocn_comp_mct diff --git a/config_src/mct_driver/ocn_cpl_indices.F90 b/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 similarity index 97% rename from config_src/mct_driver/ocn_cpl_indices.F90 rename to config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 index a701083c0c..3f47c01903 100644 --- a/config_src/mct_driver/ocn_cpl_indices.F90 +++ b/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 @@ -172,11 +172,11 @@ subroutine cpl_indices_init(ind) ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'Foxx_swnet_afracr') do ncat = 1, ice_ncat - write(cncat,'(i2.2)') ncat - ncol = ncat+1 - ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) - ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) - ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) + write(cncat,'(i2.2)') ncat + ncol = ncat+1 + ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) + ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) + ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) enddo else mcog_ncols = 1 diff --git a/config_src/solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 similarity index 83% rename from config_src/solo_driver/atmos_ocean_fluxes.F90 rename to config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 index 4a4ddf6da3..fb9fbe3e22 100644 --- a/config_src/solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 @@ -20,9 +20,12 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, character(len=*), intent(in) :: flux_type !< An unused argument character(len=*), intent(in) :: implementation !< An unused argument integer, optional, intent(in) :: atm_tr_index !< An unused argument - real, dimension(:), optional, intent(in) :: param !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument that would be used to + !! pass parameters for flux parameterizations + !! in other contexts [various] logical, dimension(:), optional, intent(in) :: flag !< An unused argument - real, optional, intent(in) :: mol_wt !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument that would usually be + !! the tracer's molecular weight [g mol-1] character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 new file mode 100644 index 0000000000..753269116a --- /dev/null +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -0,0 +1,498 @@ +program Shelf_main + +! This file is part of MOM6. See LICENSE.md for the license. + +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* By Daniel Goldberg, Olga Sergienko, and Robert Hallberg * +!* * +!* This file is the driver for the stand-alone ice-sheet model that * +!* is under development at GFDL. When used in a mode that is coupled * +!* with an ocean model or a full coupled model, a different driver * +!* will be used. This file orchestrates the calls to the appropriate * +!* initialization routines, to the subroutine that steps the model, * +!* and coordinates the saving and reading of restarts. * +!* A description of all of the files that constitute this ice shelf * +!* component is found in the comments at the beginning of * +!* MOM_ice_shelf.F90. The arguments of each subroutine are * +!* described where the subroutine is defined. * +!* * +!* Macros written all in capital letters are defined in MOM_memory.h * +!* * +!********+*********+*********+*********+*********+*********+*********+** + + use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end + use MOM_cpu_clock, only : CLOCK_COMPONENT + use MOM_debugging, only : MOM_debugging_init + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init, set_axes_info + use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration + use MOM_diag_manager_infra, only : diag_manager_set_time_end_infra + use MOM_domains, only : MOM_infra_init, MOM_infra_end + use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var + use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid + use MOM_error_handler, only : 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 + use MOM_fixed_initialization, only : MOM_initialize_fixed + use MOM_get_input, only : Get_MOM_Input, directories + use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end + use MOM_hor_index, only : hor_index_type, hor_index_init + use MOM_io, only : MOM_io_init, file_exists, open_ASCII_file, close_file + use MOM_io, only : check_nml_error, io_infra_init, io_infra_end + use MOM_io, only : APPEND_FILE, READONLY_FILE, SINGLE_FILE + use MOM_open_boundary, only : ocean_OBC_type + use MOM_restart, only : save_restart + 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 : operator(+), operator(-), operator(*), operator(/) + use MOM_time_manager, only : operator(>), operator(<), operator(>=) + use MOM_time_manager, only : increment_date, set_calendar_type, month_name + use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR + use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid + use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init + use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd + use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init + use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_forcing_type, only : forcing + use MOM_ice_shelf_initialize, only : initialize_ice_SMB + + use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS + use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf + + implicit none + +#include + + logical :: use_ice_shelf = .false. ! If .true., use the ice shelf model for + ! part of the domain. + + ! This is .true. if incremental restart files may be saved. + logical :: permit_incr_restart = .true. + + integer :: ns ! Running number of external timesteps. + integer :: ns_ice ! Running number of internal timesteps in solo_step_ice_shelf. + + ! nmax is the number of iterations after which to stop so that the simulation does not exceed its + ! CPU time limit. nmax is determined by evaluating the CPU time used between successive calls to + ! write_cputime. Initially it is set to be very large. + integer :: nmax=2000000000 + ! A structure containing pointers to the thermodynamic forcing fields + ! at the ocean surface. + type(forcing) :: fluxes + ! A structure containing several relevant directory paths. + type(directories) :: dirs + + ! A suite of time types for use by the solo ice model. + type(time_type), target :: Time ! A copy of the model's time. + ! Other modules can set pointers to this and + ! change it to manage diagnostics. + type(time_type) :: Master_Time ! The ocean model's master clock. No other + ! modules are ever given access to this. + type(time_type) :: Time1 ! The value of the ocean model's time at the + ! start of a call to step_MOM. + type(time_type) :: Start_time ! The start time of the simulation. + type(time_type) :: segment_start_time ! The start time of this run segment. + type(time_type) :: Time_end ! End time for the segment or experiment. + type(time_type) :: restart_time ! The next time to write restart files. + type(time_type) :: Time_step_shelf ! A time_type version of time_step. + type(time_type) :: time_chg ! An amount of time to adjust the segment_start_time + ! and elapsed time to avoid roundoff problems. + + real :: elapsed_time = 0.0 ! Elapsed time in this run [T ~> s]. + + logical :: elapsed_time_master ! If true, elapsed time is used to set the + ! model's master clock (Time). This is needed + ! if Time_step_shelf is not an exact + ! representation of time_step. + real :: time_step ! The time step [T ~> s] + + ! A pointer to a structure containing metrics and related information. + type(ocean_grid_type), pointer :: ocn_grid => NULL() + + type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid + type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the ocean vertical grid structure + + !> Pointer to the MOM open boundary condition type + type(ocean_OBC_type), pointer :: OBC => NULL() + + ! A pointer to a structure containing dimensional unit scaling factors. + type(unit_scale_type), pointer :: US => NULL() + + type(diag_ctrl), pointer :: & + diag => NULL() ! A pointer to the diagnostic regulatory structure + + integer :: Restart_control ! An integer that is bit-tested to determine whether + ! incremental restart files are saved and whether they + ! have a time stamped name. +1 (bit 0) for generic + ! files and +2 (bit 1) for time-stamped files. A + ! restart file is saved at the end of a run segment + ! unless Restart_control is negative. + + real :: Time_unit ! The time unit for the following input fields [s]. + type(time_type) :: restint ! The time between saves of the restart file. + type(time_type) :: daymax ! The final day of the simulation. + + integer :: CPU_steps ! The number of steps between writing CPU time. + integer :: date_init(6)=0 ! The start date of the whole simulation. + integer :: date(6)=-1 ! Possibly the start date of this run segment. + integer :: years=0, months=0, days=0 ! These may determine the segment run + integer :: hours=0, minutes=0, seconds=0 ! length, if read from a namelist. + integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. + type(param_file_type) :: param_file ! The structure indicating the file(s) + ! containing all run-time parameters. + character(len=9) :: month + character(len=16) :: calendar = 'noleap' + integer :: calendar_type=-1 + + integer :: unit, io_status, ierr + logical :: symmetric + + logical :: unit_in_use + integer :: initClock, mainClock, termClock + + type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() + type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() + !----------------------------------------------------------------------- + + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mod_name = "SHELF_main (ice_shelf_driver)" ! This module's name. + + namelist /ice_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds + + !===================================================================== + + call write_cputime_start_clock(write_CPU_CSp) + + call MOM_infra_init() ; call io_infra_init() + + ! These clocks are on the global pelist. + initClock = cpu_clock_id( 'Initialization' ) + mainClock = cpu_clock_id( 'Main loop' ) + termClock = cpu_clock_id( 'Termination' ) + call cpu_clock_begin(initClock) + + call MOM_mesg('======== Model being driven by ice_shelf_driver ========', 2) + call callTree_waypoint("Program Shelf_main, ice_shelf_driver.F90") + + if (file_exists('input.nml')) then + ! Provide for namelist specification of the run length and calendar data. + call open_ASCII_file(unit, 'input.nml', action=READONLY_FILE) + read(unit, ice_solo_nml, iostat=io_status) + call close_file(unit) + ierr = check_nml_error(io_status,'ice_solo_nml') + if (years+months+days+hours+minutes+seconds > 0) then + if (is_root_pe()) write(*,ice_solo_nml) + endif + endif + + ! Get the names of the I/O directories and initialization file. + ! Also calls the subroutine that opens run-time parameter files. + call Get_MOM_Input(param_file, dirs) + + ! Read ocean_solo restart, which can override settings from the namelist. + 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) + read(unit,*) calendar_type + read(unit,*) date_init + read(unit,*) date + 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 + elseif (calendar(1:1) /= ' ') then + call MOM_error(FATAL,'Shelf_driver: Invalid namelist value '//trim(calendar)//' for calendar') + else + call MOM_error(FATAL,'Shelf_driver: No namelist value for calendar') + endif + endif + call set_calendar_type(calendar_type) + + + 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)) + else + Start_time = real_to_time(0.0) + endif + + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, US) + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mod_name, version, "") + + call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & + "If true, call the code to apply an ice shelf model over "//& + "some of the domain.", default=.false.) + + if (.not.use_ice_shelf) call MOM_error(FATAL, "Shelf_driver: Run stops unless ICE_SHELF is true.") + + call get_param(param_file, mod_name, "ICE_VELOCITY_TIMESTEP", time_step, & + "The time step for changing forcing, coupling with other "//& + "components, or potentially writing certain diagnostics.", & + units="s", scale=US%s_to_T, fail_if_missing=.true.) + + if (sum(date) >= 0) then + ! In this case, the segment starts at a time fixed by ocean_solo.res + segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) + Time = segment_start_time + else + ! In this case, the segment starts at Start_time. + Time = Start_time + endif + + ! This is the start of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("Start of ice shelf initialization.") + + call MOM_debugging_init(param_file) + call diag_mediator_infrastructure_init() + call MOM_io_init(param_file) + + ! Set up the ocean model domain and grid; the ice model grid is set in initialize_ice_shelf, + ! but the grids have strong commonalities in this configuration, and the ocean grid is required + ! to set up the diag mediator control structure. + allocate(ocn_grid) + call MOM_domains_init(ocn_grid%domain, param_file) !, domain_name='MOM') + allocate(HI) + call hor_index_init(ocn_grid%Domain, HI, param_file) + allocate(dG) + call create_dyn_horgrid(dG, HI) + call clone_MOM_domain(ocn_grid%Domain, dG%Domain) + + ! Initialize the ocean grid and topography. + call MOM_initialize_fixed(dG, US, OBC, param_file, .true., dirs%output_directory) + call MOM_grid_init(ocn_grid, param_file, US, HI) + call copy_dyngrid_to_MOM_grid(dG, ocn_grid, US) + call destroy_dyn_horgrid(dG) + + ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at + ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. + call verticalGridInit(param_file, GV, US) + allocate(diag) + call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + + call callTree_waypoint("returned from diag_mediator_init()") + + call set_axes_info(ocn_grid, GV, US, param_file, diag) + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, & + Start_time, dirs%output_directory, fluxes_in=fluxes, solo_ice_sheet_in=.true.) + + call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) + + ! This is the end of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("End of ice shelf initialization.") + + Master_Time = Time +! grid => ice_shelf_CSp%grid + + 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) + if (elapsed_time_master) & + call MOM_mesg("Using real elapsed time for the master clock.", 2) + + ! Determine the segment end time, either from the namelist file or parsed input file. + call get_param(param_file, mod_name, "TIMEUNIT", Time_unit, & + "The time unit for DAYMAX and RESTINT.", & + units="s", default=86400.0) + if (years+months+days+hours+minutes+seconds > 0) then + Time_end = increment_date(Time, years, months, days, hours, minutes, seconds) + call MOM_mesg('Segment run length determined from ice_solo_nml.', 2) + call get_param(param_file, mod_name, "DAYMAX", daymax, & + "The final time of the whole simulation, in units of "//& + "TIMEUNIT seconds. This also sets the potential end "//& + "time of the present run segment if the end time is "//& + "not set (as it was here) via ocean_solo_nml in input.nml.", & + timeunit=Time_unit, default=Time_end) + else + call get_param(param_file, mod_name, "DAYMAX", daymax, & + "The final time of the whole simulation, in units of "//& + "TIMEUNIT seconds. This also sets the potential end "//& + "time of the present run segment if the end time is "//& + "not set via ocean_solo_nml in input.nml.", & + timeunit=Time_unit, fail_if_missing=.true.) + Time_end = daymax + endif + + call diag_manager_set_time_end_infra (Time_end) + + if (Time >= Time_end) call MOM_error(FATAL, & + "Shelf_driver: The run has been started at or after the end time of the run.") + + call get_param(param_file, mod_name, "RESTART_CONTROL", Restart_control, & + "An integer whose bits encode which restart files are "//& + "written. Add 2 (bit 1) for a time-stamped file, and odd "//& + "(bit 0) for a non-time-stamped file. A non-time-stamped "//& + "restart file is saved at the end of the run segment "//& + "for any non-negative value.", default=1) + call get_param(param_file, mod_name, "RESTINT", restint, & + "The interval between saves of the restart file in units "//& + "of TIMEUNIT. Use 0 (the default) to not save "//& + "incremental restart files at all.", default=real_to_time(0.0), & + timeunit=Time_unit) + call get_param(param_file, mod_name, "WRITE_CPU_STEPS", cpu_steps, & + "The number of coupled timesteps between writing the cpu "//& + "time. If this is not positive, do not check cpu time, and "//& + "the segment run-length can not be set via an elapsed CPU time.", & + default=1000) + + call log_param(param_file, mod_name, "ELAPSED TIME AS MASTER", elapsed_time_master) + + if (cpu_steps > 0) & + call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & + write_CPU_CSp) + + ! Close the param_file. No further parsing of input is possible after this. + call close_param_file(param_file) + call diag_mediator_close_registration(diag) + + ! Write out a time stamp file. + if (is_root_pe() .and. (calendar_type /= NO_CALENDAR)) then + call open_ASCII_file(unit, 'time_stamp.out', action=APPEND_FILE) + call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + write(unit,'(6i4,2x,a3)') date, month(1:3) + call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + write(unit,'(6i4,2x,a3)') date, month(1:3) + call close_file(unit) + endif + + if (cpu_steps > 0) call write_cputime(Time, 0, write_CPU_CSp) + + if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & + .or. (Restart_control < 0)) permit_incr_restart = .false. + + if (restint > real_to_time(0.0)) then + ! restart_time is the next integral multiple of restint. + restart_time = Start_time + restint * & + (1 + ((Time + Time_step_shelf) - Start_time) / restint) + else + ! Set the time so late that there is no intermediate restart. + restart_time = Time_end + Time_step_shelf + permit_incr_restart = .false. + endif + + call cpu_clock_end(initClock) !end initialization + + call cpu_clock_begin(mainClock) !begin main loop + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MAIN LOOP !!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ns = 1 ; ns_ice = 1 + do while ((ns < nmax) .and. (Time < Time_end)) + call callTree_enter("Main loop, Shelf_driver.F90", ns) + + ! 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) + +! Time = Time + Time_step_shelf +! This is here to enable fractional-second time steps. + elapsed_time = elapsed_time + time_step + if (elapsed_time > 2.0e9*US%s_to_T) then + ! This is here to ensure that the conversion from a real to an integer can be accurately + ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time + ! does not lose resolution of order the timetype's resolution, provided that the timestep and + ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller + ! value would be required. + time_chg = real_to_time(US%T_to_s*elapsed_time) + segment_start_time = segment_start_time + time_chg + elapsed_time = elapsed_time - US%s_to_T*time_type_to_real(time_chg) + endif + if (elapsed_time_master) then + Master_Time = segment_start_time + real_to_time(US%T_to_s*elapsed_time) + else + Master_Time = Master_Time + Time_step_shelf + endif + Time = Master_Time + + if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then + call write_cputime(Time, ns, write_CPU_CSp, nmax) + endif ; endif + +! See if it is time to write out a restart file - timestamped or not. + if ((permit_incr_restart) .and. (Time + (Time_step_shelf/2) > restart_time)) then + if (BTEST(Restart_control,1)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) + endif + if (BTEST(Restart_control,0)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) + endif + ! Write ice shelf solo restart file. + if (is_root_pe())then + call open_ASCII_file(unit, trim(dirs%restart_output_dir)//'shelf.res') + write(unit, '(i6,8x,a)') calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Model start time: year, month, day, hour, minute, second' + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Current model time: year, month, day, hour, minute, second' + call close_file(unit) + endif + restart_time = restart_time + restint + endif + + ns = ns + 1 + call callTree_leave("Main loop") + enddo + + call cpu_clock_end(mainClock) + call cpu_clock_begin(termClock) + if (Restart_control>=0) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, & + dirs%restart_output_dir) + + ! Write ice shelf solo restart file. + if (is_root_pe())then + call open_ASCII_file(unit, trim(dirs%restart_output_dir)//'shelf.res') + write(unit, '(i6,8x,a)') calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Model start time: year, month, day, hour, minute, second' + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Current model time: year, month, day, hour, minute, second' + call close_file(unit) + endif + endif + + if (is_root_pe()) then + do unit=10,1967 + INQUIRE(unit,OPENED=unit_in_use) + if (.not.unit_in_use) exit + enddo + open(unit,FILE="exitcode",FORM="FORMATTED",STATUS="REPLACE",action="WRITE") + if (Time < daymax) then + write(unit,*) 9 + else + write(unit,*) 0 + endif + close(unit) + endif + + call callTree_waypoint("End Shelf_main") + call ice_shelf_end(ice_shelf_CSp) + call diag_mediator_end(Time, diag, end_diag_manager=.true.) + if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) + call cpu_clock_end(termClock) + + call io_infra_end ; call MOM_infra_end + +end program Shelf_main diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 new file mode 100644 index 0000000000..3e3abba674 --- /dev/null +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -0,0 +1,2957 @@ +!> This module contains a set of subroutines that are required by NUOPC. + +module MOM_cap_mod + +use MOM_domains, only: get_domain_extent +use MOM_io, only: stdout, io_infra_end +use mpp_domains_mod, only: mpp_get_compute_domains +use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain +use mpp_domains_mod, only: mpp_get_domain_npes + +use MOM_time_manager, only: set_calendar_type, time_type, set_time, set_date +use MOM_time_manager, only: GREGORIAN, JULIAN, NOLEAP +use MOM_time_manager, only: operator( <= ), operator( < ), operator( >= ) +use MOM_time_manager, only: operator( + ), operator( - ), operator( / ) +use MOM_time_manager, only: operator( * ), operator( /= ), operator( > ) +use MOM_domains, only: MOM_infra_init, MOM_infra_end +use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file +use MOM_get_input, only: get_MOM_input, directories +use MOM_domains, only: pass_var, pe_here +use MOM_error_handler, only: MOM_error, FATAL, is_root_pe +use MOM_grid, only: ocean_grid_type, get_global_grid_size +use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type +use MOM_ocean_model_nuopc, only: ocean_model_restart, ocean_public_type, ocean_state_type +use MOM_ocean_model_nuopc, only: ocean_model_init_sfc, ocean_model_flux_init +use MOM_ocean_model_nuopc, only: ocean_model_init, update_ocean_model, ocean_model_end +use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh, query_ocean_state +use MOM_cap_time, only: AlarmInit +use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, mod2med_areacor +use MOM_cap_methods, only: med2mod_areacor, state_diagnose +use MOM_cap_methods, only: ChkErr +use MOM_ensemble_manager, only: ensemble_manager_init +use MOM_coms, only: sum_across_PEs + +#ifdef CESMCOUPLED +use shr_log_mod, only: shr_log_setLogUnit +use nuopc_shr_methods, only: get_component_instance +#endif +use time_utils_mod, only: esmf2fms_time + +use, intrinsic :: iso_fortran_env, only: output_unit + +use ESMF, only: ESMF_ClockAdvance, ESMF_ClockGet, ESMF_ClockPrint, ESMF_VMget +use ESMF, only: ESMF_ClockGetAlarm, ESMF_ClockGetNextTime, ESMF_ClockAdvance +use ESMF, only: ESMF_ClockSet, ESMF_Clock, ESMF_GeomType_Flag, ESMF_LOGMSG_INFO +use ESMF, only: ESMF_Grid, ESMF_GridCreate, ESMF_GridAddCoord +use ESMF, only: ESMF_GridGetCoord, ESMF_GridAddItem, ESMF_GridGetItem +use ESMF, only: ESMF_GridComp, ESMF_GridCompSetEntryPoint, ESMF_GridCompGet +use ESMF, only: ESMF_LogWrite, ESMF_LogSetError +use ESMF, only: ESMF_LOGERR_PASSTHRU, ESMF_KIND_R8, ESMF_RC_VAL_WRONG +use ESMF, only: ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_SUCCESS +use ESMF, only: ESMF_METHOD_INITIALIZE, ESMF_MethodRemove, ESMF_State +use ESMF, only: ESMF_LOGMSG_INFO, ESMF_RC_ARG_BAD, ESMF_VM, ESMF_Time +use ESMF, only: ESMF_TimeInterval, ESMF_MAXSTR, ESMF_VMGetCurrent +use ESMF, only: ESMF_VMGet, ESMF_TimeGet, ESMF_TimeIntervalGet, ESMF_MeshGet +use ESMF, only: ESMF_MethodExecute, ESMF_Mesh, ESMF_DeLayout, ESMF_Distgrid +use ESMF, only: ESMF_DistGridConnection, ESMF_StateItem_Flag, ESMF_KIND_I4 +use ESMF, only: ESMF_KIND_I8, ESMF_FAILURE, ESMF_DistGridCreate, ESMF_MeshCreate +use ESMF, only: ESMF_FILEFORMAT_ESMFMESH, ESMF_DELayoutCreate, ESMF_DistGridConnectionSet +use ESMF, only: ESMF_DistGridGet, ESMF_STAGGERLOC_CORNER, ESMF_GRIDITEM_MASK +use ESMF, only: ESMF_TYPEKIND_I4, ESMF_TYPEKIND_R8, ESMF_STAGGERLOC_CENTER +use ESMF, only: ESMF_GRIDITEM_AREA, ESMF_Field, ESMF_ALARM, ESMF_VMLogMemInfo +use ESMF, only: ESMF_AlarmIsRinging, ESMF_AlarmRingerOff, ESMF_StateRemove +use ESMF, only: ESMF_FieldCreate, ESMF_LOGMSG_ERROR, ESMF_LOGMSG_WARNING +use ESMF, only: ESMF_COORDSYS_SPH_DEG, ESMF_GridCreate, ESMF_INDEX_DELOCAL +use ESMF, only: ESMF_MESHLOC_ELEMENT, ESMF_RC_VAL_OUTOFRANGE, ESMF_StateGet +use ESMF, only: ESMF_TimePrint, ESMF_AlarmSet, ESMF_FieldGet, ESMF_Array +use ESMF, only: ESMF_FieldRegridGetArea +use ESMF, only: ESMF_ArrayCreate +use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE +use ESMF, only: ESMF_VMBroadcast, ESMF_VMReduce, ESMF_REDUCE_MAX, ESMF_REDUCE_MIN +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled +use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite +use ESMF, only: ESMF_END_ABORT, ESMF_Finalize +use ESMF, only: ESMF_REDUCE_MAX, ESMF_REDUCE_MIN, ESMF_VMAllReduce +use ESMF, only: operator(==), operator(/=), operator(+), operator(-) + +! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. +!! Model does not compile with "use ESMF, only: ESMF_GridCompGetInternalState" +!! Is this okay? + +use NUOPC, only: NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize +use NUOPC, only: NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet, NUOPC_CompAttributeAdd +use NUOPC, only: NUOPC_Advertise, NUOPC_SetAttribute, NUOPC_IsUpdated, NUOPC_Write +use NUOPC, only: NUOPC_IsConnected, NUOPC_Realize, NUOPC_CompAttributeSet +use NUOPC_Model, only: NUOPC_ModelGet +use NUOPC_Model, only: model_routine_SS => SetServices +use NUOPC_Model, only: model_label_Advance => label_Advance +use NUOPC_Model, only: model_label_DataInitialize => label_DataInitialize +use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock +use NUOPC_Model, only: model_label_Finalize => label_Finalize +use NUOPC_Model, only: SetVM + +implicit none; private + +public SetServices +public SetVM + +!> Internal state type with pointers to three types defined by MOM. +type ocean_internalstate_type + type(ocean_public_type), pointer :: ocean_public_type_ptr + type(ocean_state_type), pointer :: ocean_state_type_ptr + type(ice_ocean_boundary_type), pointer :: ice_ocean_boundary_type_ptr +end type + +!> Wrapper-derived type required to associate an internal state instance +!! with the ESMF/NUOPC component +type ocean_internalstate_wrapper + type(ocean_internalstate_type), pointer :: ptr +end type + +!> Contains field information +type fld_list_type + character(len=64) :: stdname + character(len=64) :: shortname + character(len=64) :: transferOffer + integer :: ungridded_lbound = 0 + integer :: ungridded_ubound = 0 +end type fld_list_type + +integer,parameter :: fldsMax = 100 +integer :: fldsToOcn_num = 0 +type (fld_list_type) :: fldsToOcn(fldsMax) +integer :: fldsFrOcn_num = 0 +type (fld_list_type) :: fldsFrOcn(fldsMax) + +integer :: dbug = 0 +integer :: import_slice = 1 +integer :: export_slice = 1 +character(len=256) :: tmpstr +logical :: write_diagnostics = .false. +logical :: overwrite_timeslice = .false. +logical :: write_runtimelog = .false. +character(len=32) :: runtype !< run type +logical :: profile_memory = .true. +logical :: grid_attach_area = .false. +logical :: use_coldstart = .true. +logical :: use_mommesh = .true. +logical :: restart_eor = .false. +character(len=128) :: scalar_field_name = '' +integer :: scalar_field_count = 0 +integer :: scalar_field_idx_grid_nx = 0 +integer :: scalar_field_idx_grid_ny = 0 +character(len=*),parameter :: u_FILE_u = & + __FILE__ + +#ifdef CESMCOUPLED +logical :: cesm_coupled = .true. +type(ESMF_GeomType_Flag) :: geomtype = ESMF_GEOMTYPE_MESH +#else +logical :: cesm_coupled = .false. +type(ESMF_GeomType_Flag) :: geomtype +#endif +character(len=8) :: restart_mode = 'alarms' +character(len=16) :: inst_suffix = '' +real(8) :: timere + +type(ESMF_Time), allocatable :: restartFhTimes(:) + +contains + +!> NUOPC SetService method is the only public entry point. +!! SetServices registers all of the user-provided subroutines +!! in the module with the NUOPC layer. +!! +!! @param gcomp an ESMF_GridComp object +!! @param rc return code +subroutine SetServices(gcomp, rc) + + type(ESMF_GridComp) :: gcomp !< an ESMF_GridComp object + integer, intent(out) :: rc !< return code + + ! local variables + character(len=*),parameter :: subname='(MOM_cap:SetServices)' + + rc = ESMF_SUCCESS + + ! the NUOPC model component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=InitializeP0, phase=0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv03p1"/), userRoutine=InitializeAdvertise, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv03p3"/), userRoutine=InitializeRealize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !------------------ + ! attach specializing method(s) + !------------------ + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_DataInitialize, & + specRoutine=DataInitialize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & + specRoutine=ModelAdvance, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & + specRoutine=ModelSetRunClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & + specRoutine=ocean_model_finalize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + +end subroutine SetServices + +!> First initialize subroutine called by NUOPC. The purpose +!! is to set which version of the Initialize Phase Definition (IPD) +!! to use. +!! +!! For this MOM cap, we are using IPDv01. +!! +!! @param gcomp an ESMF_GridComp object +!! @param importState an ESMF_State object for import fields +!! @param exportState an ESMF_State object for export fields +!! @param clock an ESMF_Clock object +!! @param rc return code +subroutine InitializeP0(gcomp, importState, exportState, clock, rc) + type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object + type(ESMF_State) :: importState, exportState !< ESMF_State object for + !! import/export fields + type(ESMF_Clock) :: clock !< ESMF_Clock object + integer, intent(out) :: rc !< return code + + ! local variables + logical :: isPresent, isSet + integer :: iostat + character(len=64) :: value, logmsg + character(len=*),parameter :: subname='(MOM_cap:InitializeP0)' + type(ESMF_VM) :: vm + integer :: mype + + rc = ESMF_SUCCESS + + ! Switch to IPDv03 by filtering all other phaseMap entries + call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & + acceptStringList=(/"IPDv03p"/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + write_diagnostics = .false. + call NUOPC_CompAttributeGet(gcomp, name="DumpFields", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) write_diagnostics=(trim(value)=="true") + + write(logmsg,*) write_diagnostics + call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) + + write_runtimelog = .false. + call NUOPC_CompAttributeGet(gcomp, name="RunTimeLog", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) write_runtimelog=(trim(value)=="true") + write(logmsg,*) write_runtimelog + call ESMF_LogWrite('MOM_cap:RunTimeLog = '//trim(logmsg), ESMF_LOGMSG_INFO) + + overwrite_timeslice = .false. + call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) overwrite_timeslice=(trim(value)=="true") + write(logmsg,*) overwrite_timeslice + call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO) + + profile_memory = .false. + call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) profile_memory=(trim(value)=="true") + write(logmsg,*) profile_memory + call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO) + + grid_attach_area = .false. + call NUOPC_CompAttributeGet(gcomp, name="GridAttachArea", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) grid_attach_area=(trim(value)=="true") + write(logmsg,*) grid_attach_area + call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=value, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(value,*) dbug + end if + write(logmsg,'(i6)') dbug + call ESMF_LogWrite('MOM_cap:dbug = '//trim(logmsg), ESMF_LOGMSG_INFO) + + scalar_field_name = "" + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + scalar_field_name = trim(value) + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) + endif + + scalar_field_count = 0 + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(value, *, iostat=iostat) scalar_field_count + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldCount not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_count + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) + endif + + scalar_field_idx_grid_nx = 0 + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(value, *, iostat=iostat) scalar_field_idx_grid_nx + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_idx_grid_nx + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) + endif + + scalar_field_idx_grid_ny = 0 + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(value, *, iostat=iostat) scalar_field_idx_grid_ny + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_idx_grid_ny + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) + endif + + use_coldstart = .true. + call NUOPC_CompAttributeGet(gcomp, name="use_coldstart", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) use_coldstart=(trim(value)=="true") + write(logmsg,*) use_coldstart + call ESMF_LogWrite('MOM_cap:use_coldstart = '//trim(logmsg), ESMF_LOGMSG_INFO) + + use_mommesh = .true. + call NUOPC_CompAttributeGet(gcomp, name="use_mommesh", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) use_mommesh=(trim(value)=="true") + write(logmsg,*) use_mommesh + call ESMF_LogWrite('MOM_cap:use_mommesh = '//trim(logmsg), ESMF_LOGMSG_INFO) + + if(use_mommesh)then + geomtype = ESMF_GEOMTYPE_MESH + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', isPresent=isPresent, isSet=isSet, rc=rc) + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite('geomtype set to mesh but mesh_ocn is not specified', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + else + geomtype = ESMF_GEOMTYPE_GRID + endif + + ! Read end of run restart config option + call NUOPC_CompAttributeGet(gcomp, name="write_restart_at_endofrun", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(value) .eq. '.true.') restart_eor = .true. + end if + +end subroutine + +!> Called by NUOPC to advertise import and export fields. "Advertise" +!! simply means that the standard names of all import and export +!! fields are supplied. The NUOPC layer uses these to match fields +!! between components in the coupled system. +!! +!! @param gcomp an ESMF_GridComp object +!! @param importState an ESMF_State object for import fields +!! @param exportState an ESMF_State object for export fields +!! @param clock an ESMF_Clock object +!! @param rc return code +subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object + type(ESMF_State) :: importState, exportState !< ESMF_State object for + !! import/export fields + type(ESMF_Clock) :: clock !< ESMF_Clock object + integer, intent(out) :: rc !< return code + + ! local variables + type(ESMF_VM) :: vm + type(ESMF_Time) :: MyTime + type(ESMF_TimeInterval) :: TINT + type (ocean_public_type), pointer :: ocean_public => NULL() + type (ocean_state_type), pointer :: ocean_state => NULL() + type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() + type(ocean_internalstate_wrapper) :: ocean_internalstate + type(ocean_grid_type), pointer :: ocean_grid => NULL() + type(directories) :: dirs + type(time_type) :: Run_len !< length of experiment + type(time_type) :: time0 !< Start time of coupled model's calendar. + type(time_type) :: time_start !< The time at which to initialize the ocean model + type(time_type) :: Time_restart + type(time_type) :: DT + integer :: DT_OCEAN + integer :: isc,iec,jsc,jec + integer :: year=0, month=0, day=0, hour=0, minute=0, second=0 + integer :: mpi_comm_mom + integer :: i,n + character(len=256) :: stdname, shortname + character(len=32) :: starttype ! model start type + character(len=512) :: diro + character(len=512) :: logfile + character(ESMF_MAXSTR) :: cvalue + character(len=64) :: logmsg + logical :: isPresent, isPresentDiro, isPresentLogfile, isSet + logical :: existflag + logical :: use_waves ! If true, the wave modules are active. + character(len=40) :: wave_method ! Wave coupling method. + integer :: userRc + integer :: localPet + integer :: localPeCount + integer :: iostat + integer :: readunit + character(len=512) :: restartfile ! Path/Name of restart file + character(len=2048) :: restartfiles ! Path/Name of restart files + ! (same as restartfile if single restart file) + character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' + character(len=32) :: calendar + character(len=:), allocatable :: rpointer_filename + integer :: inst_index + real(8) :: MPI_Wtime, timeiads +!-------------------------------- + + rc = ESMF_SUCCESS + if(write_runtimelog) timeiads = MPI_Wtime() + + call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) + + allocate(Ice_ocean_boundary) + !allocate(ocean_state) ! ocean_model_init allocate this pointer + allocate(ocean_public) + allocate(ocean_internalstate%ptr) + ocean_internalstate%ptr%ice_ocean_boundary_type_ptr => Ice_ocean_boundary + ocean_internalstate%ptr%ocean_public_type_ptr => ocean_public + ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + +#ifdef CESMCOUPLED + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ensemble_manager_init(inst_suffix) + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) +#endif + + ! reset shr logging to my log file + if (localPet==0) then + call NUOPC_CompAttributeGet(gcomp, name="diro", & + isPresent=isPresentDiro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", & + isPresent=isPresentLogfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresentDiro .and. isPresentLogfile) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (cesm_coupled) then + ! Multiinstance logfile name needs a correction + if(len_trim(inst_suffix) > 0) then + n = index(logfile, '.') + logfile = logfile(1:n-1)//trim(inst_suffix)//logfile(n:) + endif + endif + + open(newunit=stdout,file=trim(diro)//"/"//trim(logfile)) + else + stdout = output_unit + endif + else + stdout = output_unit + endif + call shr_log_setLogUnit(stdout) + call NUOPC_CompAttributeAdd(gcomp, (/"logunit"/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, "logunit", stdout, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call MOM_infra_init(mpi_comm_mom) + + ! determine the calendar + if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) calendar + select case (trim(calendar)) + case ("NO_LEAP") + call set_calendar_type (NOLEAP) + case ("GREGORIAN") + call set_calendar_type (GREGORIAN) + case default + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": Calendar not supported in MOM6: "//trim(calendar), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + end select + else + call set_calendar_type (NOLEAP) + endif + + else + call set_calendar_type (JULIAN) + endif + + ! this ocean connector will be driven at set interval + DT = set_time (DT_OCEAN, 0) + ! get current time + time_start = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) + + if (is_root_pe()) then + write(stdout,*) subname//'current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second + endif + + ! get start/reference time + call ESMF_ClockGet(CLOCK, refTime=MyTime, RC=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) + + if (is_root_pe()) then + write(stdout,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second + endif + + starttype = "" + call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) starttype + else + call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & + ESMF_LOGMSG_INFO) + endif + + runtype = "" + if (trim(starttype) == trim('startup')) then + runtype = "initial" + else if (trim(starttype) == trim('continue') ) then + runtype = "continue" + else if (trim(starttype) == trim('branch')) then + runtype = "continue" + else if (len_trim(starttype) > 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": unknown starttype - "//trim(starttype), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + if (len_trim(runtype) > 0) then + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) + endif + + restartfile = ""; restartfiles = "" + if (runtype == "initial") then + if (cesm_coupled) then + restartfiles = "n" + else + call get_MOM_input(dirs=dirs) + restartfiles = dirs%input_filename(1:1) + endif + call ESMF_LogWrite('MOM_cap:restartfile = '//trim(restartfiles), ESMF_LOGMSG_INFO) + + else if (runtype == "continue") then ! hybrid or branch or continuos runs + + if (cesm_coupled) then + call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (localPet == 0) then + ! this hard coded for rpointer.ocn right now + open(newunit=readunit, file=rpointer_filename, form='formatted', status='old', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening '//rpointer_filename, & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + do + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading '//rpointer_filename, & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) + endif + + endif + + ocean_public%is_ocean_pe = .true. + if (cesm_coupled .and. len_trim(inst_suffix)>0) then + call ocean_model_init(ocean_public, ocean_state, time0, time_start, & + input_restart_file=trim(adjustl(restartfiles)), inst_index=inst_index) + else + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(adjustl(restartfiles))) + endif + + ! GMM, this call is not needed in CESM. Check with EMC if it can be deleted. + call ocean_model_flux_init(ocean_state) + + call ocean_model_init_sfc(ocean_state, ocean_public) + + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) + + allocate ( Ice_ocean_boundary% u_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% v_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% t_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% q_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% salt_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% lw_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_vis_dir (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_vis_dif (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_nir_dir (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_nir_dif (isc:iec,jsc:jec), & + Ice_ocean_boundary% lprec (isc:iec,jsc:jec), & + Ice_ocean_boundary% fprec (isc:iec,jsc:jec), & + Ice_ocean_boundary% seaice_melt_heat (isc:iec,jsc:jec),& + Ice_ocean_boundary% seaice_melt (isc:iec,jsc:jec), & + Ice_ocean_boundary% mi (isc:iec,jsc:jec), & + Ice_ocean_boundary% ice_fraction (isc:iec,jsc:jec), & + Ice_ocean_boundary% u10_sqr (isc:iec,jsc:jec), & + Ice_ocean_boundary% p (isc:iec,jsc:jec), & + Ice_ocean_boundary% lrunoff (isc:iec,jsc:jec), & + Ice_ocean_boundary% frunoff (isc:iec,jsc:jec)) + + Ice_ocean_boundary%u_flux = 0.0 + Ice_ocean_boundary%v_flux = 0.0 + Ice_ocean_boundary%t_flux = 0.0 + Ice_ocean_boundary%q_flux = 0.0 + Ice_ocean_boundary%salt_flux = 0.0 + Ice_ocean_boundary%lw_flux = 0.0 + Ice_ocean_boundary%sw_flux_vis_dir = 0.0 + Ice_ocean_boundary%sw_flux_vis_dif = 0.0 + Ice_ocean_boundary%sw_flux_nir_dir = 0.0 + Ice_ocean_boundary%sw_flux_nir_dif = 0.0 + Ice_ocean_boundary%lprec = 0.0 + Ice_ocean_boundary%fprec = 0.0 + Ice_ocean_boundary%seaice_melt = 0.0 + Ice_ocean_boundary%seaice_melt_heat= 0.0 + Ice_ocean_boundary%mi = 0.0 + Ice_ocean_boundary%ice_fraction = 0.0 + Ice_ocean_boundary%u10_sqr = 0.0 + Ice_ocean_boundary%p = 0.0 + Ice_ocean_boundary%lrunoff = 0.0 + Ice_ocean_boundary%frunoff = 0.0 + + if (cesm_coupled) then + allocate (Ice_ocean_boundary% hrain (isc:iec,jsc:jec), & + Ice_ocean_boundary% hsnow (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofl (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofi (isc:iec,jsc:jec), & + Ice_ocean_boundary% hevap (isc:iec,jsc:jec), & + Ice_ocean_boundary% hcond (isc:iec,jsc:jec)) + + Ice_ocean_boundary%hrain = 0.0 + Ice_ocean_boundary%hsnow = 0.0 + Ice_ocean_boundary%hrofl = 0.0 + Ice_ocean_boundary%hrofi = 0.0 + Ice_ocean_boundary%hevap = 0.0 + Ice_ocean_boundary%hcond = 0.0 + endif + + call query_ocean_state(ocean_state, use_waves=use_waves, wave_method=wave_method) + if (use_waves) then + if (wave_method == "EFACTOR") then + allocate( Ice_ocean_boundary%lamult(isc:iec,jsc:jec) ) + Ice_ocean_boundary%lamult = 0.0 + else if (wave_method == "SURFACE_BANDS") then + call query_ocean_state(ocean_state, NumWaveBands=Ice_ocean_boundary%num_stk_bands) + allocate(Ice_ocean_boundary%ustkb(isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), source=0.0) + allocate(Ice_ocean_boundary%vstkb(isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), source=0.0) + allocate(Ice_ocean_boundary%stk_wavenumbers(Ice_ocean_boundary%num_stk_bands), source=0.0) + call query_ocean_state(ocean_state, WaveNumbers=Ice_ocean_boundary%stk_wavenumbers, unscale=.true.) + else + call MOM_error(FATAL, "Unsupported WAVE_METHOD encountered in NUOPC cap.") + endif + endif + ! Consider adding this: + ! if (.not.use_waves) Ice_ocean_boundary%num_stk_bands = 0 + + ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state + call ESMF_GridCompSetInternalState(gcomp, ocean_internalstate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (len_trim(scalar_field_name) > 0) then + call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") + endif + + !--------- import fields ------------- + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_salt" , "will provide") ! from ice + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_taux" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_tauy" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_sen" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_evap" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_lwnet" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_vdr" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_vdf" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_idr" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_idf" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_rain" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_snow" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_pslv" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofl" , "will provide") !-> liquid runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Si_ifrac" , "will provide") !-> ice fraction + call fld_list_add(fldsToOcn_num, fldsToOcn, "So_duu10n" , "will provide") !-> wind^2 at 10m + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_meltw" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_melth" , "will provide") + + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrain" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hsnow" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hevap" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hcond" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofl" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofi" , "will provide") + + if (use_waves) then + if (wave_method == "EFACTOR") then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_lamult" , "will provide") + else if (wave_method == "SURFACE_BANDS") then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_pstokes_x", "will provide", & + ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%num_stk_bands) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_pstokes_y", "will provide", & + ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%num_stk_bands) + else + call MOM_error(FATAL, "Unsupported WAVE_METHOD encountered in NUOPC cap.") + endif + endif + + !--------- export fields ------------- + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_omask" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_t" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_s" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_u" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_v" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdx" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdy" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "Fioo_q" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_bldepth" , "will provide") + + do n = 1,fldsToOcn_num + call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, name=fldsToOcn(n)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + + do n = 1,fldsFrOcn_num + 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 + +end subroutine InitializeAdvertise + +!> Called by NUOPC to realize import and export fields. "Realizing" a field +!! means that its grid has been defined and an ESMF_Field object has been +!! created and put into the import or export State. +!! +!! @param gcomp an ESMF_GridComp object +!! @param importState an ESMF_State object for import fields +!! @param exportState an ESMF_State object for export fields +!! @param clock an ESMF_Clock object +!! @param rc return code +subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object + type(ESMF_State) :: importState, exportState !< ESMF_State object for + !! import/export fields + type(ESMF_Clock) :: clock !< ESMF_Clock object + integer, intent(out) :: rc !< return code + + ! Local Variables + type(ESMF_VM) :: vm + type(ESMF_Grid) :: gridIn, gridOut + type(ESMF_Mesh) :: Emesh, EmeshTemp + type(ESMF_DeLayout) :: delayout + type(ESMF_Distgrid) :: Distgrid + type(ESMF_DistGridConnection), allocatable :: connectionList(:) + type(ESMF_StateItem_Flag) :: itemFlag + type (ocean_public_type), pointer :: ocean_public => NULL() + type (ocean_state_type), pointer :: ocean_state => NULL() + type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() + type(ocean_grid_type) , pointer :: ocean_grid + type(ocean_internalstate_wrapper) :: ocean_internalstate + integer :: npet, ntiles + integer :: npes ! number of PEs (from FMS). + integer :: nxg, nyg, cnt + integer :: isc,iec,jsc,jec + integer, allocatable :: xb(:),xe(:),yb(:),ye(:),pe(:) + integer, allocatable :: deBlockList(:,:,:) + integer, allocatable :: petMap(:) + integer, allocatable :: deLabelList(:) + integer, allocatable :: indexList(:) + integer :: ioff, joff + integer :: i, j, n, i1, j1, n1, jlast + integer :: lbnd1,ubnd1,lbnd2,ubnd2 + integer :: lbnd3,ubnd3,lbnd4,ubnd4 + integer :: nblocks_tot + logical :: found + logical :: isPresent, isSet + integer(ESMF_KIND_I4), pointer :: dataPtr_mask(:,:) + real(ESMF_KIND_R8), pointer :: dataPtr_area(:,:) + real(ESMF_KIND_R8), pointer :: dataPtr_xcen(:,:) + real(ESMF_KIND_R8), pointer :: dataPtr_ycen(:,:) + real(ESMF_KIND_R8), pointer :: dataPtr_xcor(:,:) + real(ESMF_KIND_R8), pointer :: dataPtr_ycor(:,:) + integer :: mpicom + integer :: localPet + integer :: localPeCount + integer :: lsize + integer :: ig,jg, ni,nj,k + integer, allocatable :: gindex(:) ! global index space + integer, allocatable :: gindex_ocn(:) ! global index space for ocean cells (excl. masked cells) + integer, allocatable :: gindex_elim(:) ! global index space for eliminated cells + character(len=128) :: fldname + character(len=256) :: cvalue + character(len=256) :: frmt ! format specifier for several error msgs + character(len=512) :: err_msg ! error messages + integer :: spatialDim + integer :: numOwnedElements + type(ESMF_Array) :: elemMaskArray + real(ESMF_KIND_R8) , pointer :: ownedElemCoords(:) + real(ESMF_KIND_R8) , pointer :: lat(:), latMesh(:) + real(ESMF_KIND_R8) , pointer :: lon(:), lonMesh(:) + integer(ESMF_KIND_I4) , pointer :: mask(:), maskMesh(:) + real(ESMF_KIND_R8) :: diff_lon, diff_lat + real :: eps_omesh + real(ESMF_KIND_R8) :: L2_to_rad2 + type(ESMF_Field) :: lfield + real(ESMF_KIND_R8), allocatable :: mesh_areas(:) + real(ESMF_KIND_R8), allocatable :: model_areas(:) + real(ESMF_KIND_R8), pointer :: dataPtr_mesh_areas(:) + real(ESMF_KIND_R8) :: min_areacor(2) + real(ESMF_KIND_R8) :: max_areacor(2) + real(ESMF_KIND_R8) :: min_areacor_glob(2) + real(ESMF_KIND_R8) :: max_areacor_glob(2) + character(len=*), parameter :: subname='(MOM_cap:InitializeRealize)' + integer :: niproc, njproc + integer :: ip, jp, pe_ix + integer :: num_elim_blocks ! number of blocks to be eliminated + integer :: num_elim_cells_global, num_elim_cells_local, num_elim_cells_remaining + integer, allocatable :: cell_mask(:,:) + real(8) :: MPI_Wtime, timeirls + !-------------------------------- + + rc = ESMF_SUCCESS + if(write_runtimelog) timeirls = MPI_Wtime() + + call shr_log_setLogUnit (stdout) + + !---------------------------------------------------------------------------- + ! Get pointers to ocean internal state + !---------------------------------------------------------------------------- + + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr + ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr + ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr + + !---------------------------------------------------------------------------- + ! Get mpi information + !---------------------------------------------------------------------------- + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !--------------------------------- + ! global mom grid size + !--------------------------------- + + call mpp_get_global_domain(ocean_public%domain, xsize=nxg, ysize=nyg) + write(tmpstr,'(a,2i6)') subname//' nxg,nyg = ',nxg,nyg + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + !--------------------------------- + ! number of tiles per PET, assumed to be 1, and number of pes (tiles) total + !--------------------------------- + + ntiles=mpp_get_ntile_count(ocean_public%domain) ! this is tiles on this pe + if (ntiles /= 1) then + rc = ESMF_FAILURE + call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) + endif + npes = mpp_get_domain_npes(ocean_public%domain) + write(tmpstr,'(a,1i6)') subname//' npes = ',npes + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + !--------------------------------- + ! get start and end indices of each tile and their PET + !--------------------------------- + + allocate(xb(npes),xe(npes),yb(npes),ye(npes),pe(npes)) + call mpp_get_compute_domains(ocean_public%domain, xbegin=xb, xend=xe, ybegin=yb, yend=ye) + call mpp_get_pelist(ocean_public%domain, pe) + if (dbug > 1) then + do n = 1,npes + write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + enddo + endif + + !--------------------------------- + ! Create either a grid or a mesh + !--------------------------------- + + !Get the ocean grid and sizes of global and computational domains + call get_ocean_grid(ocean_state, ocean_grid) + + if (geomtype == ESMF_GEOMTYPE_MESH) then + + !--------------------------------- + ! Create a MOM6 mesh + !--------------------------------- + + call get_global_grid_size(ocean_grid, ni, nj) + lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) + + num_elim_blocks = 0 + num_elim_cells_global = 0 + num_elim_cells_local = 0 + num_elim_cells_remaining = 0 + + ! Compute the number of eliminated blocks (specified in MOM_mask_table) + if (associated(ocean_grid%Domain%maskmap)) then + njproc = size(ocean_grid%Domain%maskmap, 1) + niproc = size(ocean_grid%Domain%maskmap, 2) + + do ip = 1, niproc + do jp = 1, njproc + if (.not. ocean_grid%Domain%maskmap(jp,ip)) then + num_elim_blocks = num_elim_blocks+1 + endif + enddo + enddo + endif + + ! Apply land block elimination to ESMF gindex + ! (Here we assume that each processor gets assigned a single tile. If multi-tile implementation is to be added + ! in MOM6 NUOPC cap in the future, below code must be updated accordingly.) + if (num_elim_blocks>0) then + + allocate(cell_mask(ni, nj), source=0) + allocate(gindex_ocn(lsize)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + jg = j + ocean_grid%jdg_offset + do i = ocean_grid%isc, ocean_grid%iec + ig = i + ocean_grid%idg_offset + k = k + 1 ! Increment position within gindex + gindex_ocn(k) = ni * (jg - 1) + ig + cell_mask(ig, jg) = 1 + enddo + enddo + call sum_across_PEs(cell_mask, ni*nj) + + if (maxval(cell_mask) /= 1 ) then + call MOM_error(FATAL, "Encountered cells shared by multiple PEs while attempting to determine masked cells.") + endif + + num_elim_cells_global = ni * nj - sum(cell_mask) + num_elim_cells_local = num_elim_cells_global / npes + + if (pe_here() == pe(npes)) then + ! assign all remaining cells to the last PE. + num_elim_cells_remaining = num_elim_cells_global - num_elim_cells_local * npes + allocate(gindex_elim(num_elim_cells_local+num_elim_cells_remaining)) + else + allocate(gindex_elim(num_elim_cells_local)) + endif + + ! Zero-based PE index. + pe_ix = pe_here() - pe(1) + + k = 0 + do jg = 1, nj + do ig = 1, ni + if (cell_mask(ig, jg) == 0) then + k = k + 1 + if (k > pe_ix * num_elim_cells_local .and. & + k <= ((pe_ix+1) * num_elim_cells_local + num_elim_cells_remaining)) then + gindex_elim(k - pe_ix * num_elim_cells_local) = ni * (jg -1) + ig + endif + endif + enddo + enddo + + allocate(gindex(lsize + num_elim_cells_local + num_elim_cells_remaining)) + do k = 1, lsize + gindex(k) = gindex_ocn(k) + enddo + do k = 1, num_elim_cells_local + num_elim_cells_remaining + gindex(k+lsize) = gindex_elim(k) + enddo + + deallocate(cell_mask) + deallocate(gindex_ocn) + deallocate(gindex_elim) + + else ! no eliminated land blocks + + ! Create the global index space for the computational domain + allocate(gindex(lsize)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + jg = j + ocean_grid%jdg_offset + do i = ocean_grid%isc, ocean_grid%iec + ig = i + ocean_grid%idg_offset + k = k + 1 ! Increment position within gindex + gindex(k) = ni * (jg - 1) + ig + enddo + enddo + + endif + + DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! read in the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (localPet == 0) then + write(stdout,*)'mesh file for mom6 domain is ',trim(cvalue) + endif + + ! recreate the mesh using the above distGrid + EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Check for consistency of lat, lon and mask between mesh and mom6 grid + call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (lsize /= numOwnedElements - num_elim_cells_local - num_elim_cells_remaining) then + call MOM_error(FATAL, "Discrepancy detected between ESMF mesh and internal MOM6 domain sizes. Check mask table.") + endif + + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) + allocate(latMesh(numOwnedElements), lat(numOwnedElements)) + allocate(maskMesh(numOwnedElements), mask(numOwnedElements)) + + call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 1,numOwnedElements + lonMesh(n) = ownedElemCoords(2*n-1) + latMesh(n) = ownedElemCoords(2*n) + end do + + elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) + n = 0 + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + n = n+1 + mask(n) = ocean_grid%mask2dT(ig,jg) + lon(n) = ocean_grid%geolonT(ig,jg) + lat(n) = ocean_grid%geolatT(ig,jg) + end do + end do + + eps_omesh = get_eps_omesh(ocean_state) + do n = 1,lsize + diff_lon = abs(mod(lonMesh(n) - lon(n),360.0)) + if (diff_lon > eps_omesh) then + frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is "//& + "greater than parameter EPS_OMESH. n, lonMesh(n), lon(n), diff_lon, "//& + "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" + write(err_msg, frmt)n,lonMesh(n),lon(n), diff_lon, eps_omesh + call MOM_error(FATAL, err_msg) + end if + diff_lat = abs(latMesh(n) - lat(n)) + if (diff_lat > eps_omesh) then + frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is"//& + "greater than parameter EPS_OMESH. n, latMesh(n), lat(n), diff_lat, "//& + "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" + write(err_msg, frmt)n,latMesh(n),lat(n), diff_lat, eps_omesh + call MOM_error(FATAL, err_msg) + end if + if (abs(maskMesh(n) - mask(n)) > 0) then + frmt = "('ERROR: ESMF mesh and MOM6 domain masks are inconsistent! - "//& + "MOM n, maskMesh(n), mask(n) = ',3(i8,2x))" + write(err_msg, frmt)n,maskMesh(n),mask(n) + call MOM_error(FATAL, err_msg) + end if + end do + + ! realize the import and export fields using the mesh + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !--------------------------------- + ! determine flux area correction factors - module variables in mom_cap_methods + !--------------------------------- + ! Area correction factors are ONLY valid for meshes that are read in - so do not need them for + ! grids that are calculated internally + + ! Determine mesh areas for regridding + call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, spatialDim=spatialDim, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate (mod2med_areacor(numOwnedElements)) + allocate (med2mod_areacor(numOwnedElements)) + mod2med_areacor(:) = 1._ESMF_KIND_R8 + med2mod_areacor(:) = 1._ESMF_KIND_R8 + +#ifdef CESMCOUPLED + ! Determine model areas and flux correction factors (module variables in mom_) + call ESMF_StateGet(exportState, itemName=trim(fldsFrOcn(2)%stdname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridGetArea(lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataPtr_mesh_areas, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(mesh_areas(numOwnedElements)) + allocate(model_areas(numOwnedElements)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + do i = ocean_grid%isc, ocean_grid%iec + k = k + 1 ! Increment position within gindex + if (mask(k) /= 0) then + mesh_areas(k) = dataPtr_mesh_areas(k) + model_areas(k) = ocean_grid%AreaT(i,j) / ocean_grid%Rad_Earth_L**2 + mod2med_areacor(k) = model_areas(k) / mesh_areas(k) + med2mod_areacor(k) = mesh_areas(k) / model_areas(k) + end if + end do + end do + deallocate(mesh_areas) + deallocate(model_areas) + + ! Write diagnostic output for correction factors + min_areacor(1) = minval(mod2med_areacor) + max_areacor(1) = maxval(mod2med_areacor) + min_areacor(2) = minval(med2mod_areacor) + max_areacor(2) = maxval(med2mod_areacor) + call ESMF_VMAllReduce(vm, min_areacor, min_areacor_glob, 2, ESMF_REDUCE_MIN, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllReduce(vm, max_areacor, max_areacor_glob, 2, ESMF_REDUCE_MAX, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (localPet == 0) then + write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& + min_areacor_glob(1), max_areacor_glob(1), 'MOM6' + write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& + min_areacor_glob(2), max_areacor_glob(2), 'MOM6' + end if +#endif + + deallocate(ownedElemCoords) + deallocate(lonMesh , lon ) + deallocate(latMesh , lat ) + deallocate(maskMesh, mask) + + else if (geomtype == ESMF_GEOMTYPE_GRID) then + + !--------------------------------- + ! create a MOM6 grid + !--------------------------------- + + ! generate delayout and dist_grid + + allocate(deBlockList(2,2,npes)) + allocate(petMap(npes)) + allocate(deLabelList(npes)) + + do n = 1, npes + deLabelList(n) = n + deBlockList(1,1,n) = xb(n) + deBlockList(1,2,n) = xe(n) + deBlockList(2,1,n) = yb(n) + deBlockList(2,2,n) = ye(n) + petMap(n) = pe(n) + ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side + enddo + + delayout = ESMF_DELayoutCreate(petMap, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! rsd this assumes tripole grid, but sometimes in CESM a bipole + ! grid is used -- need to introduce conditional logic here + + allocate(connectionList(2)) + + ! bipolar boundary condition at top row: nyg + call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & + tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & + orientationVector=(/-1, -2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! periodic boundary condition along first dimension + call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & + tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & + ! indexflag = ESMF_INDEX_DELOCAL, & + deBlockList=deBlockList, & + ! deLabelList=deLabelList, & + delayout=delayout, & + connectionList=connectionList, & + rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(xb,xe,yb,ye,pe) + deallocate(connectionList) + deallocate(deLabelList) + deallocate(deBlockList) + deallocate(petMap) + + call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(indexList(cnt)) + write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& + indexList(1),indexList(cnt),minval(indexList), maxval(indexList) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + deallocate(IndexList) + + ! create grid + + gridIn = ESMF_GridCreate(distgrid=distgrid, & + gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & + coordSys = ESMF_COORDSYS_SPH_DEG, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & + staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Attach area to the Grid optionally. By default the cell areas are computed. + if (grid_attach_area) then + call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & + staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + call ESMF_GridGetCoord(gridIn, coordDim=1, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_xcen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=2, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_ycen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=1, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=dataPtr_xcor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=2, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=dataPtr_ycor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_mask, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (grid_attach_area) then + call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_area, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + ! load up area, mask, center and corner values + ! area, mask, and centers should be same size in mom and esmf grid + ! corner points may not be, need to offset corner points by 1 in i and j + ! retrieve these values directly from ocean_grid, which contains halo + ! values for j=0 and wrap-around in i. on tripole seam, decomposition + ! domains are 1 larger in j; to load corner values need to loop one extra row + + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) + + lbnd1 = lbound(dataPtr_mask,1) + ubnd1 = ubound(dataPtr_mask,1) + lbnd2 = lbound(dataPtr_mask,2) + ubnd2 = ubound(dataPtr_mask,2) + + lbnd3 = lbound(dataPtr_xcor,1) + ubnd3 = ubound(dataPtr_xcor,1) + lbnd4 = lbound(dataPtr_xcor,2) + ubnd4 = ubound(dataPtr_xcor,2) + + write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=SUBNAME//": fld and grid do not have the same size.", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + do j = jsc, jec + j1 = j + lbnd2 - jsc + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + ig = i + ocean_grid%isc - isc + dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) + dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) + dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) + if(grid_attach_area) then + dataPtr_area(i1,j1) = ocean_grid%US%L_to_m**2 * ocean_grid%areaT(ig,jg) + endif + enddo + enddo + + jlast = jec + if (jec == nyg)jlast = jec+1 + + do j = jsc, jlast + j1 = j + lbnd4 - jsc + jg = j + ocean_grid%jsc - jsc - 1 + do i = isc, iec + i1 = i + lbnd3 - isc + ig = i + ocean_grid%isc - isc - 1 + dataPtr_xcor(i1,j1) = ocean_grid%geolonBu(ig,jg) + dataPtr_ycor(i1,j1) = ocean_grid%geolatBu(ig,jg) + enddo + enddo + + write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + if (grid_attach_area) then + write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + endif + + write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + gridOut = gridIn ! for now out same as in + + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !--------------------------------- + ! set scalar data in export state + !--------------------------------- + + if (len_trim(scalar_field_name) > 0) then + call State_SetScalar(real(nxg,ESMF_KIND_R8),scalar_field_idx_grid_nx, exportState, localPet, & + scalar_field_name, scalar_field_count, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call State_SetScalar(real(nyg,ESMF_KIND_R8),scalar_field_idx_grid_ny, exportState, localPet, & + scalar_field_name, scalar_field_count, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !--------------------------------- + ! Set module variable geomtype in MOM_cap_methods + !--------------------------------- + call mom_set_geomtype(geomtype) + + !--------------------------------- + ! write out diagnostics + !--------------------------------- + + !call NUOPC_Write(exportState, fileNamePrefix='post_realize_field_ocn_export_', & + ! timeslice=1, relaxedFlag=.true., rc=rc) + !if (ChkErr(rc,__LINE__,u_FILE_u)) return + + timere = 0. + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeirls + +end subroutine InitializeRealize + +!> TODO +!! +!! @param gcomp an ESMF_GridComp object +!! @param rc return code +subroutine DataInitialize(gcomp, rc) + type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object + integer, intent(out) :: rc !< return code + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_State) :: importState, exportState + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep + type(ESMF_StateItem_Flag) :: itemType + type (ocean_public_type), pointer :: ocean_public => NULL() + type (ocean_state_type), pointer :: ocean_state => NULL() + type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() + type(ocean_internalstate_wrapper) :: ocean_internalstate + type(ocean_grid_type), pointer :: ocean_grid + character(240) :: msgString + character(240) :: fldname + character(240) :: timestr + integer :: fieldCount, n + type(ESMF_Field) :: field + character(len=64),allocatable :: fieldNameList(:) + character(len=*),parameter :: subname='(MOM_cap:DataInitialize)' + real(8) :: MPI_Wtime, timedis + !-------------------------------- + + if(write_runtimelog) timedis = MPI_Wtime() + + ! query the Component for its clock, importState and exportState + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(clock, currTime=currTime, timeStep=timeStep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(currTime, timestring=timestr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr + ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr + ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr + call get_ocean_grid(ocean_state, ocean_grid) + + call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(fieldNameList(fieldCount)) + call ESMF_StateGet(exportState, itemNameList=fieldNameList, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + do n=1, fieldCount + call ESMF_StateGet(exportState, itemName=fieldNameList(n), field=field, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + deallocate(fieldNameList) + + ! check whether all Fields in the exportState are "Updated" + if (NUOPC_IsUpdated(exportState)) then + call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) + call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + if (write_diagnostics) then + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=field, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldWrite(field, fileName='field_init_ocn_export_'//trim(timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + enddo + endif + + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timedis + +end subroutine DataInitialize + +!> Called by NUOPC to advance the model a single timestep. +!! +!! @param gcomp an ESMF_GridComp object +!! @param rc return code +subroutine ModelAdvance(gcomp, rc) + type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object + integer, intent(out) :: rc !< return code + + ! local variables + integer :: userRc + logical :: existflag, isPresent, isSet + logical :: do_advance = .true. + type(ESMF_Clock) :: clock!< ESMF Clock class definition + type(ESMF_Alarm) :: restart_alarm, stop_alarm + type(ESMF_State) :: importState, exportState + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep + type(ESMF_Time) :: startTime + type(ESMF_TimeInterval) :: time_elapsed + integer(ESMF_KIND_I8) :: n_interval, time_elapsed_sec + type(ESMF_Field) :: lfield + type(ESMF_StateItem_Flag) :: itemType + character(len=64) :: timestamp + type (ocean_public_type), pointer :: ocean_public => NULL() + type (ocean_state_type), pointer :: ocean_state => NULL() + type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() + type(ocean_internalstate_wrapper) :: ocean_internalstate + type(ocean_grid_type) , pointer :: ocean_grid + type(time_type) :: Time + type(time_type) :: Time_step_coupled + type(time_type) :: Time_restart_current + integer :: dth, dtm, dts + integer :: nc + type(ESMF_Time) :: MyTime + integer :: seconds, day, year, month, hour, minute + character(ESMF_MAXSTR) :: restartname, cvalue, stoch_restartname + character(240) :: msgString + character(ESMF_MAXSTR) :: casename + integer :: iostat + integer :: writeunit + integer :: localPet + type(ESMF_VM) :: vm + integer :: n, i + character(240) :: import_timestr, export_timestr + character(len=128) :: fldname + character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' + character(len=8) :: suffix + character(len=:), allocatable :: rpointer_filename + integer :: num_rest_files + real(8) :: MPI_Wtime, timers + logical :: write_restart + logical :: write_restartfh + logical :: write_restart_eor + + + rc = ESMF_SUCCESS + if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") + if(write_runtimelog) then + timers = MPI_Wtime() + if(timere>0. .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time since last time step ',timers-timere + endif + + call shr_log_setLogUnit (stdout) + + ! query the Component for its clock, importState and exportState + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, & + exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! HERE THE MODEL ADVANCES: currTime -> currTime + timeStep + + call ESMF_ClockPrint(clock, options="currTime", & + preString="------>Advancing OCN from: ", unit=msgString, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO) + + call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, & + timeStep=timeStep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimePrint(currTime + timeStep, & + preString="--------------------------------> to: ", unit=msgString, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + + call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc) + call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc) + + Time_step_coupled = esmf2fms_time(timeStep) + Time = esmf2fms_time(currTime) + + !--------------- + ! Apply ocean lag for startup runs: + !--------------- + + if (cesm_coupled .or. (.not.use_coldstart)) then + if (trim(runtype) == "initial") then + + ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run + if (currTime == startTime) then + call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO) + do_advance = .false. + else + do_advance = .true. + endif + + if (do_advance) then + ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps + if (currTime == startTime + timeStep) then + call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) + Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime + + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) + Time_step_coupled = 2 * esmf2fms_time(timeStep) + endif + endif + + endif + endif + + if (do_advance) then + + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr + ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr + ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr + + !--------------- + ! Write diagnostics for import + !--------------- + + if (write_diagnostics) then + do n = 1,fldsToOcn_num + fldname = fldsToOcn(n)%shortname + call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + enddo + endif + + if (dbug > 0) then + call state_diagnose(importState,subname//':IS ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !--------------- + ! Get ocean grid + !--------------- + + call get_ocean_grid(ocean_state, ocean_grid) + + !--------------- + ! Import data + !--------------- + + call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !--------------- + ! Update MOM6 + !--------------- + + if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") + call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled, & + cesm_coupled) + if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") + + !--------------- + ! Export Data + !--------------- + + call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (dbug > 0) then + call state_diagnose(exportState,subname//':ES ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + endif + + !--------------- + ! Get the stop alarm + !--------------- + call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !--------------- + ! If restart alarm exists and is ringing - write restart file + !--------------- + + if (restart_mode == 'alarms') then + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + write_restartfh = .false. + ! check if next time is == to any restartfhtime + if (allocated(RestartFhTimes)) then + do n = 1,size(RestartFhTimes) + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (MyTime == RestartFhTimes(n)) write_restartfh = .true. + end do + end if + + write_restart = .false. + if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_restart = .true. + ! turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + write_restart_eor = .false. + if (restart_eor) then + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_restart_eor = .true. + ! turn off the alarm + call ESMF_AlarmRingerOff(stop_alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + + if (write_restart .or. write_restartfh .or. write_restart_eor) then + ! determine restart filename + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) + + write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & + trim(casename), year, month, day, hour * 3600 + minute * 60 + seconds + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) + if (localPet == 0) then + ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean + open(newunit=writeunit, file=rpointer_filename, form='formatted', status='unknown', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & + msg=subname//' ERROR opening '//rpointer_filename, line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + if (len_trim(inst_suffix) == 0) then + write(writeunit,'(a)') trim(restartname)//'.nc' + else + write(writeunit,'(a)') trim(restartname)//'.'//trim(inst_suffix)//'.nc' + endif + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(writeunit) + endif + else ! not cesm_coupled + write(restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & + ".MOM.res" + write(stoch_restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & + ".ocn_stoch.res.nc" + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) + + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname, & + stoch_restartname=stoch_restartname) + + endif + + if (is_root_pe()) then + write(stdout,*) subname//' writing restart file ',trim(restartname) + endif + endif + endif ! restart_mode + + !--------------- + ! Write diagnostics + !--------------- + + if (write_diagnostics) then + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_export_'//trim(export_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + enddo + endif + + if(write_runtimelog) then + timere = MPI_Wtime() + if(is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', timere-timers + endif + + if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") + +end subroutine ModelAdvance + + +subroutine ModelSetRunClock(gcomp, rc) + + use ESMF, only : ESMF_TimeIntervalSet + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + type(ESMF_Clock) :: mclock, dclock + type(ESMF_Time) :: mcurrtime, dcurrtime + type(ESMF_Time) :: mstoptime, dstoptime + type(ESMF_TimeInterval) :: mtimestep, dtimestep + type(ESMF_TimeInterval) :: fhInterval + character(len=128) :: mtimestring, dtimestring + character(len=256) :: timestr + character(len=256) :: cvalue + character(len=256) :: restart_option ! Restart option units + integer :: restart_n ! Number until restart interval + integer :: restart_ymd ! Restart date (YYYYMMDD) + integer :: dt_cpl ! coupling timestep + type(ESMF_Alarm) :: restart_alarm + type(ESMF_Alarm) :: stop_alarm + logical :: isPresent, isSet + logical :: first_time = .true. + integer :: localPet + integer :: n, nfh + integer, allocatable :: restart_fh(:) + character(len=*),parameter :: subname='(MOM_cap:ModelSetRunClock) ' + !-------------------------------- + + rc = ESMF_SUCCESS + + ! query the Component for its clock, importState and exportState + call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=dstoptime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! check that the current time in the model and driver are the same + !-------------------------------- + + if (mcurrtime /= dcurrtime) then + call ESMF_TimeGet(dcurrtime, timeString=dtimestring, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(mcurrtime, timeString=mtimestring, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR in time consistency: "//trim(dtimestring)//" != "//trim(mtimestring), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + !-------------------------------- + ! force model clock currtime and timestep to match driver and set stoptime + !-------------------------------- + + mstoptime = mcurrtime + dtimestep + + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (first_time) then + !-------------------------------- + ! set restart alarm + !-------------------------------- + + ! defaults + restart_n = 0 + restart_ymd = 0 + + if (cesm_coupled) then + + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! If restart_option is set then must also have set either restart_n or restart_ymd + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_n + endif + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + endif + if (restart_n == 0 .and. restart_ymd == 0) then + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + + else + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! If restart_n is set and non-zero, then restart_option must be available from config + if (isPresent .and. isSet) then + call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO) + read(cvalue,*) restart_n + if (restart_n /= 0)then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_option + call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & + ESMF_LOGMSG_INFO) + else + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_option must be set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + ! not used in ufs + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) + endif + else + ! restart_n is zero, restarts will be written at finalize only (no alarm control) + restart_mode = 'no_alarms' + call ESMF_LogWrite(subname//" Restarts will be written at finalize only", ESMF_LOGMSG_INFO) + endif + endif + endif + + if (restart_mode == 'alarms') then + call AlarmInit(mclock, & + alarm = restart_alarm, & + option = trim(restart_option), & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'restart_alarm', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) + end if + + ! create a 1-shot alarm at the driver stop time + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) + + ! set up Times to write non-interval restarts + call NUOPC_CompAttributeGet(gcomp, name='restart_fh', isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + + call ESMF_TimeIntervalGet(dtimestep, s=dt_cpl, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name='restart_fh', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! convert string to a list of integer restart_fh values + nfh = 1 + count(transfer(trim(cvalue), 'a', len(cvalue)) == ",") + allocate(restart_fh(1:nfh)) + allocate(restartFhTimes(1:nfh)) + read(cvalue,*)restart_fh(1:nfh) + + ! create a list of times at each restart_fh + do n = 1,nfh + call ESMF_TimeIntervalSet(fhInterval, h=restart_fh(n), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + restartFhTimes(n) = mcurrtime + fhInterval + call ESMF_TimePrint(restartFhTimes(n), options="string", preString="Restart_Fh at ", unit=timestr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (localPet == 0) then + if (mod(3600*restart_fh(n),dt_cpl) /= 0) then + write(stdout,'(A)')trim(subname)//trim(timestr)//' will not be written' + else + write(stdout,'(A)')trim(subname)//trim(timestr)//' will be written' + end if + end if + end do + deallocate(restart_fh) + end if + + first_time = .false. + endif + + !-------------------------------- + ! Advance model clock to trigger alarms then reset model clock back to currtime + !-------------------------------- + + call ESMF_ClockAdvance(mclock,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + +end subroutine ModelSetRunClock + +!=============================================================================== + +!> Called by NUOPC at the end of the run to clean up. +!! +!! @param gcomp an ESMF_GridComp object +!! @param rc return code +subroutine ocean_model_finalize(gcomp, rc) + + type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object + integer, intent(out) :: rc !< return code + + ! local variables + type (ocean_public_type), pointer :: ocean_public + type (ocean_state_type), pointer :: ocean_state + type(ocean_internalstate_wrapper) :: ocean_internalstate + type(TIME_TYPE) :: Time + type(ESMF_Clock) :: clock + type(ESMF_Time) :: currTime + type(ESMF_Alarm), allocatable :: alarmList(:) + integer :: alarmCount + character(len=64) :: timestamp + logical :: write_restart + character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' + real(8) :: MPI_Wtime, timefs + + if (is_root_pe()) then + write(stdout,*) 'MOM: --- finalize called ---' + endif + rc = ESMF_SUCCESS + if(write_runtimelog) timefs = MPI_Wtime() + + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr + ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr + + call NUOPC_ModelGet(gcomp, modelClock=clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(clock, currTime=currTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + Time = esmf2fms_time(currTime) + + ! Do not write a restart unless mode is no_alarms + if (restart_mode == 'no_alarms') then + write_restart = .true. + else + write_restart = .false. + end if + if (write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", & + ESMF_LOGMSG_INFO) + + call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) + + call io_infra_end() + call MOM_infra_end() + + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timefs + +end subroutine ocean_model_finalize + + +!> Set scalar data from state for a particula name +subroutine State_SetScalar(value, scalar_id, State, mytask, scalar_name, scalar_count, rc) + real(ESMF_KIND_R8),intent(in) :: value + integer, intent(in) :: scalar_id + type(ESMF_State), intent(inout) :: State + integer, intent(in) :: mytask + character(len=*), intent(in) :: scalar_name + integer, intent(in) :: scalar_count + integer, intent(inout) :: rc !< return code + + ! local variables + type(ESMF_Field) :: field + real(ESMF_KIND_R8), pointer :: farrayptr(:,:) + character(len=*), parameter :: subname='(MOM_cap:State_SetScalar)' + !-------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(State, itemName=trim(scalar_name), field=field, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (mytask == 0) then + call ESMF_FieldGet(field, farrayPtr=farrayptr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (scalar_id < 0 .or. scalar_id > scalar_count) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ERROR in scalar_id", line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + farrayptr(scalar_id,1) = value + endif + +end subroutine State_SetScalar + +!> Realize the import and export fields using either a grid or a mesh. +subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) + type(ESMF_State) , intent(inout) :: state !< ESMF_State object for + !! import/export fields. + integer , intent(in) :: nfields !< Number of fields. + type(fld_list_type) , intent(inout) :: field_defs(:) !< Structure with field's + !! information. + character(len=*) , intent(in) :: tag !< Import or export. + type(ESMF_Grid) , intent(in), optional :: grid!< ESMF grid. + type(ESMF_Mesh) , intent(in), optional :: mesh!< ESMF mesh. + integer , intent(inout) :: rc !< Return code. + + ! local variables + integer :: i + type(ESMF_Field) :: field + real(ESMF_KIND_R8), pointer :: fldptr1d(:) ! for mesh + real(ESMF_KIND_R8), pointer :: fldptr2d(:,:) ! for grid + character(len=*),parameter :: subname='(MOM_cap:MOM_RealizeFields)' + !-------------------------------------------------------- + + rc = ESMF_SUCCESS + + do i = 1, nfields + + if (NUOPC_IsConnected(state, fieldName=field_defs(i)%shortname)) then + + if (field_defs(i)%shortname == scalar_field_name) then + + call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & + ESMF_LOGMSG_INFO) + + call SetScalarField(field, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + else + + call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & + ESMF_LOGMSG_INFO) + + if (present(grid)) then + + if (field_defs(i)%ungridded_lbound > 0 .and. field_defs(i)%ungridded_ubound > 0) then + call ESMF_LogWrite(trim(subname)//": ERROR ungridded dimensions not supported in MOM6 nuopc cap when "//& + "ESMF_GEOMTYPE_GRID is used. Use ESMF_GEOMTYPE_MESH instead.", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + else + field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & + name=field_defs(i)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0.0 + endif + + else if (present(mesh)) then + + if (field_defs(i)%ungridded_lbound > 0 .and. field_defs(i)%ungridded_ubound > 0) then + field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + name=field_defs(i)%shortname, ungriddedLbound=(/field_defs(i)%ungridded_lbound/), & + ungriddedUbound=(/field_defs(i)%ungridded_ubound/), gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0.0 + else + field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + name=field_defs(i)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr1d(:) = 0.0 + endif + endif + endif + + ! Realize connected field + call NUOPC_Realize(state, field=field, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + else ! field is not connected + + call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & + ESMF_LOGMSG_INFO) + + ! remove a not connected Field from State + call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + endif + + enddo + +contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + subroutine SetScalarField(field, rc) + + ! create a field with scalar data on the root pe + type(ESMF_Field), intent(inout) :: field + integer, intent(inout) :: rc + + ! local variables + type(ESMF_Distgrid) :: distgrid + type(ESMF_Grid) :: grid + character(len=*), parameter :: subname='(MOM_cap:SetScalarField)' + + rc = ESMF_SUCCESS + + ! create a DistGrid with a single index space element, which gets mapped onto DE 0. + distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + grid = ESMF_GridCreate(distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! num of scalar values + field = ESMF_FieldCreate(name=trim(scalar_field_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), ungriddedUBound=(/scalar_field_count/), gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine SetScalarField + +end subroutine MOM_RealizeFields + +!=============================================================================== + +!> Set up list of field information +subroutine fld_list_add(num, fldlist, stdname, transferOffer, shortname, ungridded_lbound, ungridded_ubound) + integer, intent(inout) :: num + type(fld_list_type), intent(inout) :: fldlist(:) + character(len=*), intent(in) :: stdname + character(len=*), intent(in) :: transferOffer + character(len=*), optional, intent(in) :: shortname + integer, optional, intent(in) :: ungridded_lbound + integer, optional, intent(in) :: ungridded_ubound + + ! local variables + integer :: rc + character(len=*), parameter :: subname='(MOM_cap:fld_list_add)' + + ! fill in the new entry + num = num + 1 + if (num > fldsMax) then + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=trim(subname)//": ERROR number of field exceeded fldsMax: "//trim(stdname), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + fldlist(num)%stdname = trim(stdname) + if (present(shortname)) then + fldlist(num)%shortname = trim(shortname) + else + fldlist(num)%shortname = trim(stdname) + endif + fldlist(num)%transferOffer = trim(transferOffer) + if (present(ungridded_lbound) .and. present(ungridded_ubound)) then + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound + end if + +end subroutine fld_list_add + + +#ifndef CESMCOUPLED +subroutine shr_log_setLogUnit(nunit) + integer, intent(in) :: nunit + ! do nothing for this stub - its just here to replace + ! having cppdefs in the main program +end subroutine shr_log_setLogUnit +#endif + +!> +!! @page nuopc_cap NUOPC Cap +!! @author Fei Liu (fei.liu@gmail.com) +!! @date 5/10/13 Original documentation +!! @author Rocky Dunlap (rocky.dunlap@noaa.gov) +!! @date 1/12/17 Moved to doxygen +!! @date 2/28/19 Rewrote for unified cap +!! @tableofcontents +!! +!! @section Overview Overview +!! +!! **This MOM cap has been tested with MOM6.** +!! +!! This document describes the MOM NUOPC "cap", which is a light weight software layer that is +!! required when the [MOM ocean model](https://github.com/NOAA-GFDL/MOM6/tree/dev/master) +!! is used in [National Unified Operation Prediction Capability] +!! (http://www.earthsystemcog.org/projects/nuopc) (NUOPC) coupled systems. Also see the +!! [MOM wiki](https://github.com/NOAA-GFDL/MOM6-Examples/wiki) for more documentation. +!! +!! NUOPC is a software layer built on top of the [Earth System Modeling +!! Framework] (https://www.earthsystemcog.org/projects/esmf) (ESMF). +!! ESMF is a high-performance modeling framework that provides +!! data structures, interfaces, and operations suited for building coupled models +!! from a set of components. NUOPC refines the capabilities of ESMF by providing +!! a more precise definition of what it means for a model to be a component and +!! how components should interact and share data in a coupled system. The NUOPC +!! Layer software is designed to work with typical high-performance models in the +!! Earth sciences domain, most of which are written in Fortran and are based on a +!! distributed memory model of parallelism (MPI). +!! +!! A NUOPC "cap" is a Fortran module that serves as the interface to a model +!! when it's used in a NUOPC-based coupled system. +!! The term "cap" is used because it is a light weight software layer that sits on top +!! of model code, making calls into it and exposing model data structures in a +!! standard way. +!! +!! The MOM cap package includes the cap code itself (MOM_cap.F90, MOM_cap_methods.F90 +!! and MOM_cap_time.F90), a set of time utilities (time_utils.F90) for converting between ESMF and FMS +!! time type and two modules MOM_ocean_model_nuopc.F90 and MOM_surface_forcing_nuopc.F90. MOM_surface_forcing_nuopc.F90 +!! converts the input ESMF data (import data) to a MOM-specific data type (surface_forcing_CS). +!! MOM_ocean_model_nuopc.F90 contains routines for initialization, update and finalization of the ocean model state. +!! +!! @subsection CapSubroutines Cap Subroutines +!! +!! The MOM cap modules contains a set of subroutines that are required +!! by NUOPC. These subroutines are called by the NUOPC infrastructure according +!! to a predefined calling sequence. Some subroutines are called during +!! initialization of the coupled system, some during the run of the coupled +!! system, and some during finalization of the coupled system. +!! +!! The initialization sequence is the most complex and is governed by the NUOPC technical rules. +!! Details about the initialization sequence can be found in the [NUOPC Reference Manual] +!! (http://www.earthsystemmodeling.org/esmf_releases/last_built/NUOPC_refdoc/). +!! The cap requires beta snapshot ESMF v8.0.0bs16 or later. +!! +!! The following table summarizes the NUOPC-required subroutines that appear in the +!! MOM cap. The "Phase" column says whether the subroutine is called during the +!! initialization, run, or finalize part of the coupled system run. +!! +!! +!! +!! +!! +!! +!! +!!
Phase MOM Cap Subroutine Description +!!
Init +!! [InitializeP0] (@ref MOM_cap_mod::initializep0) +!! Sets the Initialize Phase Definition (IPD) version to use +!!
Init +!! [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) +!! Advertises standard names of import and export fields +!!
Init +!! [InitializeRealize] (@ref MOM_cap_mod::initializerealize) +!! Creates an ESMF_Grid or ESMF_Mesh as well as ESMF_Fields for import and export fields +!!
Run +!! [ModelAdvance] (@ref MOM_cap_mod::modeladvance) +!! Advances the model by a timestep +!!
Final +!! [Finalize] (@ref MOM_cap_mod::ocean_model_finalize) +!! Cleans up +!!
+!! +!! +!! @section UnderlyingModelInterfaces Underlying Model Interfaces +!! +!! +!! @subsection DomainCreation Domain Creation +!! +!! The cap can accomodate a MOM tripolar grid which is represented either as a 2D `ESMF_Grid` or +!! as a 1D `ESMF_Mesh`. Other MOM grids (e.g. a bipolar grid) can be represented as a 1d `ESMF_Mesh` only. +!! Coupling fields are placed on either the `ESMF_Grid` or `ESMF_Mesh`. +!! Note that for either the `ESMF_Grid` or `ESMF_Mesh` representation, the fields are translated into +!! a 2D MOM specific surface boundary type and the distinction between the two is no longer there. +!! Calls related to creating the grid are located in the [InitializeRealize] +!! (@ref MOM_cap_mod::initializerealize) subroutine, which is called by the NUOPC infrastructure +!! during the intialization sequence. +!! +!! The cap determines parameters for setting up the grid by calling subroutines in the +!! `mpp_domains_mod` module. The global domain size is determined by calling `mpp_get_global_domain()`. +!! A check is in place to ensure that there is only a single tile in the domain (the +!! cap is currently limited to one tile; multi-tile mosaics are not supported). The +!! decomposition across processors is determined via calls to `mpp_get_compute_domains()` +!! (to retrieve decomposition block indices) and `mpp_get_pelist()` (to determine how +!! blocks are assigned to processors). +!! +!! The `ESMF_Grid` is created in several steps: +!! - an `ESMF_DELayout` is created based on the pelist from MOM +!! - an `ESMF_DistGrid` is created over the global index space. Connections are set +!! up so that the index space is periodic in the first dimension and has a +!! fold at the top for the bipole. The decompostion blocks are also passed in +!! along with the `ESMF_DELayout` mentioned above. +!! - an `ESMF_Grid` is then created by passing in the above `ESMF_DistGrid`. +!! - masks, areas, center (tlat, tlon), and corner (ulat, ulon) coordinates are then added to the `ESMF_Grid` +!! by retrieving those fields from the MOM datatype `ocean_grid` elements. +!! +!! The `ESMF_Mesh` is also created in several steps: +!! - the target mesh is generated offline. +!! - a temporary mesh is created from an input file specified by the config variable `mesh_ocn`. +!! the mesh has a distribution that is automatically generated by ESMF when reading in the mesh +!! - an `ESMF_DistGrid` is created from the global index space for the computational domain. +!! - the final `ESMF_Mesh` is then created by distributing the temporary mesh using the created `ESMF_DistGrid`. +!! +!! +!! @subsection Initialization Initialization +!! +!! During the [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) phase, calls are +!! made to MOM's native initialization subroutines. The MPI communicator +!! is pulled in through the ESMF VM object for the MOM component. The dt and start time are set +!! from parameters from the incoming ESMF clock with calls to `set_time()` and `set_date().` +!! +!! +!! @subsection Run Run +!! +!! The [ModelAdvance] (@ref MOM_cap_mod::modeladvance) subroutine is called by the NUOPC +!! infrastructure when it's time for MOM to advance in time. During this subroutine, there is a +!! call into the MOM update routine: +!! +!! call update_ocean_model(Ice_ocean_boundary, Ocean_state, Ocean_public, Time, Time_step_coupled, cesm_coupled) +!! +!! Priori to the call to `update_ocean_model()`, the cap performs these steps +!! - the `Time` and `Time_step_coupled` parameters, based on FMS types, are derived from the incoming ESMF clock +!! - diagnostics are optionally written to files `field_ocn_import_*`, one for each import field +!! - mom_import is called and translates to the ESMF input data to a MOM specific data type +!! - momentum flux vectors are rotated to internal grid +!! +!! After the call to `update_ocean_model()`, the cap performs these steps: +!! - mom_export is called +!! - the `ocean_mask` export is set to match that of the internal MOM mask +!! - the `freezing_melting_potential` export is converted from J m-2 to W m-2 by dividing by the coupling interval +!! - vector rotations are applied to the `ocean_current_zonal` and `ocean_current_merid` exports, back to lat-lon grid +!! - diagnostics are optionally written to files `field_ocn_export_*`, one for each export field +!! - optionally, a call is made to `ocean_model_restart()` at the interval `restart_interval` +!! +!! @subsubsection VectorRotations Vector Rotations +!! +!! Vector rotations are applied to incoming momentum fluxes (from regular lat-lon to tripolar grid) and +!! outgoing ocean currents (from tripolar to regular lat-lon). The rotation angles are provided +!! from the native MOM grid by a call to `get_ocean_grid(Ocean_grid)`. +!! The cosine and sine of the rotation angle are: +!! +!! ocean_grid%cos_rot(i,j) +!! ocean_grid%sin_rot(i,j) +!! +!! The rotation of momentum flux from regular lat-lon to tripolar is: +!! \f[ +!! \begin{bmatrix} +!! \tau_x' \\ +!! \tau_y' +!! \end{bmatrix} = +!! \begin{bmatrix} +!! cos \theta & sin \theta \\ +!! -sin \theta & cos \theta +!! \end{bmatrix} * +!! \begin{bmatrix} +!! \tau_x \\ +!! \tau_y +!! \end{bmatrix} +!! \f] +!! +!! The rotation of ocean current from tripolar to regular lat-lon is: +!! \f[ +!! \begin{bmatrix} +!! u' \\ +!! v' +!! \end{bmatrix} = +!! \begin{bmatrix} +!! cos \theta & -sin \theta \\ +!! sin \theta & cos \theta +!! \end{bmatrix} * +!! \begin{bmatrix} +!! u \\ +!! v +!! \end{bmatrix} +!! \f] +!! @subsection Finalization Finalization +!! +!! NUOPC infrastructure calls [ocean_model_finalize] (@ref MOM_cap_mod::ocean_model_finalize) +!! at the end of the run. This subroutine is a hook to call into MOM's native shutdown +!! procedures: +!! +!! call ocean_model_end (ocean_public, ocean_State, Time) +!! +!! @section ModelFields Model Fields +!! +!! The following tables list the import and export fields currently set up in the MOM cap. +!! +!! @subsection ImportFields Import Fields +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!!
Standard Name +!! Units +!! Model Variable +!! Description +!! Notes +!!
Sa_pslvPappressure of overlying sea ice and atmosphere
mass_of_overlying_sea_icekgmimass of overlying sea ice
Fioi_melthW m-2seaice_melt_heatsea ice and snow melt heat flux
Fioi_meltwkg m-2 s-1seaice_meltwater flux due to sea ice and snow melting
mean_calving_ratekg m-2 s-1calvingmass flux of frozen runoff
Foxx_evapkg m-2 s-1q_fluxspecific humidity flux
Faxa_snowkg m-2 s-1fprecmass flux of frozen precip
Foxx_lwnetW m-2lw_fluxlong wave radiation
Foxx_swnet_idfW m-2sw_flux_nir_difdiffuse near IR shortwave radiation
Foxx_swnet_idrW m-2sw_flux_nir_dirdirect near IR shortwave radiation
Foxx_swnet_vdfW m-2sw_flux_vis_difdiffuse visible shortware radiation
Foxx_swnet_idrW m-2sw_flux_vis_dirdirect visible shortware radiation
Faxa_rainkg m-2 s-1lprecmass flux of liquid precip
Foxx_hrainW m-2hrainheat content (enthalpy) of liquid water entering the ocean
Foxx_hsnowW m-2hsnowheat content (enthalpy) of frozen water entering the ocean
Foxx_hevapW m-2hevapheat content (enthalpy) of water leaving the ocean
Foxx_hcondW m-2hcondheat content (enthalpy) of liquid water entering the ocean due to condensation
Foxx_hroflW m-2hroflheat content (enthalpy) of liquid runoff
Foxx_hrofiW m-2hrofiheat content (enthalpy) of frozen runoff
Foxx_roflkg m-2 s-1runoffmass flux of liquid runoff
Foxx_rofikg m-2 s-1runoffmass flux of frozen runoff
Fioi_saltkg m-2 s-1salt_fluxsalt flux
Foxx_senW m-2t_fluxsensible heat flux into ocean
Foxx_tauxPau_fluxi-directed wind stress into ocean[vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar
Foxx_tauyPav_fluxj-directed wind stress into ocean[vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar
+!! +!! @subsection ExportField Export Fields +!! +!! Export fields are populated from the `ocean_public` parameter (type `ocean_public_type`) +!! after the call to `update_ocean_model()`. +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!! +!!
Standard NameUnitsModel VariableDescriptionNotes
Fioo_qW m-2combination of frazil and melt_potentialcap converts model units (J m-2) to (W m-2) for export
So_omaskocean mask
So_vm s-1v_surfj-directed surface velocity on u-cell[vector rotation] (@ref VectorRotations) applied - tripolar to lat-lon
So_um s-1u_surfi-directed surface velocity on u-cell[vector rotation] (@ref VectorRotations) applied - tripolar to lat-lon
So_spsus_surfsea surface salinity on t-cell
So_tKt_surfsea surface temperature on t-cell
So_dhdxunitlesscreated from sshsea surface zonal slope
So_dhyunitlesscreated from sshsea surface meridional slope
So_bldepthmobldocean surface boundary layer depth
+!! +!! @subsection MemoryManagement Memory Management +!! +!! The MOM cap has an internal state type with pointers to three +!! types defined by MOM. There is also a small wrapper derived type +!! required to associate an internal state instance +!! with the ESMF/NUOPC component: +!! +!! type ocean_internalstate_type +!! type(ocean_public_type), pointer :: ocean_public_type_ptr +!! type(ocean_state_type), pointer :: ocean_state_type_ptr +!! type(ice_ocean_boundary_type), pointer :: ice_ocean_boundary_type_ptr +!! end type +!! +!! type ocean_internalstate_wrapper +!! type(ocean_internalstate_type), pointer :: ptr +!! end type +!! +!! The member of type `ocean_public_type` stores ocean surface fields used during the coupling. +!! The member of type `ocean_state_type` is required by the ocean driver, +!! although its internals are private (not to be used by the coupling directly). +!! This type is passed to the ocean init and update routines +!! so that it can maintain state there if desired. +!! The member of type `ice_ocean_boundary_type` is populated by this cap +!! with incoming coupling fields from other components. These three derived types are allocated during the +!! [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) phase. Also during that +!! phase, the `ice_ocean_boundary` type members are all allocated using bounds retrieved +!! from `get_domain_extent()`. +!! +!! During the [InitializeRealize] (@ref MOM_cap_mod::initializerealize) phase, +!! `ESMF_Field`s are created for each of the coupling fields in the `ice_ocean_boundary` +!! and `ocean_public_type` members of the internal state. These fields directly reference into the members of +!! the `ice_ocean_boundary` and `ocean_public_type` so that memory-to-memory copies are not required to move +!! data from the cap's import and export states to the memory areas used internally +!! by MOM. +!! +!! @subsection IO I/O +!! +!! The cap can optionally output coupling fields for diagnostic purposes if the ESMF attribute +!! "DumpFields" has been set to "true". In this case the cap will write out NetCDF files +!! with names "field_ocn_import_.nc" and "field_ocn_export_.nc". +!! Additionally, calls will be made to the cap subroutine [dumpMomInternal] +!! (@ref MOM_cap_mod::dumpmominternal) to write out model internal fields to files +!! named "field_ocn_internal_.nc". In all cases these NetCDF files will +!! contain a time series of field data. +!! +!! @section RuntimeConfiguration Runtime Configuration +!! +!! At runtime, the MOM cap can be configured with several options provided +!! as ESMF attributes. Attributes can be set in the cap by the NUOPC Driver +!! above this cap, or in some systems ESMF attributes are set by +!! reading in from a configuration file. The available attributes are: +!! +!! * `DumpFields` - when set to "true", write out diagnostic NetCDF files for import/export/internal fields +!! * `ProfileMemory` - when set to "true", write out memory usage information to the ESMF log files; this +!! information is written when entering and leaving the [ModelAdvance] +!! (@ref MOM_cap_mod::modeladvance) subroutine and before and after the call to +!! `update_ocean_model()`. +!! * `restart_interval` - integer number of seconds indicating the interval at +!! which to call `ocean_model_restart()`; no restarts written if set to 0 + +end module MOM_cap_mod diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 new file mode 100644 index 0000000000..125bae5748 --- /dev/null +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -0,0 +1,1109 @@ +!> Contains import/export methods for CMEPS. +module MOM_cap_methods + +use ESMF, only: ESMF_Clock, ESMF_ClockGet, ESMF_time, ESMF_TimeGet +use ESMF, only: ESMF_TimeInterval, ESMF_TimeIntervalGet +use ESMF, only: ESMF_State, ESMF_StateGet +use ESMF, only: ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate +use ESMF, only: ESMF_GridComp, ESMF_Mesh, ESMF_MeshGet, ESMF_Grid, ESMF_GridCreate +use ESMF, only: ESMF_DistGrid, ESMF_DistGridCreate +use ESMF, only: ESMF_KIND_R8, ESMF_SUCCESS, ESMF_LogFoundError +use ESMF, only: ESMF_LOGERR_PASSTHRU, ESMF_LOGMSG_INFO, ESMF_LOGWRITE +use ESMF, only: ESMF_LogSetError, ESMF_RC_MEM_ALLOCATE +use ESMF, only: ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND +use ESMF, only: ESMF_GEOMTYPE_FLAG, ESMF_GEOMTYPE_GRID, ESMF_GEOMTYPE_MESH +use ESMF, only: ESMF_RC_VAL_OUTOFRANGE, ESMF_INDEX_DELOCAL, ESMF_MESHLOC_ELEMENT +use ESMF, only: ESMF_TYPEKIND_R8, ESMF_FIELDSTATUS_COMPLETE +use ESMF, only: ESMF_FieldStatus_Flag, ESMF_LOGMSG_ERROR, ESMF_FAILURE, ESMF_MAXSTR +use ESMF, only: operator(/=), operator(==) +use MOM_ocean_model_nuopc, only: ocean_public_type, ocean_state_type +use MOM_surface_forcing_nuopc, only: ice_ocean_boundary_type +use MOM_grid, only: ocean_grid_type +use MOM_domains, only: pass_var +use mpp_domains_mod, only: mpp_get_compute_domain + +! By default make data private +implicit none; private + +! Public member functions +public :: mom_set_geomtype +public :: mom_import +public :: mom_export +public :: state_diagnose +public :: ChkErr + +interface State_getImport + module procedure State_getImport_2d + module procedure State_getImport_3d ! third dimension being an ungridded dimension +end interface + +private :: State_setExport + +!> Get field pointer +interface State_GetFldPtr + module procedure State_GetFldPtr_1d + module procedure State_GetFldPtr_2d +end interface + +integer :: import_cnt = 0!< used to skip using the import state + !! at the first count for cesm +type(ESMF_GeomType_Flag) :: geomtype !< SMF type describing type of + !! geometry (mesh or grid) + +! area correction factors for fluxes send and received from mediator +! these actors are ONLY valid for meshes that are read in - so do not need them for +! grids that are calculated internally + +real(ESMF_KIND_R8), public, allocatable :: mod2med_areacor(:) ! ratios of model areas to input mesh areas +real(ESMF_KIND_R8), public, allocatable :: med2mod_areacor(:) ! ratios of input mesh areas to model areas +character(len=*),parameter :: u_FILE_u = __FILE__ + +contains + +!> Sets module variable geometry type +subroutine mom_set_geomtype(geomtype_in) + type(ESMF_GeomType_Flag), intent(in) :: geomtype_in !< ESMF type describing type of + !! geometry (mesh or grid) + + geomtype = geomtype_in + +end subroutine mom_set_geomtype + +!> This function has a few purposes: +!! (1) it imports surface fluxes using data from the mediator; and +!! (2) it can apply restoring in SST and SSS. +subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc) + type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state + type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid + type(ESMF_State) , intent(inout) :: importState !< incoming data from mediator + type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing + integer , intent(inout) :: rc !< Return code + + ! Local Variables + integer :: i, j, ib, ig, jg, n + integer :: isc, iec, jsc, jec + integer :: nsc ! number of stokes drift components + character(len=128) :: fldname + real(ESMF_KIND_R8), allocatable :: taux(:,:) + real(ESMF_KIND_R8), allocatable :: tauy(:,:) + real(ESMF_KIND_R8), allocatable :: stkx(:,:,:) + real(ESMF_KIND_R8), allocatable :: stky(:,:,:) + character(len=*) , parameter :: subname = '(mom_import)' + + rc = ESMF_SUCCESS + + ! ------- + ! import_cnt is used to skip using the import state at the first count for cesm + ! ------- + + ! The following are global indices without halos + call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + + !---- + ! surface height pressure + !---- + call state_getimport(importState, 'Sa_pslv', isc, iec, jsc, jec, ice_ocean_boundary%p, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! near-IR, direct shortwave (W/m2) + !---- + call state_getimport(importState, 'Foxx_swnet_idr', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_nir_dir, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! near-IR, diffuse shortwave (W/m2) + !---- + call state_getimport(importState, 'Foxx_swnet_idf', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_nir_dif, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! visible, direct shortwave (W/m2) + !---- + call state_getimport(importState, 'Foxx_swnet_vdr', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_vis_dir, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! visible, diffuse shortwave (W/m2) + !---- + call state_getimport(importState, 'Foxx_swnet_vdf', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_vis_dif, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! ------- + ! Net longwave radiation (W/m2) + ! ------- + call state_getimport(importState, 'Foxx_lwnet', isc, iec, jsc, jec, & + ice_ocean_boundary%lw_flux, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! zonal and meridional surface stress + !---- + allocate (taux(isc:iec,jsc:jec)) + allocate (tauy(isc:iec,jsc:jec)) + + call state_getimport(importState, 'Foxx_taux', isc, iec, jsc, jec, taux, & + areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Foxx_tauy', isc, iec, jsc, jec, tauy, & + areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! rotate taux and tauy from true zonal/meridional to local coordinates + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ice_ocean_boundary%u_flux(i,j) = ocean_grid%cos_rot(ig,jg)*taux(i,j) & + - ocean_grid%sin_rot(ig,jg)*tauy(i,j) + ice_ocean_boundary%v_flux(i,j) = ocean_grid%cos_rot(ig,jg)*tauy(i,j) & + + ocean_grid%sin_rot(ig,jg)*taux(i,j) + enddo + enddo + + deallocate(taux, tauy) + + !---- + ! sensible heat flux (W/m2) + !---- + call state_getimport(importState, 'Foxx_sen', isc, iec, jsc, jec, & + ice_ocean_boundary%t_flux, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! evaporation flux (W/m2) + !---- + call state_getimport(importState, 'Foxx_evap', isc, iec, jsc, jec, & + ice_ocean_boundary%q_flux, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! liquid precipitation (rain) + !---- + call state_getimport(importState, 'Faxa_rain', isc, iec, jsc, jec, & + ice_ocean_boundary%lprec, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! frozen precipitation (snow) + !---- + call state_getimport(importState, 'Faxa_snow', isc, iec, jsc, jec, & + ice_ocean_boundary%fprec, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! mass and heat content of liquid and frozen runoff + !---- + ! Note - preset values to 0, if field does not exist in importState, then will simply return + ! and preset value will be used + + ! liquid runoff + ice_ocean_boundary%lrunoff (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Foxx_rofl', & + isc, iec, jsc, jec, ice_ocean_boundary%lrunoff, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! ice runoff + ice_ocean_boundary%frunoff (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Foxx_rofi', & + isc, iec, jsc, jec, ice_ocean_boundary%frunoff, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! Enthalpy terms + !---- + + !---- + ! enthalpy from liquid precipitation (hrain) + !---- + if ( associated(ice_ocean_boundary%hrain) ) then + call state_getimport(importState, 'Foxx_hrain', isc, iec, jsc, jec, & + ice_ocean_boundary%hrain, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !---- + ! enthalpy from frozen precipitation (hsnow) + !---- + if ( associated(ice_ocean_boundary%hsnow) ) then + call state_getimport(importState, 'Foxx_hsnow', isc, iec, jsc, jec, & + ice_ocean_boundary%hsnow, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !---- + ! enthalpy from liquid runoff (hrofl) + !---- + if ( associated(ice_ocean_boundary%hrofl) ) then + call state_getimport(importState, 'Foxx_hrofl', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofl, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !---- + ! enthalpy from frozen runoff (hrofi) + !---- + if ( associated(ice_ocean_boundary%hrofi) ) then + call state_getimport(importState, 'Foxx_hrofi', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofi, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !---- + ! enthalpy from evaporation (hevap) + !---- + if ( associated(ice_ocean_boundary%hevap) ) then + call state_getimport(importState, 'Foxx_hevap', isc, iec, jsc, jec, & + ice_ocean_boundary%hevap, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !---- + ! enthalpy from condensation (hcond) + !---- + if ( associated(ice_ocean_boundary%hcond) ) then + call state_getimport(importState, 'Foxx_hcond', isc, iec, jsc, jec, & + ice_ocean_boundary%hcond, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! salt flux from ice + !---- + ice_ocean_boundary%salt_flux(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Fioi_salt', isc, iec, jsc, jec, & + ice_ocean_boundary%salt_flux, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! snow&ice melt heat flux (W/m^2) + !---- + ice_ocean_boundary%seaice_melt_heat(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Fioi_melth', isc, iec, jsc, jec, & + ice_ocean_boundary%seaice_melt_heat, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! snow&ice melt water flux (W/m^2) + !---- + ice_ocean_boundary%seaice_melt(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Fioi_meltw', isc, iec, jsc, jec, & + ice_ocean_boundary%seaice_melt, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! mass of overlying ice + !---- + ! Note - preset values to 0, if field does not exist in importState, then will simply return + ! and preset value will be used + ice_ocean_boundary%mi(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'mass_of_overlying_ice', isc, iec, jsc, jec, & + ice_ocean_boundary%mi,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! sea-ice fraction + !---- + ice_ocean_boundary%ice_fraction(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Si_ifrac', isc, iec, jsc, jec, & + ice_ocean_boundary%ice_fraction, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! 10m wind squared + !---- + ice_ocean_boundary%u10_sqr(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'So_duu10n', isc, iec, jsc, jec, & + ice_ocean_boundary%u10_sqr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! Langmuir enhancement factor + !---- + if ( associated(ice_ocean_boundary%lamult) ) then + ice_ocean_boundary%lamult (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Sw_lamult', isc, iec, jsc, jec, & + ice_ocean_boundary%lamult, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! Partitioned Stokes Drift Components + !---- + if ( associated(ice_ocean_boundary%ustkb) ) then + nsc = Ice_ocean_boundary%num_stk_bands + allocate(stkx(isc:iec,jsc:jec,1:nsc)) + allocate(stky(isc:iec,jsc:jec,1:nsc)) + + call state_getimport(importState,'Sw_pstokes_x', isc, iec, jsc, jec, 1, nsc, stkx, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'Sw_pstokes_y', isc, iec, jsc, jec, 1, nsc, stky, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! rotate from true zonal/meridional to local coordinates + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + !rotate + do ib = 1, nsc + ice_ocean_boundary%ustkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stkx(i,j,ib) & + - ocean_grid%sin_rot(ig,jg)*stky(i,j,ib) + ice_ocean_boundary%vstkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stky(i,j,ib) & + + ocean_grid%sin_rot(ig,jg)*stkx(i,j,ib) + enddo + ! apply masks + ice_ocean_boundary%ustkb(i,j,:) = ice_ocean_boundary%ustkb(i,j,:) * ocean_grid%mask2dT(ig,jg) + ice_ocean_boundary%vstkb(i,j,:) = ice_ocean_boundary%vstkb(i,j,:) * ocean_grid%mask2dT(ig,jg) + enddo + enddo + deallocate(stkx,stky) + endif + +end subroutine mom_import + +!> Maps outgoing ocean data to ESMF State +subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc) + type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state + type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid + type(ocean_state_type) , pointer :: ocean_state !< Ocean state + type(ESMF_State) , intent(inout) :: exportState !< outgoing data + type(ESMF_Clock) , intent(in) :: clock !< ESMF clock + integer , intent(inout) :: rc !< Return code + + ! Local variables + integer :: i, j, ig, jg ! indices + integer :: isc, iec, jsc, jec ! indices + integer :: iloc, jloc ! indices + integer :: iglob, jglob ! indices + integer :: n + integer :: icount + real :: slp_L, slp_R, slp_C + real :: slope, u_min, u_max + integer :: day, secs + type(ESMF_TimeInterval) :: timeStep + integer :: dt_int + real :: inv_dt_int !< The inverse of coupling time interval in s-1. + type(ESMF_StateItem_Flag) :: itemFlag + real(ESMF_KIND_R8), allocatable :: omask(:,:) + real(ESMF_KIND_R8), allocatable :: melt_potential(:,:) + real(ESMF_KIND_R8), allocatable :: ocz(:,:), ocm(:,:) + real(ESMF_KIND_R8), allocatable :: ocz_rot(:,:), ocm_rot(:,:) + real(ESMF_KIND_R8), allocatable :: ssh(:,:) + real(ESMF_KIND_R8), allocatable :: dhdx(:,:), dhdy(:,:) + real(ESMF_KIND_R8), allocatable :: dhdx_rot(:,:), dhdy_rot(:,:) + character(len=*) , parameter :: subname = '(mom_export)' + + rc = ESMF_SUCCESS + + call ESMF_ClockGet( clock, timeStep=timeStep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeIntervalGet( timeStep, s=dt_int, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Use Adcroft's rule of reciprocals; it does the right thing here. + if (real(dt_int) > 0.0) then + inv_dt_int = 1.0 / real(dt_int) + else + inv_dt_int = 0.0 + endif + + !---------------- + ! Copy from ocean_public to exportstate. + !---------------- + + call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + + ! ------- + ! ocean mask + ! ------- + + allocate(omask(isc:iec, jsc:jec)) + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + omask(i,j) = nint(ocean_grid%mask2dT(ig,jg)) + enddo + enddo + + call State_SetExport(exportState, 'So_omask', isc, iec, jsc, jec, omask, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(omask) + + ! ------- + ! Sea surface temperature + ! ------- + call State_SetExport(exportState, 'So_t', isc, iec, jsc, jec, ocean_public%t_surf, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! ------- + ! Sea surface salinity + ! ------- + call State_SetExport(exportState, 'So_s', isc, iec, jsc, jec, ocean_public%s_surf, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! ------- + ! zonal and meridional currents + ! ------- + + ! rotate ocn current from tripolar grid back to lat/lon grid x,y => latlon (CCW) + ! "ocean_grid" has halos and uses local indexing. + + allocate(ocz(isc:iec, jsc:jec)) + allocate(ocm(isc:iec, jsc:jec)) + allocate(ocz_rot(isc:iec, jsc:jec)) + allocate(ocm_rot(isc:iec, jsc:jec)) + + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ocz(i,j) = ocean_public%u_surf(i,j) + ocm(i,j) = ocean_public%v_surf(i,j) + ocz_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocz(i,j) + ocean_grid%sin_rot(ig,jg)*ocm(i,j) + ocm_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocm(i,j) - ocean_grid%sin_rot(ig,jg)*ocz(i,j) + enddo + enddo + + call State_SetExport(exportState, 'So_u', isc, iec, jsc, jec, ocz_rot, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call State_SetExport(exportState, 'So_v', isc, iec, jsc, jec, ocm_rot, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(ocz, ocm, ocz_rot, ocm_rot) + + ! ------- + ! Boundary layer depth + ! ------- + call ESMF_StateGet(exportState, 'So_bldepth', itemFlag, rc=rc) + if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then + call State_SetExport(exportState, 'So_bldepth', isc, iec, jsc, jec, & + ocean_public%obld, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + ! ------- + ! Freezing melting potential + ! ------- + ! melt_potential, defined positive for T>Tfreeze, so need to change sign + ! Convert from J/m^2 to W/m^2 and make sure Melt_potential is always <= 0 + + allocate(melt_potential(isc:iec, jsc:jec)) + + do j = jsc,jec + do i = isc,iec + if (ocean_public%frazil(i,j) > 0.0) then + melt_potential(i,j) = ocean_public%frazil(i,j) * inv_dt_int + else + melt_potential(i,j) = -ocean_public%melt_potential(i,j) * inv_dt_int + if (melt_potential(i,j) > 0.0) melt_potential(i,j) = 0.0 + endif + enddo + enddo + + call State_SetExport(exportState, 'Fioo_q', isc, iec, jsc, jec, & + melt_potential, ocean_grid, areacor=mod2med_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(melt_potential) + + ! ------- + ! Sea level + ! ------- + call ESMF_StateGet(exportState, 'sea_level', itemFlag, rc=rc) + if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then + call State_SetExport(exportState, 'sea_level', & + isc, iec, jsc, jec, ocean_public%sea_lev, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---------------- + ! Sea-surface zonal and meridional slopes + !---------------- + + allocate(ssh(ocean_grid%isd:ocean_grid%ied,ocean_grid%jsd:ocean_grid%jed)) ! local indices with halos + allocate(dhdx(isc:iec, jsc:jec)) !global indices without halos + allocate(dhdy(isc:iec, jsc:jec)) !global indices without halos + allocate(dhdx_rot(isc:iec, jsc:jec)) !global indices without halos + allocate(dhdy_rot(isc:iec, jsc:jec)) !global indices without halos + + ssh = 0.0_ESMF_KIND_R8 + dhdx = 0.0_ESMF_KIND_R8 + dhdy = 0.0_ESMF_KIND_R8 + + ! Make a copy of ssh in order to do a halo update (ssh has local indexing with halos) + do j = ocean_grid%jsc, ocean_grid%jec + jloc = j + ocean_grid%jdg_offset + do i = ocean_grid%isc,ocean_grid%iec + iloc = i + ocean_grid%idg_offset + ssh(i,j) = ocean_public%sea_lev(iloc,jloc) + enddo + enddo + + ! Update halo of ssh so we can calculate gradients (local indexing) + call pass_var(ssh, ocean_grid%domain) + + ! d/dx ssh + ! This is a simple second-order difference + ! dhdx(i,j) = 0.5 * (ssh(i+1,j) - ssh(i-1,j)) * ocean_grid%US%m_to_L*ocean_grid%IdxT(i,j) * ocean_grid%mask2dT(ig,jg) + + do jglob = jsc, jec + j = jglob + ocean_grid%jsc - jsc + do iglob = isc,iec + i = iglob + ocean_grid%isc - isc + ! This is a PLM slope which might be less prone to the A-grid null mode + slp_L = (ssh(I,j) - ssh(I-1,j)) * ocean_grid%mask2dCu(i-1,j) + if (ocean_grid%mask2dCu(i-1,j)==0.) slp_L = 0. + slp_R = (ssh(I+1,j) - ssh(I,j)) * ocean_grid%mask2dCu(i,j) + if (ocean_grid%mask2dCu(i+1,j)==0.) slp_R = 0. + slp_C = 0.5 * (slp_L + slp_R) + if ( (slp_L * slp_R) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + u_min = min( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) + u_max = max( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) + slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + slope = 0.0 + endif + dhdx(iglob,jglob) = slope * ocean_grid%US%m_to_L*ocean_grid%IdxT(i,j) * ocean_grid%mask2dT(i,j) + if (ocean_grid%mask2dT(i,j)==0.) dhdx(iglob,jglob) = 0.0 + enddo + enddo + + ! d/dy ssh + ! This is a simple second-order difference + ! dhdy(i,j) = 0.5 * (ssh(i,j+1) - ssh(i,j-1)) * ocean_grid%US%m_to_L*ocean_grid%IdyT(i,j) * ocean_grid%mask2dT(ig,jg) + + do jglob = jsc, jec + j = jglob + ocean_grid%jsc - jsc + do iglob = isc,iec + i = iglob + ocean_grid%isc - isc + ! This is a PLM slope which might be less prone to the A-ocean_grid null mode + slp_L = ssh(i,J) - ssh(i,J-1) * ocean_grid%mask2dCv(i,j-1) + if (ocean_grid%mask2dCv(i,j-1)==0.) slp_L = 0. + slp_R = ssh(i,J+1) - ssh(i,J) * ocean_grid%mask2dCv(i,j) + if (ocean_grid%mask2dCv(i,j+1)==0.) slp_R = 0. + slp_C = 0.5 * (slp_L + slp_R) + if ((slp_L * slp_R) > 0.0) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + u_min = min( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) + u_max = max( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) + slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + slope = 0.0 + endif + dhdy(iglob,jglob) = slope * ocean_grid%US%m_to_L*ocean_grid%IdyT(i,j) * ocean_grid%mask2dT(i,j) + if (ocean_grid%mask2dT(i,j)==0.) dhdy(iglob,jglob) = 0.0 + enddo + enddo + + ! rotate slopes from tripolar grid back to lat/lon grid, x,y => latlon (CCW) + ! "ocean_grid" uses has halos and uses local indexing. + + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + dhdx_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdx(i,j) + ocean_grid%sin_rot(ig,jg)*dhdy(i,j) + dhdy_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdy(i,j) - ocean_grid%sin_rot(ig,jg)*dhdx(i,j) + enddo + enddo + + call State_SetExport(exportState, 'So_dhdx', isc, iec, jsc, jec, dhdx_rot, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call State_SetExport(exportState, 'So_dhdy', isc, iec, jsc, jec, dhdy_rot, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(ssh, dhdx, dhdy, dhdx_rot, dhdy_rot) + +end subroutine mom_export + +!> Get field pointer 1D +subroutine State_GetFldPtr_1d(State, fldname, fldptr, rc) + type(ESMF_State) , intent(in) :: State !< ESMF state + character(len=*) , intent(in) :: fldname !< Field name + real(ESMF_KIND_R8), pointer , intent(in) :: fldptr(:)!< Pointer to the 1D field + integer, optional , intent(out) :: rc !< Return code + + ! local variables + type(ESMF_Field) :: lfield + integer :: lrc + character(len=*),parameter :: subname='(MOM_cap:State_GetFldPtr)' + + call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=lrc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=lrc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (present(rc)) rc = lrc + +end subroutine State_GetFldPtr_1d + +!> Get field pointer 2D +subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) + type(ESMF_State) , intent(in) :: State !< ESMF state + character(len=*) , intent(in) :: fldname !< Field name + real(ESMF_KIND_R8), pointer , intent(in) :: fldptr(:,:)!< Pointer to the 2D field + integer, optional , intent(out) :: rc !< Return code + + ! local variables + type(ESMF_Field) :: lfield + integer :: lrc + character(len=*),parameter :: subname='(MOM_cap:State_GetFldPtr)' + + call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=lrc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=lrc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (present(rc)) rc = lrc + +end subroutine State_GetFldPtr_2d + +!> Map 2d import state field to output array +subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum, areacor, rc) + type(ESMF_State) , intent(in) :: state !< ESMF state + character(len=*) , intent(in) :: fldname !< Field name + integer , intent(in) :: isc !< The start i-index of cell centers within + !! the computational domain + integer , intent(in) :: iec !< The end i-index of cell centers within the + !! computational domain + integer , intent(in) :: jsc !< The start j-index of cell centers within + !! the computational domain + integer , intent(in) :: jec !< The end j-index of cell centers within + !! the computational domain + real (ESMF_KIND_R8) , intent(inout) :: output(isc:iec,jsc:jec)!< Output 2D array + logical, optional , intent(in) :: do_sum !< If true, sums the data + real (ESMF_KIND_R8), optional, intent(in) :: areacor(:) !< flux area correction factors + !! applicable to meshes + integer , intent(out) :: rc !< Return code + + ! local variables + type(ESMF_StateItem_Flag) :: itemFlag + integer :: n, i, j, i1, j1 + integer :: lbnd1,lbnd2 + real(ESMF_KIND_R8), pointer :: dataPtr1d(:) + real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) + character(len=*) , parameter :: subname='(MOM_cap_methods:state_getimport_2d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) + if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then + + if (geomtype == ESMF_GEOMTYPE_MESH) then + + ! get field pointer + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! determine output array and apply area correction if present + n = 0 + do j = jsc,jec + do i = isc,iec + n = n + 1 + if (present(do_sum)) then + if (present(areacor)) then + output(i,j) = output(i,j) + dataPtr1d(n) * areacor(n) + else + output(i,j) = output(i,j) + dataPtr1d(n) + end if + else + if (present(areacor)) then + output(i,j) = dataPtr1d(n) * areacor(n) + else + output(i,j) = dataPtr1d(n) + end if + endif + enddo + enddo + + else if (geomtype == ESMF_GEOMTYPE_GRID) then + + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + lbnd1 = lbound(dataPtr2d,1) + lbnd2 = lbound(dataPtr2d,2) + + do j = jsc, jec + j1 = j + lbnd2 - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + if (present(do_sum)) then + output(i,j) = output(i,j) + dataPtr2d(i1,j1) + else + output(i,j) = dataPtr2d(i1,j1) + endif + enddo + enddo + + endif + + endif + +end subroutine State_GetImport_2d + +!> Map 3d import state field to output array (where 3rd dim is an ungridded dimension) +subroutine State_GetImport_3d(state, fldname, isc, iec, jsc, jec, lbd, ubd, output, do_sum, areacor, rc) + type(ESMF_State) , intent(in) :: state !< ESMF state + character(len=*) , intent(in) :: fldname !< Field name + integer , intent(in) :: isc !< The start i-index of cell centers within + !! the computational domain + integer , intent(in) :: iec !< The end i-index of cell centers within the + !! computational domain + integer , intent(in) :: jsc !< The start j-index of cell centers within + !! the computational domain + integer , intent(in) :: jec !< The end j-index of cell centers within + !! the computational domain + integer , intent(in) :: lbd !< lower bound of ungridded dimension + integer , intent(in) :: ubd !< upper bound of ungridded dimension + real (ESMF_KIND_R8) , intent(inout) :: output(isc:iec,jsc:jec,lbd:ubd)!< Output 3D array + logical, optional , intent(in) :: do_sum !< If true, sums the data + real (ESMF_KIND_R8), optional, intent(in) :: areacor(:) !< flux area correction factors + !! applicable to meshes + integer , intent(out) :: rc !< Return code + + ! local variables + type(ESMF_StateItem_Flag) :: itemFlag + integer :: n, i, j, i1, j1, u + integer :: lbnd1,lbnd2 + real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) + character(len=*) , parameter :: subname='(MOM_cap_methods:state_getimport_3d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) + if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then + + if (geomtype == ESMF_GEOMTYPE_MESH) then + + ! get field pointer + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! determine output array and apply area correction if present + do u = lbd, ubd ! ungridded dims + n = 0 + do j = jsc,jec + do i = isc,iec + n = n + 1 + if (present(do_sum)) then + if (present(areacor)) then + output(i,j,u) = output(i,j,u) + dataPtr2d(u,n) * areacor(n) + else + output(i,j,u) = output(i,j,u) + dataPtr2d(u,n) + end if + else + if (present(areacor)) then + output(i,j,u) = dataPtr2d(u,n) * areacor(n) + else + output(i,j,u) = dataPtr2d(u,n) + end if + endif + enddo + enddo + enddo + + else if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_LogWrite(trim(subname)//": ERROR ungridded dimensions not supported in MOM6 nuopc cap when "// & + "ESMF_GEOMTYPE_GRID is used. Use ESMF_GEOMTYPE_MESH instead.", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + + endif + +end subroutine State_GetImport_3d + +!> Map input array to export state +subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid, areacor, rc) + type(ESMF_State) , intent(inout) :: state !< ESMF state + character(len=*) , intent(in) :: fldname !< Field name + integer , intent(in) :: isc !< The start i-index of cell centers within + !! the computational domain + integer , intent(in) :: iec !< The end i-index of cell centers within the + !! computational domain + integer , intent(in) :: jsc !< The start j-index of cell centers within + !! the computational domain + integer , intent(in) :: jec !< The end j-index of cell centers within + !! the computational domain + real (ESMF_KIND_R8) , intent(in) :: input(isc:iec,jsc:jec)!< Input 2D array + type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean horizontal grid + real (ESMF_KIND_R8), optional, intent(in) :: areacor(:) !< flux area correction factors + !! applicable to meshes + integer , intent(out) :: rc !< Return code + + ! local variables + type(ESMF_StateItem_Flag) :: itemFlag + integer :: n, i, j, k, i1, j1, ig,jg + integer :: lbnd1,lbnd2 + real(ESMF_KIND_R8), pointer :: dataPtr1d(:) + real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) + character(len=*) , parameter :: subname='(MOM_cap_methods:state_setexport)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + ! Indexing notes: + ! input array from "ocean_public" uses local indexing without halos + ! mask from "ocean_grid" uses local indexing with halos + + call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) + if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then + + if (geomtype == ESMF_GEOMTYPE_MESH) then + + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + n = 0 + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + n = n+1 + dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) + enddo + enddo + if (present(areacor)) then + do n = 1,(size(dataPtr1d)) + dataPtr1d(n) = dataPtr1d(n) * areacor(n) + enddo + end if + + ! if a maskmap is provided, set exports of all eliminated cells to zero. + if (associated(ocean_grid%Domain%maskmap)) then + do k = n+1, size(dataPtr1d) + dataPtr1d(k) = 0.0 + enddo + endif + + else if (geomtype == ESMF_GEOMTYPE_GRID) then + + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + lbnd1 = lbound(dataPtr2d,1) + lbnd2 = lbound(dataPtr2d,2) + + do j = jsc, jec + j1 = j + lbnd2 - jsc + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + ig = i + ocean_grid%isc - isc + dataPtr2d(i1,j1) = input(i,j) * ocean_grid%mask2dT(ig,jg) + enddo + enddo + + endif + + endif + +end subroutine State_SetExport + +!> This subroutine writes the minimum, maximum and sum of each field +!! contained within an ESMF state. +subroutine state_diagnose(State, string, rc) + + ! ---------------------------------------------- + ! Diagnose status of State + ! ---------------------------------------------- + + type(ESMF_State), intent(in) :: state !< An ESMF State + character(len=*), intent(in) :: string !< A string indicating whether the State is an + !! import or export State + integer , intent(out) :: rc !< Return code + + ! local variables + integer :: i,j,n + type(ESMf_Field) :: lfield + integer :: fieldCount, lrank + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + real(ESMF_KIND_R8), pointer :: dataPtr1d(:) + real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) + character(len=*),parameter :: subname='(state_diagnose)' + character(len=ESMF_MAXSTR) :: msgString + ! ---------------------------------------------- + + call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + + call ESMF_StateGet(state, itemNameList=lfieldnamelist, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + do n = 1, fieldCount + + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + else + call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + enddo + + deallocate(lfieldnamelist) + +end subroutine state_diagnose + +!> Obtain a pointer to a rank 1 or rank 2 ESMF field +subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) + + ! input/output variables + type(ESMF_Field) , intent(in) :: field !< An ESMF field + real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr1(:) !< A pointer to a rank 1 ESMF field + real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr2(:,:) !< A pointer to a rank 2 ESMF field + integer , intent(out) , optional :: rank !< Field rank + logical , intent(in) , optional :: abort !< Abort code + integer , intent(out) , optional :: rc !< Return code + + ! local variables + type(ESMF_GeomType_Flag) :: geomtype + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_Mesh) :: lmesh + integer :: lrank, nnodes, nelements + logical :: labort + character(len=*), parameter :: subname='(field_getfldptr)' + ! ---------------------------------------------- + + if (.not.present(rc)) then + call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + rc = ESMF_SUCCESS + + labort = .true. + if (present(abort)) then + labort = abort + endif + lrank = -99 + + call ESMF_FieldGet(field, status=status, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (status /= ESMF_FIELDSTATUS_COMPLETE) then + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO) + endif + else + + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + endif ! status + + if (present(rank)) then + rank = lrank + endif + +end subroutine field_getfldptr + +!> Returns true if ESMF_LogFoundError() determines that rc is an error code. Otherwise false. +logical function ChkErr(rc, line, file) + integer, intent(in) :: rc !< return code to check + integer, intent(in) :: line !< Integer source line number + character(len=*), intent(in) :: file !< User-provided source file name + integer :: lrc + ChkErr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + ChkErr = .true. + endif +end function ChkErr + +end module MOM_cap_methods diff --git a/config_src/drivers/nuopc_cap/mom_cap_time.F90 b/config_src/drivers/nuopc_cap/mom_cap_time.F90 new file mode 100644 index 0000000000..d8ae6892a9 --- /dev/null +++ b/config_src/drivers/nuopc_cap/mom_cap_time.F90 @@ -0,0 +1,340 @@ +!> This was originally share code in CIME, but required CIME as a +!! dependency to build the MOM cap. The options here for setting +!! a restart alarm are useful for all caps, so a second step is to +!! determine if/how these could be offered more generally in a +!! shared library. For now we really want the MOM cap to only +!! depend on MOM and ESMF/NUOPC. +module MOM_cap_time + +! !USES: +use ESMF , only : ESMF_Time, ESMF_Clock, ESMF_Calendar, ESMF_Alarm +use ESMF , only : ESMF_TimeGet, ESMF_TimeSet +use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalSet +use ESMF , only : ESMF_ClockGet, ESMF_AlarmCreate +use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO +use ESMF , only : ESMF_LogSetError, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU +use ESMF , only : ESMF_RC_ARG_BAD +use ESMF , only : operator(<), operator(/=), operator(+), operator(-), operator(*) , operator(>=) +use ESMF , only : operator(<=), operator(>), operator(==) +use MOM_cap_methods , only : ChkErr + +implicit none; private + +public :: AlarmInit ! initialize an alarm + +private :: TimeInit +private :: date2ymd + +! Clock and alarm options +character(len=*), private, parameter :: & + optNONE = "none" , & + optNever = "never" , & + optNSteps = "nsteps" , & + optNStep = "nstep" , & + optNSeconds = "nseconds" , & + optNSecond = "nsecond" , & + optNMinutes = "nminutes" , & + optNMinute = "nminute" , & + optNHours = "nhours" , & + optNHour = "nhour" , & + optNDays = "ndays" , & + optNDay = "nday" , & + optNMonths = "nmonths" , & + optNMonth = "nmonth" , & + optNYears = "nyears" , & + optNYear = "nyear" , & + optMonthly = "monthly" , & + optYearly = "yearly" , & + optDate = "date" , & + optIfdays0 = "ifdays0" , & + optGLCCouplingPeriod = "glc_coupling_period" + +! Module data +integer, parameter :: SecPerDay = 86400 ! Seconds per day +character(len=*), parameter :: u_FILE_u = & + __FILE__ + +contains + +!> Setup an alarm in a clock. The ringtime sent to AlarmCreate +!! MUST be the next alarm time. If you send an arbitrary but +!! proper ringtime from the past and the ring interval, the alarm +!! will always go off on the next clock advance and this will cause +!! serious problems. Even if it makes sense to initialize an alarm +!! with some reference time and the alarm interval, that reference +!! time has to be advance forward to be >= the current time. +!! In the logic below we set an appropriate "NextAlarm" and then +!! we make sure to advance it properly based on the ring interval. +subroutine AlarmInit( clock, alarm, option, & + opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + type(ESMF_Clock) , intent(inout) :: clock !< ESMF clock + type(ESMF_Alarm) , intent(inout) :: alarm !< ESMF alarm + character(len=*) , intent(in) :: option !< alarm option + integer , optional , intent(in) :: opt_n !< alarm freq + integer , optional , intent(in) :: opt_ymd !< alarm ymd + integer , optional , intent(in) :: opt_tod !< alarm tod (sec) + type(ESMF_Time) , optional , intent(in) :: RefTime !< ref time + character(len=*) , optional , intent(in) :: alarmname !< alarm name + integer , intent(inout) :: rc !< Return code + + ! local variables + type(ESMF_Calendar) :: cal ! calendar + integer :: lymd ! local ymd + integer :: ltod ! local tod + integer :: cyy,cmm,cdd,csec ! time info + integer :: nyy,nmm,ndd,nsec ! time info + character(len=64) :: lalarmname ! local alarm name + logical :: update_nextalarm ! update next alarm + type(ESMF_Time) :: CurrTime ! Current Time + type(ESMF_Time) :: NextAlarm ! Next restart alarm time + type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval + character(len=*), parameter :: subname = '(AlarmInit): ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + lalarmname = 'alarm_unknown' + if (present(alarmname)) lalarmname = trim(alarmname) + ltod = 0 + if (present(opt_tod)) ltod = opt_tod + lymd = -1 + if (present(opt_ymd)) lymd = opt_ymd + + ! verify parameters + if (trim(option) == optNSteps .or. trim(option) == optNStep .or. & + trim(option) == optNSeconds .or. trim(option) == optNSecond .or. & + trim(option) == optNMinutes .or. trim(option) == optNMinute .or. & + trim(option) == optNHours .or. trim(option) == optNHour .or. & + trim(option) == optNDays .or. trim(option) == optNDay .or. & + trim(option) == optNMonths .or. trim(option) == optNMonth .or. & + trim(option) == optNYears .or. trim(option) == optNYear .or. & + trim(option) == optIfdays0) then + if (.not. present(opt_n)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_n', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + if (opt_n <= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' invalid opt_n', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + endif + + call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(CurrTime, yy=cyy, mm=cmm, dd=cdd, s=csec, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(CurrTime, yy=nyy, mm=nmm, dd=ndd, s=nsec, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! initial guess of next alarm, this will be updated below + if (present(RefTime)) then + NextAlarm = RefTime + else + NextAlarm = CurrTime + endif + + ! Determine calendar + call ESMF_ClockGet(clock, calendar=cal, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine inputs for call to create alarm + selectcase (trim(option)) + + case (optNONE, optNever) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optDate) + if (.not. present(opt_ymd)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_ymd', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + if (lymd < 0 .or. ltod < 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//'opt_ymd, opt_tod invalid', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optIfdays0) + if (.not. present(opt_ymd)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_ymd', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case (optNSteps, optNStep) + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNSeconds, optNSecond) + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMinutes, optNMinute) + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNHours, optNHour) + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNDays, optNDay) + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMonths, optNMonth) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optMonthly) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case (optNYears, optNYear) + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optYearly) + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case default + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//' unknown option: '//trim(option), & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + + end select + + ! -------------------------------------------------------------------------------- + ! --- AlarmInterval and NextAlarm should be set --- + ! -------------------------------------------------------------------------------- + + ! --- advance Next Alarm so it won't ring on first timestep for + ! --- most options above. go back one alarminterval just to be careful + + if (update_nextalarm) then + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo + endif + + alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, ringInterval=AlarmInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + +end subroutine AlarmInit + +!> Creates the ESMF_Time object corresponding to the given input time, +!! given in YMD (Year Month Day) and TOD (Time-of-day) format. Sets +!! the time by an integer as YYYYMMDD and integer seconds in the day. +subroutine TimeInit( Time, ymd, cal, tod, desc, logunit, rc) + type(ESMF_Time) , intent(inout) :: Time !< ESMF time + integer , intent(in) :: ymd !< year, month, day YYYYMMDD + type(ESMF_Calendar) , intent(in) :: cal !< ESMF calendar + integer , intent(in), optional :: tod !< time of day in [sec] + character(len=*) , intent(in), optional :: desc !< description of time to set + integer , intent(in), optional :: logunit!< Unit for stdout output + integer , intent(out), optional :: rc !< Return code + + ! local varaibles + integer :: yr, mon, day ! Year, month, day as integers + integer :: ltod ! local tod + character(len=256) :: ldesc ! local desc + character(len=*), parameter :: subname = '(TimeInit) ' + !------------------------------------------------------------------------------- + + ltod = 0 + if (present(tod)) ltod = tod + ldesc = '' + if (present(desc)) ldesc = desc + + if ( (ymd < 0) .or. (ltod < 0) .or. (ltod > SecPerDay) )then + if (present(logunit)) then + write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & + 'time-of-day out of bounds', ymd, ltod + endif + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//' yymmdd is negative or time-of-day out of bounds ', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + + call date2ymd (ymd,yr,mon,day) + + call ESMF_TimeSet( Time, yy=yr, mm=mon, dd=day, s=ltod, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + +end subroutine TimeInit + +!> Converts a coded-date (yyyymmdd) into calendar year,month,day. +subroutine date2ymd (date, year, month, day) + integer, intent(in) :: date !< coded-date (yyyymmdd) + integer, intent(out) :: year,month,day !< calendar year,month,day + + ! local variables + integer :: tdate ! temporary date + character(*),parameter :: subName = "(date2ymd)" + !------------------------------------------------------------------------------- + + tdate = abs(date) + year = int(tdate/10000) + if (date < 0) then + year = -year + endif + month = int( mod(tdate,10000)/ 100) + day = mod(tdate, 100) + +end subroutine date2ymd + +end module MOM_cap_time diff --git a/config_src/nuopc_driver/MOM_ocean_model.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 similarity index 73% rename from config_src/nuopc_driver/MOM_ocean_model.F90 rename to config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index abe583ffcc..9ac40daaa4 100644 --- a/config_src/nuopc_driver/MOM_ocean_model.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -1,5 +1,5 @@ !> Top-level module for the MOM6 ocean model in coupled mode. -module MOM_ocean_model +module MOM_ocean_model_nuopc ! This file is part of MOM6. See LICENSE.md for the license. @@ -11,57 +11,58 @@ module MOM_ocean_model ! This code is a stop-gap wrapper of the MOM6 code to enable it to be called ! in the same way as MOM4. -use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end -use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization -use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline -use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging -use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end -use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE -use MOM_domains, only : TO_ALL, Omit_Corners -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -use MOM_forcing_type, only : allocate_forcing_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields -use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing -use MOM_forcing_type, only : set_derived_forcing_fields -use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, file_exists, read_data, write_version_number -use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart -use MOM_string_functions, only : uppercase -use MOM_surface_forcing, only : surface_forcing_init, convert_IOB_to_fluxes -use MOM_surface_forcing, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum -use MOM_surface_forcing, only : ice_ocean_boundary_type, surface_forcing_CS -use MOM_surface_forcing, only : forcing_save_restart -use MOM_time_manager, only : time_type, get_time, set_time, operator(>) -use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) -use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real -use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init -use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end +use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization +use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized +use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart +use MOM_coms, only : field_chksum +use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging +use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields +use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing +use MOM_forcing_type, only : set_derived_forcing_fields +use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS +use MOM_string_functions, only : uppercase +use MOM_time_manager, only : time_type, get_time, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) +use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use MOM_interpolate, only : time_interp_external_init +use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_flux_init, call_tracer_set_forcing use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type -use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data -use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain -use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux -use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data +use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain +use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain +use MOM_io, only : stdout +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only : Update_Surface_Waves, query_wave_properties +use MOM_surface_forcing_nuopc, only : surface_forcing_init, convert_IOB_to_fluxes +use MOM_surface_forcing_nuopc, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum +use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS +use MOM_surface_forcing_nuopc, only : forcing_save_restart +use get_stochy_pattern_mod, only : write_stoch_restart_ocn +use iso_fortran_env, only : int64 #include @@ -78,15 +79,8 @@ module MOM_ocean_model public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum -public ocean_model_data_get -public get_ocean_grid - -!> This interface extracts a named scalar field or array from the ocean surface or public type -interface ocean_model_data_get - module procedure ocean_model_data1D_get - module procedure ocean_model_data2D_get -end interface - +public get_ocean_grid, query_ocean_state +public get_eps_omesh !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence @@ -151,7 +145,8 @@ module MOM_ocean_model integer :: nstep = 0 !< The number of calls to update_ocean. logical :: use_ice_shelf !< If true, the ice shelf model is enabled. - logical :: use_waves !< If true use wave coupling. + logical,public :: use_waves !< If true use wave coupling. + character(len=40) :: wave_method !< Wave coupling method. logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the !! ocean dynamics and forcing fluxes. @@ -176,11 +171,18 @@ module MOM_ocean_model !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. real :: dt !< (baroclinic) dynamics time step (seconds) - real :: dt_therm !< thermodynamics time step (seconds) + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. + logical :: do_sppt !< If true, stochastically perturb the diabatic and + !! write restarts + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and + !! genration termsand write restarts + + real :: eps_omesh !< Max allowable difference between ESMF mesh and MOM6 + !! domain coordinates type(directories) :: dirs !< A structure containing several relevant directory paths. type(mech_forcing) :: forces !< A structure with the driving mechanical surface forces @@ -199,8 +201,8 @@ module MOM_ocean_model !! about the vertical grid. type(unit_scale_type), pointer :: US => NULL() !< A pointer to a structure containing !! dimensional unit scaling factors. - type(MOM_control_struct), pointer :: & - MOM_CSp => NULL() !< A pointer to the MOM control structure + type(MOM_control_struct) :: MOM_CSp + !< MOM control structure type(ice_shelf_CS), pointer :: & Ice_shelf_CSp => NULL() !< A pointer to the control structure for the !! ice shelf model that couples with MOM6. This @@ -208,13 +210,12 @@ module MOM_ocean_model type(marine_ice_CS), pointer :: & marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. - type(wave_parameters_cs), pointer :: & - Waves !< A structure containing pointers to the surface wave fields + type(tracer_flow_control_CS), pointer :: & + tracer_flow_CSp => NULL() !< A pointer to the tracer flow control structure + type(wave_parameters_CS), pointer, public :: & + Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -227,7 +228,7 @@ module MOM_ocean_model !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indicies and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file, inst_index) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -244,6 +245,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read + integer, optional :: inst_index !< Ensemble index provided by the cap (instead of FMS ensemble manager) + ! Local variables real :: Rho0 ! The Boussinesq ocean density, in kg m-3. real :: G_Earth ! The gravitational acceleration in m s-2. @@ -251,7 +254,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! The actual depth over which melt potential is computed will !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. - logical :: use_melt_pot!< If true, allocate melt_potential array + logical :: use_melt_pot !< If true, allocate melt_potential array + ! This include declares and sets the variable "version". #include "version_variable.h" @@ -260,7 +264,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i integer :: secs, days type(param_file_type) :: param_file !< A structure to parse for run-time parameters logical :: use_temperature - type(time_type) :: dt_geometric, dt_savedays, dt_from_base call callTree_enter("ocean_model_init(), ocean_model_MOM.F90") if (associated(OS)) then @@ -273,14 +276,16 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return + call time_interp_external_init + OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & - diag_ptr=OS%diag, count_calls=.true.) + diag_ptr=OS%diag, count_calls=.true., tracer_flow_CSp=OS%tracer_flow_CSp, & + waves_CSp=OS%Waves, ensemble_num=inst_index) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & - use_temp=use_temperature) - OS%fluxes%C_p = OS%C_p + C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -290,16 +295,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that "//& - "is actually used will be an integer fraction of the "//& - "forcing time-step.", units="s", fail_if_missing=.true.) + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & "The thermodynamic and tracer advection time step. "//& "Ideally DT_THERM should be an integer multiple of DT "//& "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=OS%dt) + "default DT_THERM is set to DT.", & + units="s", default=OS%US%T_to_s*OS%dt, scale=OS%US%s_to_T) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -328,6 +334,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i else ; call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & trim(stagger)//" is invalid.") ; endif + call get_param(param_file, mdl, "EPS_OMESH",OS%eps_omesh, & + "Maximum allowable difference between ESMF mesh and "//& + "MOM6 domain coordinates in nuopc cap.", & + units="degrees", default=1.e-4) call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & "If true, the coupled driver will add a globally-balanced "//& "fresh-water flux that drives sea-surface salinity "//& @@ -354,7 +364,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%press_to_z = 1.0/(Rho0*G_Earth) - call get_param(param_file, mdl, "HFREEZE", HFrz, & + call get_param(param_file, mdl, "HFREEZE", HFrz, & "If HFREEZE > 0, melt potential will be computed. The actual depth "//& "over which melt potential is computed will be min(HFREEZE, OBLD), "//& "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& @@ -366,17 +376,21 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i use_melt_pot=.false. endif + call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & + "If true, enables surface wave modules.", default=.false.) + ! 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) call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & - OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) + OS%forcing_CSp, OS%restore_salinity, OS%restore_temp, OS%use_waves) if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + OS%diag, Time_init, OS%dirs%output_directory, OS%forces, OS%fluxes) endif if (OS%icebergs_alter_ocean) then call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) @@ -384,13 +398,14 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call allocate_forcing_type(OS%grid, OS%fluxes, shelf=.true.) endif - call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & - "If true, enables surface wave modules.", default=.false.) - if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) - else - call MOM_wave_interface_init_lite(param_file) + if (OS%Use_Waves) then + call get_param(param_file, mdl, "WAVE_METHOD", OS%wave_method, default="EMPTY", do_not_log=.true.) endif + call allocate_forcing_type(OS%grid, OS%fluxes, waves=.true., lamult=(trim(OS%wave_method)=="EFACTOR")) + + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) if (associated(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & @@ -409,15 +424,28 @@ 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) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + 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) +! get number of processors and PE list for stocasthci physics initialization + call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & + "If true, then stochastically perturb the thermodynamic "//& + "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, "PERT_EPBL", OS%pert_epbl, & + "If true, then stochastically perturb the kinetic energy "//& + "production and dissipation terms. Amplitude and correlations are "//& + "controlled by the nam_stoch namelist in the UFS model only.", & + default=.false.) + call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) if (is_root_pe()) & - write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + write(stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' call callTree_leave("ocean_model_init(") end subroutine ocean_model_init @@ -429,7 +457,7 @@ end subroutine ocean_model_init !! storing the new ocean properties in Ocean_state. subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & time_start_update, Ocean_coupling_time_step, & - update_dyn, update_thermo, Ocn_fluxes_used) + cesm_coupled, update_dyn, update_thermo, Ocn_fluxes_used) type(ice_ocean_boundary_type), & intent(in) :: Ice_ocean_boundary !< A structure containing the !! various forcing fields coming from the ice. @@ -444,6 +472,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over !! which to advance the ocean. + logical, intent(in) :: cesm_coupled !< Flag to check if coupled with cesm logical, optional, intent(in) :: update_dyn !< If present and false, do not do updates !! due to the ocean dynamics. logical, optional, intent(in) :: update_thermo !< If present and false, do not do updates @@ -459,13 +488,13 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & integer :: index_bnds(4) ! The computational domain index bounds in the ! ice-ocean boundary type. real :: weight ! Flux accumulation weight - real :: dt_coupling ! The coupling time step in seconds. + real :: dt_coupling ! The coupling time step in rescaled seconds [T ~> s]. integer :: nts ! The number of baroclinic dynamics time steps ! within dt_coupling. - real :: dt_therm ! A limited and quantized version of OS%dt_therm (sec) - real :: dt_dyn ! The dynamics time step in sec. - real :: dtdia ! The diabatic time step in sec. - real :: t_elapsed_seg ! The elapsed time in this update segment, in s. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s] + real :: dt_dyn ! The dynamics time step [T ~> s] + real :: dtdia ! The diabatic time step [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s] integer :: n, n_max, n_last_thermo type(time_type) :: Time2 ! A temporary time. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans @@ -476,9 +505,9 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & integer :: secs, days integer :: is, ie, js, je - call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") + call callTree_enter("update_ocean_model(), MOM_ocean_model_nuopc.F90") call get_time(Ocean_coupling_time_step, secs, days) - dt_coupling = 86400.0*real(days) + real(secs) + dt_coupling = OS%US%s_to_T*(86400.0*real(days) + real(secs)) if (time_start_update /= OS%Time) then call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& @@ -493,7 +522,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & do_dyn = .true. ; if (present(update_dyn)) do_dyn = update_dyn do_thermo = .true. ; if (present(update_thermo)) do_thermo = update_thermo - ! This is benign but not necessary if ocean_model_init_sfc was called or if ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec @@ -511,7 +539,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%fluxes%fluxes_used) then if (do_thermo) & - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, & OS%restore_salinity, OS%restore_temp) @@ -520,14 +548,14 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (do_thermo) & call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & - call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & - call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif @@ -535,34 +563,31 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid, skip_pres=.true.) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes #endif - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = dt_coupling else OS%flux_tmp%C_p = OS%fluxes%C_p if (do_thermo) & - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & - OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, dt_coupling, & + OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity, OS%restore_temp) if (OS%use_ice_shelf) then if (do_thermo) & call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & - call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & - call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif - call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, dt_coupling, OS%grid, weight) + call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, OS%grid, weight) ! Some of the fields that exist in both the forcing and mech_forcing types ! (e.g., ustar) are time-averages must be copied back to the forces type. call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) @@ -572,16 +597,23 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & #endif endif call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) - call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) + call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid, OS%US) if (OS%use_waves) then - call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) + if (OS%wave_method /= "EFACTOR") then + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves, OS%forces) + endif endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif + if (do_thermo) & + call call_tracer_set_forcing(OS%sfc_state, OS%fluxes, OS%Time, & + real_to_time_type(dt_coupling), OS%grid, OS%US, OS%GV%Rho0, & + OS%tracer_flow_CSp) + call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time @@ -643,7 +675,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) + Time2 = Time2 - set_time(int(floor(OS%US%T_to_s*(dtdia - dt_dyn) + 0.5))) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) @@ -651,35 +683,35 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time2 = Time1 + set_time(int(floor(OS%US%T_to_s*t_elapsed_seg + 0.5))) enddo endif OS%Time = Master_time + Ocean_coupling_time_step OS%nstep = OS%nstep + 1 - call enable_averaging(dt_coupling, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) if (OS%fluxes%fluxes_used) then - call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) - call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + if (cesm_coupled) then + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, & + OS%forcing_CSp%handles, enthalpy=.true.) + else + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) + endif endif ! 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) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) call coupler_type_send_data(Ocean_sfc%fields, OS%Time) call callTree_leave("update_ocean_model()") end subroutine update_ocean_model !> This subroutine writes out the ocean model restart file. -subroutine ocean_model_restart(OS, timestamp, restartname) +subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, num_rest_files) type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the !! internal ocean state being saved to a restart file character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be @@ -687,6 +719,10 @@ subroutine ocean_model_restart(OS, timestamp, restartname) character(len=*), optional, intent(in) :: restartname !< Name of restart file to use !! This option distinguishes the cesm interface from the !! non-cesm interface + character(len=*), optional, intent(in) :: stoch_restartname !< Name of restart file to use + !! This option distinguishes the cesm interface from the + !! non-cesm interface + integer, optional, intent(out) :: num_rest_files !< number of restart files written if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& @@ -697,33 +733,38 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) ! Is this needed? - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & - OS%dirs%restart_output_dir) - endif + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) ! Is this needed? + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & + OS%dirs%restart_output_dir) + endif else - if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) - endif - endif - if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - endif + if (BTEST(OS%Restart_control,1)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, time_stamped=.true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif + endif + if (present(stoch_restartname)) then + if (OS%do_sppt .OR. OS%pert_epbl) then + call write_stoch_restart_ocn('RESTART/'//trim(stoch_restartname)) + endif endif end subroutine ocean_model_restart @@ -740,7 +781,7 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time, write_restart) type(time_type), intent(in) :: Time !< The model time, used for writing restarts. logical, intent(in) :: write_restart !< true => write restart file - call ocean_model_save_restart(Ocean_state, Time) + if(write_restart)call ocean_model_save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) call MOM_end(Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) @@ -772,14 +813,13 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - end subroutine ocean_model_save_restart !> Initialize the public ocean type @@ -807,9 +847,9 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, call mpp_get_layout(input_domain,layout) call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) if (PRESENT(maskmap)) then - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) else - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) endif call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) @@ -846,7 +886,7 @@ end subroutine initialize_ocean_public_type !! code that calculates the surface state in the first place. !! Note the offset in the arrays because the ocean_data_type has no !! halo points in its arrays and always uses absolute indicies. -subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z) +subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_to_z) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(ocean_public_type), & @@ -854,6 +894,7 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z !! visible ocean surface fields, whose elements !! have their data set here. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: patm(:,:) !< The pressure at the ocean surface, in Pa. real, optional, intent(in) :: press_to_z !< A conversion factor between pressure and !! ocean depth in m, usually 1/(rho_0*g), in m Pa-1. @@ -878,73 +919,73 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z if (sfc_state%T_is_conT) then ! Convert the surface T from conservative T to potential T. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(sfc_state%SSS(i+i0,j+j0), & - sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0), & + US%C_to_degC*sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = US%C_to_degC*sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET enddo ; enddo endif if (sfc_state%S_is_absS) then ! Convert the surface S from absolute salinity to practical salinity. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(sfc_state%SSS(i+i0,j+j0)) + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0)) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = sfc_state%SSS(i+i0,j+j0) + Ocean_sfc%s_surf(i,j) = US%S_to_ppt*sfc_state%SSS(i+i0,j+j0) enddo ; enddo endif if (present(patm)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z - Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo endif - if (associated(sfc_state%frazil)) then + if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%melt_potential)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%melt_potential(i,j) = sfc_state%melt_potential(i+i0,j+j0) + Ocean_sfc%melt_potential(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%melt_potential(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%Hml)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%OBLD(i,j) = sfc_state%Hml(i+i0,j+j0) + Ocean_sfc%OBLD(i,j) = US%Z_to_m * sfc_state%Hml(i+i0,j+j0) enddo ; enddo endif if (Ocean_sfc%stagger == AGRID) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == BGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == CGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*sfc_state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*sfc_state%v(i+i0,J+j0) + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0) * US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0) * US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) enddo ; enddo else write(val_str, '(I8)') Ocean_sfc%stagger @@ -979,7 +1020,7 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) end subroutine ocean_model_init_sfc @@ -1006,6 +1047,33 @@ subroutine ocean_model_flux_init(OS, verbosity) end subroutine ocean_model_flux_init +!> This interface allows certain properties that are stored in the ocean_state_type to be +!! obtained. +subroutine query_ocean_state(OS, use_waves, NumWaveBands, Wavenumbers, unscale, wave_method) + type(ocean_state_type), intent(in) :: OS !< The structure with the complete ocean state + logical, optional, intent(out) :: use_waves !< Indicates whether surface waves are in use + integer, optional, intent(out) :: NumWaveBands !< If present, this gives the number of + !! wavenumber partitions in the wave discretization + real, dimension(:), optional, intent(out) :: Wavenumbers !< If present, this gives the characteristic + !! wavenumbers of the wave discretization [m-1 or Z-1 ~> m-1] + logical, optional, intent(in) :: unscale !< If present and true, undo any dimensional + !! rescaling and return dimensional values in MKS units + character(len=40), optional, intent(out) :: wave_method !< Wave coupling method. + + logical :: undo_scaling + undo_scaling = .false. ; if (present(unscale)) undo_scaling = unscale + + if (present(use_waves)) use_waves = OS%use_waves + if (present(NumWaveBands)) call query_wave_properties(OS%Waves, NumBands=NumWaveBands) + if (present(Wavenumbers) .and. undo_scaling) then + call query_wave_properties(OS%Waves, WaveNumbers=WaveNumbers, US=OS%US) + elseif (present(Wavenumbers)) then + call query_wave_properties(OS%Waves, WaveNumbers=WaveNumbers) + endif + if (present(wave_method)) wave_method = OS%wave_method + +end subroutine query_ocean_state + !> Ocean_stock_pe - returns the integrated stocks of heat, water, etc. for conservation checks. !! Because of the way FMS is coded, only the root PE has the integrated amount, !! while all other PEs get 0. @@ -1039,7 +1107,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on @@ -1048,120 +1116,28 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> This subroutine extracts a named 2-D field from the ocean surface or public type -subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) - use MOM_constants, only : CELSIUS_KELVIN_OFFSET - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain - integer , intent(in) :: isc !< The starting i-index of array2D - integer , intent(in) :: jsc !< The starting j-index of array2D - - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) - - g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - - - select case(name) - case('area') - array2D(isc:,jsc:) = OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) -!OR same result -! do j=g_jsc,g_jec ; do i=g_isc,g_iec -! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case('tlat') - array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) - case('tlon') - array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) - case('ulat') - array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) - case('ulon') - array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) - case('vlat') - array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) - case('vlon') - array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) - case('geoLatBu') - array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) - case('geoLonBu') - array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) - case('cos_rot') - array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 - case('sin_rot') - array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 - case default - call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) - end select - -end subroutine ocean_model_data2D_get - -!> This subroutine extracts a named scalar field from the ocean surface or public type -subroutine ocean_model_data1D_get(OS, Ocean, name, value) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - - select case(name) - case('c_p') - value = OS%C_p - case default - call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) - end select - -end subroutine ocean_model_data1D_get - -!> Write out FMS-format checsums on fields from the ocean surface state +!> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly !! visible ocean surface fields. - integer :: n, m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - write(outunit,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) - - call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + + root = is_root_pe() + + if (root) write(stdout,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(stdout,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(stdout,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(stdout,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(stdout,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(stdout,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(stdout,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(stdout,100) 'ocean%melt_potential ', chks + call coupler_type_write_chksums(ocn%fields, stdout, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) end subroutine ocean_public_type_chksum @@ -1175,4 +1151,10 @@ subroutine get_ocean_grid(OS, Gridp) return end subroutine get_ocean_grid -end module MOM_ocean_model +!> Returns eps_omesh read from param file +real function get_eps_omesh(OS) + type(ocean_state_type) :: OS + get_eps_omesh = OS%eps_omesh; return +end function + +end module MOM_ocean_model_nuopc diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 new file mode 100644 index 0000000000..e7d6c9abc6 --- /dev/null +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -0,0 +1,1550 @@ +!> Converts the input ESMF data (import data) to a MOM-specific data type (surface_forcing_CS). +module MOM_surface_forcing_nuopc + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : reproducing_sum, field_chksum +use MOM_constants, only : hlv, hlf +use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_spawn +use MOM_coupler_types, only : coupler_type_copy_data +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT +use MOM_data_override, only : data_override_init, data_override +use MOM_diag_mediator, only : diag_ctrl +use MOM_diag_mediator, only : safe_alloc_ptr, time_type +use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges +use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All +use MOM_domains, only : To_North, To_East, Omit_Corners +use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags +use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type +use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_interpolate, only : init_external_field, time_interp_external +use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field +use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : stdout +use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS +use MOM_restart, only : restart_init_end, save_restart, restore_state +use MOM_string_functions, only : uppercase +use MOM_spatial_means, only : adjust_area_mean_to_zero +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init +use user_revise_forcing, only : user_revise_forcing_CS +use iso_fortran_env, only : int64 + +implicit none ; private + +#include + +public convert_IOB_to_fluxes +public convert_IOB_to_forces +public surface_forcing_init +public forcing_save_restart +public ice_ocn_bnd_type_chksum + +private apply_flux_adjustments +private apply_force_adjustments +private surface_forcing_end + +!> Contains pointers to the forcing fields which may be used to drive MOM. +!! All fluxes are positive downward. +type, public :: surface_forcing_CS ; private + integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integer values + !! from MOM_domains) to indicate the staggering of + !! the winds that are being provided in calls to + !! update_ocean_model. + logical :: use_temperature !! If true, temp and saln used as state variables + real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress (nondim). + + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] + real :: area_surf = -1.0 !< total ocean surface area [m^2] + real :: latent_heat_fusion !< latent heat of fusion [J/kg] + real :: latent_heat_vapor !< latent heat of vaporization [J/kg] + + real :: max_p_surf !< maximum surface pressure that can be exerted by the + !! atmosphere and floating sea-ice [R L2 T-2 ~> Pa]. + !! This is needed because the FMS coupling + !! structure does not limit the water that can be + !! frozen out of the ocean and the ice-ocean heat + !! fluxes are treated explicitly. + logical :: use_limited_P_SSH !< If true, return the sea surface height with + !! the correction for the atmospheric (and sea-ice) + !! pressure limited by max_p_surf instead of the + !! full atmospheric pressure. The default is true. + logical :: use_CFC !< enables the MOM_CFC_cap tracer package. + logical :: enthalpy_cpl !< Controls if enthalpy terms are provided by the coupler or computed + !! internally. + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] + logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied + !! from an input file. + real, pointer, dimension(:,:) :: & + TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the + !! bottom boundary layer by drag on the tidal flows [R Z3 T-3 ~> W m-2] + gust => NULL(), & !< spatially varying unresolved background + !! gustiness that contributes to ustar [R L Z T-2 ~> Pa]. + !! gust is used when read_gust_2d is true. + ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] + real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) + real :: utide !< constant tidal velocity to use if read_tideamp + !! is false [Z T-1 ~> m s-1] + logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. + + logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts + !! to damp surface deflections (especially surface + !! gravity waves). The default is false. + real :: g_Earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< Typical density of sea-ice [R ~> kg m-3]. The value is + !! only used to convert the ice pressure into + !! appropriate units for use with Kv_sea_ice. + 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 :: liquid_runoff_from_data !< If true, use data_override to obtain liquid runoff + + real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] + logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux + logical :: adjust_net_srestore_to_zero !< adjust srestore to zero (for both salt_flux or vprec) + logical :: adjust_net_srestore_by_scaling !< adjust srestore w/o moving zero contour + logical :: adjust_net_fresh_water_to_zero !< adjust net surface fresh-water (w/ restoring) to zero + logical :: use_net_FW_adjustment_sign_bug !< use the wrong sign when adjusting net FW + logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour + logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil + !! criteria for salinity restoring. + real :: ice_salt_concentration !< salt concentration for sea ice [kg/kg] + logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas + real :: max_delta_srestore !< maximum delta salinity used for restoring [S ~> ppt] + real :: max_delta_trestore !< maximum delta sst used for restoring [C ~> degC] + real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring by basin + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the + !! gustless wind friction velocity. + + type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing + character(len=200) :: inputdir !< directory where NetCDF input files are + character(len=200) :: salt_restore_file !< filename for salt restoring data + character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file + logical :: mask_srestore !< if true, apply a 2-dimensional mask to the surface + !< salinity restoring fluxes. The masking file should be + !< in inputdir/salt_restore_mask.nc and the field should + !! be named 'mask' + real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring + character(len=200) :: temp_restore_file !< filename for sst restoring data + character(len=30) :: temp_restore_var_name !< name of surface temperature in temp_restore_file + logical :: mask_trestore !< if true, apply a 2-dimensional mask to the surface + !! temperature restoring fluxes. The masking file should be + !! in inputdir/temp_restore_mask.nc and the field should + !! be named 'mask' + real, pointer, dimension(:,:) :: trestore_mask => NULL() !< mask for SST restoring + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field + ! Diagnostics handles + type(forcing_diags), public :: handles + + type(MOM_restart_CS), pointer :: restart_CSp => NULL() + type(user_revise_forcing_CS), pointer :: urf_CS => NULL() +end type surface_forcing_CS + +!> Structure corresponding to forcing, but with the elements, units, and conventions +!! that exactly conform to the use for MOM-based coupled models. +type, public :: ice_ocean_boundary_type + real, pointer, dimension(:,:) :: lrunoff =>NULL() !< liquid runoff [kg/m2/s] + real, pointer, dimension(:,:) :: frunoff =>NULL() !< ice runoff [kg/m2/s] + real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress [Pa] + real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress [Pa] + real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W/m2] + real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux [kg/m2/s] + real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux [kg/m2/s] + real, pointer, dimension(:,:) :: seaice_melt_heat =>NULL() !< sea ice and snow melt heat flux [W/m2] + real, pointer, dimension(:,:) :: seaice_melt =>NULL() !< water flux due to sea ice and snow melting [kg/m2/s] + real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation [W/m2] + real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation [W/m2] + real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation [W/m2] + real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() !< direct Near InfraRed sw radiation [W/m2] + real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation [W/m2] + real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip [kg/m2/s] + real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip [kg/m2/s] + real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m/s] + real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs[m2/m2] + real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) + real, pointer, dimension(:,:) :: hrofl =>NULL() !< heat content from liquid runoff [W/m2] + real, pointer, dimension(:,:) :: hrofi =>NULL() !< heat content from frozen runoff [W/m2] + real, pointer, dimension(:,:) :: hrain =>NULL() !< heat content from liquid precipitation [W/m2] + real, pointer, dimension(:,:) :: hsnow =>NULL() !< heat content from frozen precipitation [W/m2] + real, pointer, dimension(:,:) :: hevap =>NULL() !< heat content from evaporation [W/m2] + real, pointer, dimension(:,:) :: hcond =>NULL() !< heat content from condensation [W/m2] + real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere + !< on ocean surface [Pa] + real, pointer, dimension(:,:) :: ice_fraction =>NULL() !< fractional ice area [nondim] + real, pointer, dimension(:,:) :: u10_sqr =>NULL() !< wind speed squared at 10m [m2/s2] + real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice [kg/m2] + real, pointer, dimension(:,:) :: ice_rigidity =>NULL() !< rigidity of the sea ice, sea-ice and + !! ice-shelves, expressed as a coefficient + !! for divergence damping, as determined + !! outside of the ocean model in [m3/s] + real, pointer, dimension(:,:) :: lamult => NULL() !< Langmuir enhancement factor [nondim] + real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad/m] + real, pointer, dimension(:,:,:) :: ustkb => NULL() !< Stokes Drift spectrum, zonal [m/s] + !! Horizontal - u points + !! 3rd dimension - wavenumber + real, pointer, dimension(:,:,:) :: vstkb => NULL() !< Stokes Drift spectrum, meridional [m/s] + !! Horizontal - v points + !! 3rd dimension - wavenumber + integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler + integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT + type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of + !! named fields used for passive tracer fluxes. + integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of + !! wind stresses. This flag may be set by the + !! flux-exchange code, based on what the sea-ice + !! model is providing. Otherwise, the value from + !! the surface_forcing_CS is used. +end type ice_ocean_boundary_type + +integer :: id_clock_forcing + +contains + +!> This subroutine translates the Ice_ocean_boundary_type into a MOM +!! thermodynamic forcing type, including changes of units, sign conventions, +!! and putting the fields into arrays with MOM-standard halos. +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, US, CS, & + sfc_state, restore_salt, restore_temp) + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to all + !! possible mass, heat or salt flux forcing fields. + !! Unused fields have NULL ptrs. + integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + real, intent(in) :: valid_time !< The amount of time over which these fluxes + !! should be applied [T ~> s]. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + type(surface), intent(in) :: sfc_state !< A structure containing fields that describe the + !! surface state of the ocean. + logical, optional, intent(in) :: restore_salt !< If true, salinity is restored to a target value. + logical, optional, intent(in) :: restore_temp !< If true, temperature is restored to a target value. + + ! local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + data_restore, & !< The surface value toward which to restore [S ~> ppt] or [C ~> degC] + PmE_adj, & !< The adjustment to PminusE that will cause the salinity + !! to be restored toward its target value [kg/(m^2 * s)] + net_FW, & !< The area integrated net freshwater flux into the ocean [kg/s] + net_FW2, & !< The area integrated net freshwater flux into the ocean [kg/s] + work_sum, & !< A 2-d array that is used as the work space for a global + !! sum, used with units of m2 or [kg/s] + open_ocn_mask !< a binary field indicating where ice is present based on frazil criteria + + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + logical :: restore_salinity !< local copy of the argument restore_salt, if it + !! is present, or false (no restoring) otherwise. + logical :: restore_sst !< local copy of the argument restore_temp, if it + !! is present, or false (no restoring) otherwise. + real :: delta_sss !< temporary storage for sss diff from restoring value [S ~> ppt] + real :: delta_sst !< temporary storage for sst diff from restoring value [C ~> degC] + real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling + !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. + + real :: C_p !< heat capacity of seawater [J kg-1 degC-1] + real :: sign_for_net_FW_bug !< Should be +1. but an old bug can be recovered by using -1. + + call cpu_clock_begin(id_clock_forcing) + + isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) + jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + + kg_m2_s_conversion = US%kg_m2s_to_RZ_T + C_p = US%Q_to_J_kg*US%degC_to_C*fluxes%C_p + open_ocn_mask(:,:) = 1.0 + pme_adj(:,:) = 0.0 + fluxes%vPrecGlobalAdj = 0.0 + fluxes%vPrecGlobalScl = 0.0 + fluxes%saltFluxGlobalAdj = 0.0 + fluxes%saltFluxGlobalScl = 0.0 + fluxes%netFWGlobalAdj = 0.0 + fluxes%netFWGlobalScl = 0.0 + + restore_salinity = .false. + if (present(restore_salt)) restore_salinity = restore_salt + restore_sst = .false. + if (present(restore_temp)) restore_sst = restore_temp + + ! allocation and initialization if this is the first time that this + ! flux type has been used. + if (fluxes%dt_buoy_accum < 0) then + call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & + press=.true., fix_accum_bug=.not.CS%ustar_gustless_bug, & + cfc=CS%use_CFC, hevap=CS%enthalpy_cpl, tau_mag=.true.) + !call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_nir_dif,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) + if (CS%use_limited_P_SSH) then + fluxes%p_surf_SSH => fluxes%p_surf + else + fluxes%p_surf_SSH => fluxes%p_surf_full + endif + + call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) + + if (CS%allow_flux_adjustments) then + call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + endif + + do j=js-2,je+2 ; do i=is-2,ie+2 + fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) + fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) + enddo ; enddo + + if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + + endif ! endif for allocation and initialization + + if (((associated(IOB%ustar_berg) .and. (.not.associated(fluxes%ustar_berg))) & + .or. (associated(IOB%area_berg) .and. (.not.associated(fluxes%area_berg)))) & + .or. (associated(IOB%mass_berg) .and. (.not.associated(fluxes%mass_berg)))) & + call allocate_forcing_type(G, fluxes, iceberg=.true.) + + if ((.not.coupler_type_initialized(fluxes%tr_fluxes)) .and. & + coupler_type_initialized(IOB%fluxes)) & + call coupler_type_spawn(IOB%fluxes, fluxes%tr_fluxes, & + (/is,is,ie,ie/), (/js,js,je,je/)) + ! It might prove valuable to use the same array extents as the rest of the + ! ocean model, rather than using haloless arrays, in which case the last line + ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) + + ! allocation and initialization on first call to this routine + if (CS%area_surf < 0.0) then + do j=js,je ; do i=is,ie + work_sum(i,j) = US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) + enddo ; enddo + CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) + endif ! endif for allocation and initialization + + + ! Indicate that there are new unused fluxes. + fluxes%fluxes_used = .false. + fluxes%dt_buoy_accum = valid_time + + if (CS%allow_flux_adjustments) then + fluxes%heat_added(:,:)=0.0 + fluxes%salt_flux_added(:,:)=0.0 + endif + + do j=js,je ; do i=is,ie + fluxes%salt_flux(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 + enddo ; enddo + + ! Salinity restoring logic + if (restore_salinity) then + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) + ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) + open_ocn_mask(:,:) = 1.0 + if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice + do j=js,je ; do i=is,ie + if (sfc_state%SST(i,j) <= -0.0539*US%degC_to_C*US%S_to_ppt*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + enddo ; enddo + endif + if (CS%salt_restore_as_sflux) then + do j=js,je ; do i=is,ie + delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) + delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 + enddo ; enddo + if (CS%adjust_net_srestore_to_zero) then + if (CS%adjust_net_srestore_by_scaling) then + call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & + unit_scale=US%RZ_T_to_kg_m2s) + fluxes%saltFluxGlobalAdj = 0. + else + work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & + G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj + endif + endif + fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic + else + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.0) then + delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) + delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & + (CS%Rho0*CS%Flux_const) * & + delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) + endif + enddo ; enddo + if (CS%adjust_net_srestore_to_zero) then + if (CS%adjust_net_srestore_by_scaling) then + call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & + unit_scale=US%RZ_T_to_kg_m2s) + fluxes%vPrecGlobalAdj = 0. + else + work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & + US%RZ_T_to_kg_m2s*fluxes%vprec(is:ie,js:je) + fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf + do j=js,je ; do i=is,ie + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + enddo ; enddo + endif + endif + endif + endif + + ! SST restoring logic + if (restore_sst) then + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) + do j=js,je ; do i=is,ie + delta_sst = data_restore(i,j) - sfc_state%SST(i,j) + delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) + fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & + (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! Q R Z T-1 ~> W m-2 + enddo ; enddo + endif + + + ! Check that liquid runoff has a place to go + if (CS%liquid_runoff_from_data .and. .not. associated(IOB%lrunoff)) then + call MOM_error(FATAL, "liquid runoff is being added via data_override but "// & + "there is no associated runoff in the IOB") + return + endif + if (associated(IOB%lrunoff)) then + if (CS%liquid_runoff_from_data) call data_override('OCN', 'runoff', IOB%lrunoff, Time) + endif + + ! obtain fluxes from IOB; note the staggering of indices + i0 = is - isc_bnd ; j0 = js - jsc_bnd + do j=js,je ; do i=is,ie + + if (associated(IOB%lprec)) & + fluxes%lprec(i,j) = kg_m2_s_conversion * IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%fprec)) & + fluxes%fprec(i,j) = kg_m2_s_conversion * IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%q_flux)) & + fluxes%evap(i,j) = kg_m2_s_conversion * IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) + + ! liquid runoff flux + if (associated(IOB%lrunoff)) then + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%lrunoff(i-i0,j-j0) * G%mask2dT(i,j) + endif + + ! ice runoff flux + if (associated(IOB%frunoff)) then + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%frunoff(i-i0,j-j0) * G%mask2dT(i,j) + endif + + if (associated(IOB%ustar_berg)) & + fluxes%ustar_berg(i,j) = US%m_to_Z*US%T_to_s * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%area_berg)) & + fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%mass_berg)) & + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%lw_flux)) & + fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%t_flux)) & + fluxes%sens(i,j) = US%W_m2_to_QRZ_T * IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) + + ! sea ice and snow melt heat flux [Q R Z T-1 ~> W/m2] + if (associated(IOB%seaice_melt_heat)) & + fluxes%seaice_melt_heat(i,j) = US%W_m2_to_QRZ_T * G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) + + ! water flux due to sea ice and snow melt [kg/m2/s] + if (associated(IOB%seaice_melt)) & + fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) + + fluxes%latent(i,j) = 0.0 + ! notice minus sign since fprec is positive into the ocean + if (associated(IOB%fprec)) then + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + endif + ! notice minus sign since frunoff is positive into the ocean + if (associated(IOB%frunoff)) then + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & + IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + endif + if (associated(IOB%q_flux)) then + fluxes%latent(i,j) = fluxes%latent(i,j) + & + IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + endif + fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) + + if (associated(IOB%sw_flux_vis_dir)) & + fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_vis_dir(i-i0,j-j0) + + if (associated(IOB%sw_flux_vis_dif)) & + fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_vis_dif(i-i0,j-j0) + + if (associated(IOB%sw_flux_nir_dir)) & + fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_nir_dir(i-i0,j-j0) + + if (associated(IOB%sw_flux_nir_dif)) & + fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_nir_dif(i-i0,j-j0) + + fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & + fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) + + ! enthalpy terms + if (CS%enthalpy_cpl) then + if (associated(IOB%hrofl)) & + fluxes%heat_content_lrunoff(i,j) = US%W_m2_to_QRZ_T * IOB%hrofl(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hrofi)) & + fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * IOB%hrofi(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hrain)) & + fluxes%heat_content_lprec(i,j) = US%W_m2_to_QRZ_T * IOB%hrain(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hsnow)) & + fluxes%heat_content_fprec(i,j) = US%W_m2_to_QRZ_T * IOB%hsnow(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hevap)) & + fluxes%heat_content_evap(i,j) = US%W_m2_to_QRZ_T * IOB%hevap(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hcond)) & + fluxes%heat_content_cond(i,j) = US%W_m2_to_QRZ_T * IOB%hcond(i-i0,j-j0) * G%mask2dT(i,j) + endif + + ! sea ice fraction [nondim] + if (associated(IOB%ice_fraction) .and. associated(fluxes%ice_fraction)) & + fluxes%ice_fraction(i,j) = G%mask2dT(i,j) * IOB%ice_fraction(i-i0,j-j0) + ! 10-m wind speed squared [m2/s2] + if (associated(IOB%u10_sqr) .and. associated(fluxes%u10_sqr)) & + fluxes%u10_sqr(i,j) = US%m_to_L**2 * US%T_to_s**2 * G%mask2dT(i,j) * IOB%u10_sqr(i-i0,j-j0) + + enddo ; enddo + + ! wave to ocean coupling + if ( associated(IOB%lamult)) then + 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 + fluxes%lamult(i,j) = 1.0 + endif + enddo ; enddo + call pass_var(fluxes%lamult, G%domain, halo=1 ) + endif + + ! applied surface pressure from atmosphere and cryosphere + if (associated(IOB%p)) then + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + endif + + if (associated(IOB%salt_flux)) then + do j=js,je ; do i=is,ie + fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0)) + fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0) ) + enddo ; enddo + endif + + ! adjust the NET fresh-water flux to zero, if flagged + if (CS%adjust_net_fresh_water_to_zero) then + sign_for_net_FW_bug = 1. + if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. + do j=js,je ; do i=is,ie + net_FW(i,j) = US%RZ_T_to_kg_m2s * & + (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & + (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) + net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) + enddo ; enddo + + if (CS%adjust_net_fresh_water_by_scaling) then + call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) + do j=js,je ; do i=is,ie + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * & + (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) + enddo ; enddo + else + fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf + do j=js,je ; do i=is,ie + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + enddo ; enddo + endif + + endif + + if (coupler_type_initialized(fluxes%tr_fluxes) .and. & + coupler_type_initialized(IOB%fluxes)) & + call coupler_type_copy_data(IOB%fluxes, fluxes%tr_fluxes) + + if (CS%allow_flux_adjustments) then + ! Apply adjustments to fluxes + call apply_flux_adjustments(G, US, CS, Time, fluxes) + endif + + ! Allow for user-written code to alter fluxes after all the above + call user_alter_forcing(sfc_state, fluxes, Time, G, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) + +end subroutine convert_IOB_to_fluxes + +!> This subroutine translates the Ice_ocean_boundary_type into a MOM +!! mechanical forcing type, including changes of units, sign conventions, +!! and putting the fields into arrays with MOM-standard halos. +subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + + ! local variables + real, dimension(SZIB_(G),SZJB_(G)) :: & + taux_at_q, & !< Zonal wind stresses at q points [R Z L T-2 ~> Pa] + tauy_at_q !< Meridional wind stresses at q points [R Z L T-2 ~> Pa] + + real, dimension(SZI_(G),SZJ_(G)) :: & + rigidity_at_h, & !< Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] + taux_at_h, & !< Zonal wind stresses at h points [R Z L T-2 ~> Pa] + tauy_at_h !< Meridional wind stresses at h points [R Z L T-2 ~> Pa] + + real :: gustiness !< unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] + real :: Irho0 !< inverse of the mean density in [Z L-1 R-1 ~> m3 kg-1] + real :: taux2, tauy2 !< squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] + real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] + real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] + real :: I_GEarth !< The inverse of the gravitational acceleration [T2 Z L-2 ~> s2 m-1] + real :: Kv_rho_ice !< (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice !< mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff !< effective mass of sea ice for rigidity [R Z ~> kg m-2] + + integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0, istk + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + call cpu_clock_begin(id_clock_forcing) + + isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) + jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + i0 = is - isc_bnd ; j0 = js - jsc_bnd + + Irho0 = US%L_to_Z / CS%Rho0 + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + stress_conversion = Pa_conversion * CS%wind_stress_multiplier + + ! allocation and initialization if this is the first time that this + ! mechanical forcing type has been used. + if (.not.forces%initialized) then + + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) + + call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) + call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) + !call safe_alloc_ptr(forces%omega_w2x,isd,ied,jsd,jed) + + if (CS%rigid_sea_ice) then + call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) + call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) + endif + + forces%initialized = .true. + endif + + if ( (associated(IOB%area_berg) .and. (.not. associated(forces%area_berg))) .or. & + (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & + call allocate_mech_forcing(G, forces, iceberg=.true.) + + if (associated(IOB%ice_rigidity)) then + rigidity_at_h(:,:) = 0.0 + call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) + call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) + endif + + forces%accumulate_rigidity = .true. ! Multiple components may contribute to rigidity. + if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 + if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 + + if ( associated(IOB%lamult) ) then + call allocate_mech_forcing(G, forces, waves=.true., num_stk_bands=0) + elseif ( associated(IOB%ustkb) ) then + call allocate_mech_forcing(G, forces, waves=.true., num_stk_bands=IOB%num_stk_bands) + endif + + ! applied surface pressure from atmosphere and cryosphere + if (CS%use_limited_P_SSH) then + forces%p_surf_SSH => forces%p_surf + else + forces%p_surf_SSH => forces%p_surf_full + endif + if (associated(IOB%p)) then + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + forces%p_surf(i,j) = forces%p_surf_full(i,j) + enddo ; enddo + endif + else + do j=js,je ; do i=is,ie + forces%p_surf_full(i,j) = 0.0 + forces%p_surf(i,j) = 0.0 + enddo ; enddo + endif + forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + +#ifdef CESMCOUPLED + wind_stagger = AGRID +#else + wind_stagger = CS%wind_stagger +#endif + + if (wind_stagger == BGRID_NE) then + ! This is necessary to fill in the halo points. + taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 + endif + if (wind_stagger == AGRID) then + ! This is necessary to fill in the halo points. + taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 + endif + + ! obtain fluxes from IOB; note the staggering of indices + do j=js,je ; do i=is,ie + if (associated(IOB%area_berg)) & + forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%mass_berg)) & + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%ice_rigidity)) & + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + + if (wind_stagger == BGRID_NE) then + if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion + elseif (wind_stagger == AGRID) then + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * stress_conversion + else ! C-grid wind stresses. + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion + endif + + enddo ; enddo + + ! surface momentum stress related fields as function of staggering + if (wind_stagger == BGRID_NE) then + if (G%symmetric) & + call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) + call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE, halo=1) + + do j=js,je ; do I=Isq,Ieq + forces%taux(I,j) = 0.0 + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & + forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & + G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & + (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) + enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie + forces%tauy(i,J) = 0.0 + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & + forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & + G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & + (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) + enddo ; enddo + + ! ustar is required for the bulk mixed layer formulation. The background value + ! of 0.02 Pa is a relatively small value intended to give reasonable behavior + ! in regions of very weak winds. + + do j=js,je ; do i=is,ie + tau_mag = 0.0 ; gustiness = CS%gust_const + if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then + tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & + G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & + (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & + G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) + if (CS%read_gust_2d) gustiness = CS%gust(i,j) + endif + forces%tau_mag(i,j) = gustiness + tau_mag + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) + enddo ; enddo + call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) + elseif (wind_stagger == AGRID) then + call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) + + do j=js,je ; do I=Isq,Ieq + forces%taux(I,j) = 0.0 + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & + forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & + G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & + (G%mask2dT(i,j) + G%mask2dT(i+1,j)) + enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie + forces%tauy(i,J) = 0.0 + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & + forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & + G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & + (G%mask2dT(i,j) + G%mask2dT(i,j+1)) + enddo ; enddo + + do j=js,je ; do i=is,ie + gustiness = CS%gust_const + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) + forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2) + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & + sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) + !forces%omega_w2x(i,j) = atan(tauy_at_h(i,j), taux_at_h(i,j)) + enddo ; enddo + call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) + else ! C-grid wind stresses. + if (G%symmetric) & + call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) + call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) + + do j=js,je ; do i=is,ie + taux2 = 0.0 + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & + taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & + G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) + + tauy2 = 0.0 + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & + tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & + G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) + + if (CS%read_gust_2d) then + forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2) + forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) + else + forces%tau_mag(i,j) = CS%gust_const + sqrt(taux2 + tauy2) + forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) + endif + enddo ; enddo + + endif ! endif for wind related fields + + ! wave to ocean coupling + if ( associated(IOB%ustkb) ) then + + forces%stk_wavenumbers(:) = IOB%stk_wavenumbers * US%Z_to_m + do istk = 1,IOB%num_stk_bands + do j=js,je; do i=is,ie + forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) * US%m_s_to_L_T + forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) * US%m_s_to_L_T + enddo; enddo + call pass_var(forces%ustkb(:,:,istk), G%domain ) + call pass_var(forces%vstkb(:,:,istk), G%domain ) + enddo + endif + + ! sea ice related dynamic fields + if (associated(IOB%ice_rigidity)) then + call pass_var(rigidity_at_h, G%Domain, halo=1) + do I=is-1,ie ; do j=js,je + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & + min(rigidity_at_h(i,j), rigidity_at_h(i+1,j)) + enddo ; enddo + do i=is,ie ; do J=js-1,je + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + & + min(rigidity_at_h(i,j), rigidity_at_h(i,j+1)) + enddo ; enddo + endif + + if (CS%rigid_sea_ice) then + call pass_var(forces%p_surf_full, G%Domain, halo=1) + I_GEarth = 1.0 / CS%g_Earth + Kv_rho_ice = (CS%Kv_sea_ice / CS%density_sea_ice) + do I=is-1,ie ; do j=js,je + mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth + mass_eff = 0.0 + if (mass_ice > CS%rigid_sea_ice_mass) then + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) + endif + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff + enddo ; enddo + do i=is,ie ; do J=js-1,je + mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth + mass_eff = 0.0 + if (mass_ice > CS%rigid_sea_ice_mass) then + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) + endif + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff + enddo ; enddo + endif + + if (CS%allow_flux_adjustments) then + ! Apply adjustments to forces + call apply_force_adjustments(G, US, CS, Time, forces) + endif + +!### ! Allow for user-written code to alter fluxes after all the above +!### call user_alter_mech_forcing(forces, Time, G, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) +end subroutine convert_IOB_to_forces + +!> Adds thermodynamic flux adjustments obtained via data_override +!! Component name is 'OCN' +!! Available adjustments are: +!! - hflx_adj (Heat flux into the ocean, in W m-2) +!! - sflx_adj (Salt flux into the ocean, in kg salt m-2 s-1) +!! - prcme_adj (Fresh water flux into the ocean, in kg m-2 s-1) +subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure + type(time_type), intent(in) :: Time !< Model time structure + type(forcing), intent(inout) :: fluxes !< Surface fluxes structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h !< Fluxes at h points [W m-2 or kg m-2 s-1] + + integer :: isc, iec, jsc, jec, i, j + logical :: overrode_h + + 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) + + if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + US%W_m2_to_QRZ_T*temp_at_h(i,j)* G%mask2dT(i,j) + enddo ; enddo ; endif + ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) + + overrode_h = .false. + call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + + if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + & + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) + enddo ; enddo ; endif + ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) + + overrode_h = .false. + call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + + if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) + enddo ; enddo ; endif + ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) +end subroutine apply_flux_adjustments + +!> Adds mechanical forcing adjustments obtained via data_override +!! Component name is 'OCN' +!! Available adjustments are: +!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) +!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) +subroutine apply_force_adjustments(G, US, CS, Time, forces) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure + type(time_type), intent(in) :: Time !< Model time structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h !< Delta to zonal wind stress at h points [R Z L T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h !< Delta to meridional wind stress at h points [R Z L T-2 ~> Pa] + + integer :: isc, iec, jsc, jec, i, j + real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] + logical :: overrode_x, overrode_y + + isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + + tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 + ! Either reads data or leaves contents unchanged + overrode_x = .false. ; overrode_y = .false. + call data_override('OCN', 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x) + call data_override('OCN', 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y) + + if (overrode_x .or. overrode_y) then + if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& + "Both taux_adj and tauy_adj must be specified, or neither, in data_table") + + ! Rotate winds + call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID, halo=1) + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 + dLonDx = G%geoLonCu(I,j) - G%geoLonCu(I-1,j) + dLonDy = G%geoLonCv(i,J) - G%geoLonCv(i,J-1) + rDlon = sqrt( dLonDx * dLonDx + dLonDy * dLonDy ) + if (rDlon > 0.) rDlon = 1. / rDlon + cosA = dLonDx * rDlon + sinA = dLonDy * rDlon + zonal_tau = Pa_conversion * tempx_at_h(i,j) + merid_tau = Pa_conversion * tempy_at_h(i,j) + tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau + tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau + enddo ; enddo + + ! Average to C-grid locations + do j=jsc,jec ; do I=isc-1,iec + forces%taux(I,j) = forces%taux(I,j) + 0.5 * ( tempx_at_h(i,j) + tempx_at_h(i+1,j) ) + enddo ; enddo + + do J=jsc-1,jec ; do i=isc,iec + forces%tauy(i,J) = forces%tauy(i,J) + 0.5 * ( tempy_at_h(i,j) + tempy_at_h(i,j+1) ) + enddo ; enddo + endif ! overrode_x .or. overrode_y + +end subroutine apply_force_adjustments + +!> Save any restart files associated with the surface forcing. +subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & + filename_suffix) + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to surface_forcing_init + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(time_type), intent(in) :: Time !< The current model time + character(len=*), intent(in) :: directory !< The directory into which to write the + !! restart files + logical, optional, intent(in) :: time_stamped !< If true, the restart file names include + !! a unique time stamp. The default is false. + character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time- + !! stamp) to append to the restart file names. + + if (.not.associated(CS)) return + if (.not.associated(CS%restart_CSp)) return + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) + +end subroutine forcing_save_restart + +!> Initialize the surface forcing, including setting parameters and allocating permanent memory. +subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, restore_temp, use_waves) + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate + !! diagnostic output + type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + logical, optional, intent(in) :: restore_salt !< If present and true surface salinity + !! restoring will be applied in this model. + logical, optional, intent(in) :: restore_temp !< If present and true surface temperature + !! restoring will be applied in this model. + logical, optional, intent(in) :: use_waves !< If present and true, use waves and activate + !! the corresponding wave forcing diagnostics + + ! Local variables + real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. + type(directories) :: dirs + logical :: new_sim, iceberg_flux_diags, fix_ustar_gustless_bug + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. + type(time_type) :: Time_frc + character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_surface_forcing_nuopc" ! This module's name. + character(len=48) :: stagger + character(len=48) :: flnam + character(len=240) :: basin_file + integer :: i, j, isd, ied, jsd, jed + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (associated(CS)) then + call MOM_error(WARNING, "surface_forcing_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + id_clock_forcing=cpu_clock_id('Ocean surface forcing', grain=CLOCK_SUBCOMPONENT) + call cpu_clock_begin(id_clock_forcing) + + CS%diag => diag + + call write_version_number(version) + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & + "The directory in which all input files are found.", & + default=".") + CS%inputdir = slasher(CS%inputdir) + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & + "If true, Temperature and salinity are used as state "//& + "variables.", default=.true.) + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf) + call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & + "The latent heat of fusion.", units="J/kg", default=hlv) + call get_param(param_file, mdl, "MAX_P_SURF", CS%max_p_surf, & + "The maximum surface pressure that can be exerted by the "//& + "atmosphere and floating sea-ice or ice shelves. This is "//& + "needed because the FMS coupling structure does not "//& + "limit the water that can be frozen out of the ocean and "//& + "the ice-ocean heat fluxes are treated explicitly. No "//& + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & + CS%adjust_net_srestore_to_zero, & + "If true, adjusts the salinity restoring seen to zero "//& + "whether restoring is via a salt flux or virtual precip.",& + default=restore_salt) + call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_BY_SCALING", & + CS%adjust_net_srestore_by_scaling, & + "If true, adjustments to salt restoring to achieve zero net are "//& + "made by scaling values without moving the zero contour.",& + default=.false.) + call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_TO_ZERO", & + CS%adjust_net_fresh_water_to_zero, & + "If true, adjusts the net fresh-water forcing seen "//& + "by the ocean (including restoring) to zero.", default=.false.) + if (CS%adjust_net_fresh_water_to_zero) & + call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & + CS%use_net_FW_adjustment_sign_bug, & + "If true, use the wrong sign for the adjustment to "//& + "the net fresh-water.", default=.false.) + call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & + CS%adjust_net_fresh_water_by_scaling, & + "If true, adjustments to net fresh water to achieve zero net are "//& + "made by scaling values without moving the zero contour.",& + default=.false.) + call get_param(param_file, mdl, "ICE_SALT_CONCENTRATION", & + CS%ice_salt_concentration, & + "The assumed sea-ice salinity needed to reverse engineer the "//& + "melt flux (or ice-ocean fresh-water flux).", & + units="kg/kg", default=0.005) + call get_param(param_file, mdl, "USE_LIMITED_PATM_SSH", CS%use_limited_P_SSH, & + "If true, return the sea surface height with the "//& + "correction for the atmospheric (and sea-ice) pressure "//& + "limited by max_p_surf instead of the full atmospheric "//& + "pressure.", default=.true.) + + call get_param(param_file, mdl, "WIND_STAGGER", 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 + 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 = "// & + trim(stagger)//" is invalid.") ; endif + call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & + "A factor multiplying the wind-stress given to the ocean by the "//& + "coupler. This is used for testing and should be =1.0 for any "//& + "production runs.", units="nondim", default=1.0) + + call get_param(param_file, mdl, "USE_CFC_CAP", CS%use_CFC, & + default=.false., do_not_log=.true.) + + call get_param(param_file, mdl, "ENTHALPY_FROM_COUPLER", CS%enthalpy_cpl, & + "If True, the heat (enthalpy) associated with mass entering/leaving the "//& + "ocean is provided via coupler.", default=.false.) + + if (restore_salt) then + call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) + call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & + "A file in which to find the surface salinity to use for restoring.", & + default="salt_restore.nc") + call get_param(param_file, mdl, "SALT_RESTORE_VARIABLE", CS%salt_restore_var_name, & + "The name of the surface salinity variable to read from "//& + "SALT_RESTORE_FILE for restoring salinity.", & + default="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, "MASK_SRESTORE_UNDER_ICE", & + CS%mask_srestore_under_ice, & + "If true, disables SSS restoring under sea-ice based on a frazil "//& + "criteria (SST<=Tf). Only used when RESTORE_SALINITY is True.", & + default=.false.) + call get_param(param_file, mdl, "MASK_SRESTORE_MARGINAL_SEAS", & + CS%mask_srestore_marginal_seas, & + "If true, disable SSS restoring in marginal seas. Only used when "//& + "RESTORE_SALINITY is True.", default=.false.) + call get_param(param_file, mdl, "BASIN_FILE", basin_file, & + "A file in which to find the basin masks, in variable 'basin'.", & + default="basin.nc") + basin_file = trim(CS%inputdir) // trim(basin_file) + call safe_alloc_ptr(CS%basin_mask,isd,ied,jsd,jed) ; CS%basin_mask(:,:) = 1.0 + if (CS%mask_srestore_marginal_seas) then + call MOM_read_data(basin_file,'basin',CS%basin_mask,G%domain, timelevel=1) + do j=jsd,jed ; do i=isd,ied + if (CS%basin_mask(i,j) >= 6.0) then ; CS%basin_mask(i,j) = 0.0 + else ; CS%basin_mask(i,j) = 1.0 ; endif + enddo ; enddo + endif + call get_param(param_file, mdl, "MASK_SRESTORE", CS%mask_srestore, & + "If true, read a file (salt_restore_mask) containing "//& + "a mask for SSS restoring.", default=.false.) + endif + + if (restore_temp) then + call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) + call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & + "A file in which to find the surface temperature to use for restoring.", & + default="temp_restore.nc") + call get_param(param_file, mdl, "SST_RESTORE_VARIABLE", CS%temp_restore_var_name, & + "The name of the surface temperature variable to read from "//& + "SST_RESTORE_FILE for restoring sst.", & + default="temp") + + call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & + "The maximum sst difference used in restoring terms.", & + units="degC ", default=999.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & + "If true, read a file (temp_restore_mask) containing "//& + "a mask for SST restoring.", default=.false.) + + endif + +! Optionally read tidal amplitude from input file (m s-1) on model grid. +! Otherwise use default tidal amplitude for bottom frictionally-generated +! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of +! work done against tides globally using OSU tidal amplitude. + call get_param(param_file, mdl, "CD_TIDES", CS%cd_tides, & + "The drag coefficient that applies to the tides.", & + units="nondim", default=1.0e-4) + call get_param(param_file, mdl, "READ_TIDEAMP", CS%read_TIDEAMP, & + "If true, read a file (given by TIDEAMP_FILE) containing "//& + "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) + if (CS%read_TIDEAMP) then + call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & + "The path to the file containing the spatially varying "//& + "tidal amplitudes with INT_TIDE_DISSIPATION.", & + default="tideamp.nc") + CS%utide=0.0 + else + call get_param(param_file, mdl, "UTIDE", CS%utide, & + "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) + endif + + call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) + + if (CS%read_TIDEAMP) then + TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) + call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) + do j=jsd, jed; do i=isd, ied + utide = CS%TKE_tidal(i,j) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide + enddo ; enddo + else + do j=jsd,jed; do i=isd,ied + utide = CS%utide + CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide + enddo ; enddo + endif + + ! initialize time interpolator module + call time_interp_external_init() + +! Optionally read a x-y gustiness field in place of a global +! constant. + + call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & + "If true, use a 2-dimensional gustiness supplied from "//& + "an input file", default=.false.) + call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + if (CS%read_gust_2d) then + call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & + "The file in which the wind gustiness is found in "//& + "variable gustiness.") + + call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) + gust_file = trim(CS%inputdir) // trim(gust_file) + call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa + endif + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & + "If true correct a bug in the time-averaging of the gustless wind friction velocity", & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) + +! See whether sufficiently thick sea ice should be treated as rigid. + call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & + "If true, sea-ice is rigid enough to exert a "//& + "nonhydrostatic pressure that resist vertical motion.", & + default=.false.) + if (CS%rigid_sea_ice) then + call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default = 9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) + call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & + "A typical density of sea ice, used with the kinematic "//& + "viscosity, when USE_RIGID_SEA_ICE is true.", & + units="kg m-3", default=900.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & + "The kinematic viscosity of sufficiently thick sea ice "//& + "for use in calculating the rigidity of sea ice.", & + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & + "The mass of sea-ice per unit area at which the sea-ice "//& + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) + endif + + 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 register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles, & + use_berg_fluxes=iceberg_flux_diags, use_waves=use_waves, use_cfcs=CS%use_CFC) + + call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & + "If true, allows flux adjustments to specified via the "//& + "data_table using the component name 'OCN'.", default=.false.) + + call get_param(param_file, mdl, "LIQUID_RUNOFF_FROM_DATA", CS%liquid_runoff_from_data, & + "If true, allows liquid river runoff to be specified via the "//& + "data_table using the component name 'OCN'.", default=.false.) + + if (CS%allow_flux_adjustments .or. CS%liquid_runoff_from_data) then + call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + endif + + 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 + 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) + endif + endif ; endif + + 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 + if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes + flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' + call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1) + endif + endif ; endif + + ! Set up any restart fields associated with the forcing. + call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") + call restart_init_end(CS%restart_CSp) + + if (associated(CS%restart_CSp)) then + call Get_MOM_Input(dirs=dirs) + + new_sim = .false. + if ((dirs%input_filename(1:1) == 'n') .and. & + (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. + if (.not.new_sim) then + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & + G, CS%restart_CSp) + endif + endif + + call user_revise_forcing_init(param_file, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) +end subroutine surface_forcing_init + +!> Clean up and deallocate any memory associated with this module and its children. +subroutine surface_forcing_end(CS, fluxes) + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by + !! a previous call to surface_forcing_init, it will + !! be deallocated here. + type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to all + !! possible mass, heat or salt flux forcing fields. + !! If present, it will be deallocated here. + + if (present(fluxes)) call deallocate_forcing_type(fluxes) + + if (associated(CS)) deallocate(CS) + CS => NULL() + +end subroutine surface_forcing_end + +!> Write out a set of messages with checksums of the fields in an ice_ocen_boundary type +subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) + + character(len=*), intent(in) :: id !< An identifying string for this call + integer, intent(in) :: timestep !< The number of elapsed timesteps + type(ice_ocean_boundary_type), & + intent(in) :: iobt !< An ice-ocean boundary type with fluxes to drive the + !! ocean in a coupled model whose checksums are reported + + ! Local variables + integer(kind=int64) :: chks ! A checksum for the field + logical :: root ! True only on the root PE + integer :: outunit ! The output unit to write to + + outunit = stdout + root = is_root_pe() + + if (root) write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + chks = field_chksum( iobt%u_flux ) ; if (root) write(outunit,100) 'iobt%u_flux ', chks + 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) ; 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 + chks = field_chksum( iobt%sw_flux_vis_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dir', chks + chks = field_chksum( iobt%sw_flux_vis_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_vis_dif', chks + chks = field_chksum( iobt%sw_flux_nir_dir) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dir', chks + chks = field_chksum( iobt%sw_flux_nir_dif) ; if (root) write(outunit,100) 'iobt%sw_flux_nir_dif', chks + chks = field_chksum( iobt%lprec ) ; if (root) write(outunit,100) 'iobt%lprec ', chks + chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks + chks = field_chksum( iobt%lrunoff ) ; if (root) write(outunit,100) 'iobt%lrunoff ', chks + chks = field_chksum( iobt%frunoff ) ; if (root) write(outunit,100) 'iobt%frunoff ', chks + chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%ice_fraction)) then + chks = field_chksum( iobt%ice_fraction ) ; if (root) write(outunit,100) 'iobt%ice_fraction ', chks + endif + if (associated(iobt%u10_sqr)) then + chks = field_chksum( iobt%u10_sqr ) ; if (root) write(outunit,100) 'iobt%u10_sqr ', chks + endif + if (associated(iobt%ustar_berg)) then + chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks + endif + if (associated(iobt%area_berg)) then + chks = field_chksum( iobt%area_berg ) ; if (root) write(outunit,100) 'iobt%area_berg ', chks + endif + if (associated(iobt%mass_berg)) then + chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks + endif + + ! enthalpy + if (associated(iobt%hrofl)) then + chks = field_chksum( iobt%hrofl ) ; if (root) write(outunit,100) 'iobt%hrofl ', chks + endif + if (associated(iobt%hrofi)) then + chks = field_chksum( iobt%hrofi ) ; if (root) write(outunit,100) 'iobt%hrofi ', chks + endif + if (associated(iobt%hrain)) then + chks = field_chksum( iobt%hrain ) ; if (root) write(outunit,100) 'iobt%hrain ', chks + endif + if (associated(iobt%hsnow)) then + chks = field_chksum( iobt%hsnow ) ; if (root) write(outunit,100) 'iobt%hsnow ', chks + endif + if (associated(iobt%hevap)) then + chks = field_chksum( iobt%hevap ) ; if (root) write(outunit,100) 'iobt%hevap ', chks + endif + if (associated(iobt%hcond)) then + chks = field_chksum( iobt%hcond ) ; if (root) write(outunit,100) 'iobt%hcond ', chks + endif + +100 FORMAT(" CHECKSUM::",A20," = ",Z20) + + call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') + +end subroutine ice_ocn_bnd_type_chksum + +end module MOM_surface_forcing_nuopc diff --git a/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 b/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 new file mode 100644 index 0000000000..6d25b9a1ae --- /dev/null +++ b/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 @@ -0,0 +1,3 @@ +module ocn_comp_NUOPC + use MOM_cap_mod +end module ocn_comp_NUOPC diff --git a/config_src/nuopc_driver/time_utils.F90 b/config_src/drivers/nuopc_cap/time_utils.F90 similarity index 93% rename from config_src/nuopc_driver/time_utils.F90 rename to config_src/drivers/nuopc_cap/time_utils.F90 index e995c1b697..81efcd2765 100644 --- a/config_src/nuopc_driver/time_utils.F90 +++ b/config_src/drivers/nuopc_cap/time_utils.F90 @@ -14,6 +14,7 @@ module time_utils_mod use ESMF, only: ESMF_Time, ESMF_TimeGet, ESMF_LogFoundError use ESMF, only: ESMF_LOGERR_PASSTHRU,ESMF_TimeInterval use ESMF, only: ESMF_TimeIntervalGet, ESMF_TimeSet, ESMF_SUCCESS +use MOM_cap_methods, only: ChkErr implicit none; private @@ -34,6 +35,9 @@ module time_utils_mod public fms2esmf_time public string_to_date +character(len=*),parameter :: u_FILE_u = & + __FILE__ + contains !> Sets fms2esmf_cal_c to the corresponding ESMF calendar type @@ -90,10 +94,7 @@ function esmf2fms_time_t(time) call ESMF_TimeGet(time, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, & calkindflag=calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return esmf2fms_time_t = set_date(yy, mm, dd, h, m, s) @@ -111,10 +112,7 @@ function esmf2fms_timestep(timestep) integer :: rc call ESMF_TimeIntervalGet(timestep, s=s, calkindflag=calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return esmf2fms_timestep = set_time(s, 0) @@ -142,10 +140,7 @@ function fms2esmf_time(time, calkind) call ESMF_TimeSet(fms2esmf_time, yy=yy, mm=mm, d=d, h=h, m=m, s=s, & calkindflag=l_calkind, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return end function fms2esmf_time diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 similarity index 83% rename from config_src/solo_driver/MESO_surface_forcing.F90 rename to config_src/drivers/solo_driver/MESO_surface_forcing.F90 index ee3cd36b41..f1f3daa52e 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -9,7 +9,7 @@ module MESO_surface_forcing use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : allocate_forcing_type use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_time_manager, only : time_type, operator(+), operator(/) @@ -27,18 +27,20 @@ module MESO_surface_forcing logical :: use_temperature !< If true, temperature and salinity are used as state variables. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. - real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. + real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [Pa]. + !! that contributes to ustar [R L Z T-2 ~> Pa] real, dimension(:,:), pointer :: & - T_Restore(:,:) => NULL(), & !< The temperature to restore the SST toward [degC]. - S_Restore(:,:) => NULL(), & !< The salinity to restore the sea surface salnity toward [ppt] - PmE(:,:) => NULL(), & !< The prescribed precip minus evap [m s-1]. - Solar(:,:) => NULL() !< The shortwave forcing into the ocean [W m-2]. + T_Restore(:,:) => NULL(), & !< The temperature to restore the SST toward [C ~> degC]. + S_Restore(:,:) => NULL(), & !< The salinity to restore the sea surface salnity toward [S ~> ppt] + PmE(:,:) => NULL(), & !< The prescribed precip minus evap [Z T-1 ~> m s-1]. + Solar(:,:) => NULL() !< The shortwave forcing into the ocean [Q R Z T-1 ~> W m-2]. real, dimension(:,:), pointer :: Heat(:,:) => NULL() !< The prescribed longwave, latent and sensible - !! heat flux into the ocean [W m-2]. + !! heat flux into the ocean [Q R Z T-1 ~> W m-2]. character(len=200) :: inputdir !< The directory where NetCDF input files are. character(len=200) :: salinityrestore_file !< The file with the target sea surface salinity character(len=200) :: SSTrestore_file !< The file with the target sea surface temperature @@ -61,7 +63,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] + !! the fluxes apply [T ~> s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by @@ -77,13 +79,10 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] - real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. + real :: density_restore ! The potential density that is being restored toward [R ~> kg m-3]. + real :: rhoXcp ! The mean density times the heat capacity [Q R C-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. + ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -123,15 +122,15 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call safe_alloc_ptr(CS%Solar, isd, ied, jsd, jed) call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "SST", & - CS%T_Restore(:,:), G%Domain) + CS%T_Restore(:,:), G%Domain, scale=US%degC_to_C) call MOM_read_data(trim(CS%inputdir)//trim(CS%salinityrestore_file), "SAL", & - CS%S_Restore(:,:), G%Domain) + CS%S_Restore(:,:), G%Domain, scale=US%ppt_to_S) call MOM_read_data(trim(CS%inputdir)//trim(CS%heating_file), "Heat", & - CS%Heat(:,:), G%Domain) + CS%Heat(:,:), G%Domain, scale=US%W_m2_to_QRZ_T) call MOM_read_data(trim(CS%inputdir)//trim(CS%PmE_file), "PmE", & - CS%PmE(:,:), G%Domain) + CS%PmE(:,:), G%Domain, scale=US%m_to_Z*US%T_to_s) call MOM_read_data(trim(CS%inputdir)//trim(CS%Solar_file), "NET_SOL", & - CS%Solar(:,:), G%Domain) + CS%Solar(:,:), G%Domain, scale=US%W_m2_to_QRZ_T) first_call = .false. endif @@ -139,19 +138,19 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! Set whichever fluxes are to be used here. Any fluxes that ! are always zero do not need to be changed here. do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] + ! Fluxes of fresh water through the surface are in units of [R Z T-1 ~> kg m-2 s-1] ! and are positive downward - i.e. evaporation should be negative. fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) - fluxes%lprec(i,j) = CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) ! vprec will be set later, if it is needed for salinity restoring. fluxes%vprec(i,j) = 0.0 - ! Heat fluxes are in units of [W m-2] and are positive into the ocean. - fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sens(i,j) = CS%Heat(i,j) * G%mask2dT(i,j) - fluxes%sw(i,j) = CS%Solar(i,j) * G%mask2dT(i,j) + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. + fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%sens(i,j) = CS%Heat(i,j) * G%mask2dT(i,j) + fluxes%sw(i,j) = CS%Solar(i,j) * G%mask2dT(i,j) enddo ; enddo else ! This is the buoyancy only mode. do j=js,je ; do i=is,ie @@ -169,14 +168,14 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & ! "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + fluxes%vprec(i,j) = - (CS%rho_restore * CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -191,14 +190,14 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 + ! density [R ~> kg m-3] that is being restored toward. + density_restore = 1030.0 * US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -216,8 +215,8 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) type(MESO_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MESO_surface_forcing" ! This module's name. if (associated(CS)) then @@ -242,10 +241,10 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", units="Pa", default=0.0, & + scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -254,12 +253,9 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T)) call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & "The file with the SST toward which to restore in "//& @@ -278,8 +274,12 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) "variable NET_SOL.", fail_if_missing=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) - - endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0).or.(.not.CS%restorebuoy)) + endif end subroutine MESO_surface_forcing_init diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 similarity index 68% rename from config_src/solo_driver/MOM_driver.F90 rename to config_src/drivers/solo_driver/MOM_driver.F90 index 6fba8efdee..9b85fafb8d 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -1,4 +1,4 @@ -program MOM_main +program MOM6 ! This file is part of MOM6. See LICENSE.md for the license. @@ -26,54 +26,52 @@ program MOM_main use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_data_override, only : data_override_init + use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration + use MOM_diag_manager_infra, only : diag_manager_set_time_end_infra use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : step_offline - use MOM_domains, only : MOM_infra_init, MOM_infra_end + use MOM, only : save_MOM_restart + use MOM_coms, only : Set_PElist + use MOM_domains, only : MOM_infra_init, MOM_infra_end, set_MOM_thread_affinity + use MOM_ensemble_manager, only : ensemble_manager_init, get_ensemble_size + use MOM_ensemble_manager, only : ensemble_pelist_setup use MOM_error_handler, only : 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 use MOM_forcing_type, only : forcing, mech_forcing, forcing_diagnostics use MOM_forcing_type, only : mech_forcing_diags, MOM_forcing_chksum, MOM_mech_forcing_chksum - use MOM_get_input, only : directories + use MOM_get_input, only : get_MOM_input, directories use MOM_grid, only : ocean_grid_type - use MOM_io, only : file_exists, open_file, close_file + 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_interpolate, only : time_interp_external_init + use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end - use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_restart, only : MOM_restart_CS, save_restart + use MOM_io, only : APPEND_FILE, READONLY_FILE 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 - use MOM_time_manager, only : real_to_time, time_type_to_real + use MOM_time_manager, only : time_type, set_date, get_date, real_to_time, time_type_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 - use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS - use MOM_time_manager, only : NO_CALENDAR + use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type + use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init + use MOM_wave_interface, only : Update_Surface_Waves use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS - use ensemble_manager_mod, only : ensemble_manager_init, get_ensemble_size - use ensemble_manager_mod, only : ensemble_pelist_setup - use mpp_mod, only : set_current_pelist => mpp_set_current_pelist - use time_interp_external_mod, only : time_interp_external_init - - 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 -! , add_shelf_flux_forcing, add_shelf_flux_IOB - - use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init - use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves - implicit none #include @@ -83,18 +81,17 @@ program MOM_main ! A structure containing pointers to the thermodynamic forcing fields ! at the ocean surface. type(forcing) :: fluxes - ! A structure containing pointers to the ocean surface state fields. type(surface) :: sfc_state ! A pointer to a structure containing metrics and related information. - type(ocean_grid_type), pointer :: grid - type(verticalGrid_type), pointer :: GV + type(ocean_grid_type), pointer :: grid => NULL() + type(verticalGrid_type), pointer :: GV => NULL() ! A pointer to a structure containing dimensional unit scaling factors. - type(unit_scale_type), pointer :: US + type(unit_scale_type), pointer :: US => NULL() ! If .true., use the ice shelf model for part of the domain. - logical :: use_ice_shelf + logical :: use_ice_shelf = .false. ! If .true., use surface wave coupling logical :: use_waves = .false. @@ -102,8 +99,6 @@ program MOM_main ! This is .true. if incremental restart files may be saved. logical :: permit_incr_restart = .true. - integer :: ns - ! nmax is the number of iterations after which to stop so that the ! simulation does not exceed its CPU time limit. nmax is determined by ! evaluating the CPU time used between successive calls to write_cputime. @@ -126,22 +121,23 @@ program MOM_main type(time_type) :: Time_end ! End time for the segment or experiment. type(time_type) :: restart_time ! The next time to write restart files. type(time_type) :: Time_step_ocean ! A time_type version of dt_forcing. - - real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. - logical :: elapsed_time_master ! If true, elapsed time is used to set the - ! model's master clock (Time). This is needed - ! if Time_step_ocean is not an exact - ! representation of dt_forcing. - real :: dt_forcing ! The coupling time step [s]. - real :: dt ! The baroclinic dynamics time step [s]. - real :: dt_off ! Offline time step [s]. - integer :: ntstep ! The number of baroclinic dynamics time steps - ! within dt_forcing. - real :: dt_therm - real :: dt_dyn, dtdia, t_elapsed_seg - integer :: n, n_max, nts, n_last_thermo - logical :: diabatic_first, single_step_call - type(time_type) :: Time2, time_chg + logical :: segment_start_time_set ! True if segment_start_time has been set to a valid value. + + real :: elapsed_time = 0.0 ! Elapsed time in this run [T ~> s]. + logical :: elapsed_time_master ! If true, elapsed time is used to set the model's master + ! clock (Time). This is needed if Time_step_ocean is not + ! an exact representation of dt_forcing. + real :: dt_forcing ! The coupling time step [T ~> s]. + real :: dt ! The nominal baroclinic dynamics time step [T ~> s]. + integer :: ntstep ! The number of baroclinic dynamics time steps within dt_forcing. + real :: dt_therm ! The thermodynamic timestep [T ~> s] + real :: dt_dyn ! The actual dynamic timestep used [T ~> s]. The value of dt_dyn + ! is chosen so that dt_forcing is an integer multiple of dt_dyn. + real :: dtdia ! The diabatic timestep [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this run segment [T ~> s] + integer :: n, ns, n_max, nts, n_last_thermo + logical :: diabatic_first, single_step_call, initialize_smb + type(time_type) :: Time2, time_chg ! Temporary time variables integer :: Restart_control ! An integer that is bit-tested to determine whether ! incremental restart files are saved and whether they @@ -155,23 +151,13 @@ program MOM_main type(time_type) :: daymax ! The final day of the simulation. integer :: CPU_steps ! The number of steps between writing CPU time. - integer :: date_init(6)=0 ! The start date of the whole simulation. - integer :: date(6)=-1 ! Possibly the start date of this run segment. - integer :: years=0, months=0, days=0 ! These may determine the segment run - integer :: hours=0, minutes=0, seconds=0 ! length, if read from a namelist. - integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. + integer :: date(6) ! Possibly the start date of this run segment. type(param_file_type) :: param_file ! The structure indicating the file(s) ! containing all run-time parameters. - character(len=9) :: month - character(len=16) :: calendar = 'julian' - integer :: calendar_type=-1 - integer :: unit, io_status, ierr - integer :: ensemble_size, nPEs_per, ensemble_info(6) + integer :: calendar_type=-1 ! A coded integer indicating the calendar type. - integer, dimension(0) :: atm_PElist, land_PElist, ice_PElist - integer, dimension(:), allocatable :: ocean_PElist - logical :: unit_in_use + integer :: unit, io_status, ierr integer :: initClock, mainClock, termClock logical :: debug ! If true, write verbose checksums for debugging purposes. @@ -183,32 +169,34 @@ program MOM_main ! and diffusion equation are read in from files stored from ! a previous integration of the prognostic model - type(MOM_control_struct), pointer :: MOM_CSp => NULL() - !> A pointer to the tracer flow control structure. + type(MOM_control_struct) :: MOM_CSp !< The control structure with all the MOM6 internal types, + !! parameters and variables type(tracer_flow_control_CS), pointer :: & tracer_flow_CSp => NULL() !< A pointer to the tracer flow control structure type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() + logical :: override_shelf_fluxes !< If true, and shelf dynamics are active, + !! the data_override feature is enabled (only for MOSAIC grid types) type(wave_parameters_cs), pointer :: waves_CSp => NULL() - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer to the restart control structure - !! that will be used for MOM restart files. - type(diag_ctrl), pointer :: & + type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- character(len=4), parameter :: vers_num = 'v2.0' -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mod_name = "MOM_main (MOM_driver)" ! This module's name. + ! These are the variables that might be read via the namelist capability. + integer :: date_init(6)=0 ! The start date of the whole simulation. + character(len=16) :: calendar = 'julian' ! The name of the calendar type. + integer :: years=0, months=0, days=0 ! These may determine the segment run + integer :: hours=0, minutes=0, seconds=0 ! length, if read from a namelist. integer :: ocean_nthreads = 1 - integer :: ncores_per_node = 36 logical :: use_hyper_thread = .false. - integer :: omp_get_num_threads,omp_get_thread_num,get_cpu_affinity,adder,base_cpu - namelist /ocean_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds,& - ocean_nthreads, ncores_per_node, use_hyper_thread + namelist /ocean_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds, & + ocean_nthreads, use_hyper_thread !===================================================================== @@ -216,18 +204,10 @@ program MOM_main call MOM_infra_init() ; call io_infra_init() - ! Initialize the ensemble manager. If there are no settings for ensemble_size - ! in input.nml(ensemble.nml), these should not do anything. In coupled - ! configurations, this all occurs in the external driver. - call ensemble_manager_init() ; ensemble_info(:) = get_ensemble_size() - ensemble_size=ensemble_info(1) ; nPEs_per=ensemble_info(2) - if (ensemble_size > 1) then ! There are multiple ensemble members. - allocate(ocean_pelist(nPEs_per)) - call ensemble_pelist_setup(.true., 0, nPEs_per, 0, 0, atm_pelist, ocean_pelist, & - land_pelist, ice_pelist) - call set_current_pelist(ocean_pelist) - deallocate(ocean_pelist) - endif + !allocate(forces,fluxes,sfc_state) + + ! Initialize the ensemble manager based on settings in input.nml(ensemble.nml). + call initialize_ocean_only_ensembles() ! These clocks are on the global pelist. initClock = cpu_clock_id( 'Initialization' ) @@ -240,43 +220,39 @@ program MOM_main if (file_exists('input.nml')) then ! Provide for namelist specification of the run length and calendar data. - call open_file(unit, 'input.nml', form=ASCII_FILE, action=READONLY_FILE) + call open_ASCII_file(unit, 'input.nml', action=READONLY_FILE) read(unit, ocean_solo_nml, iostat=io_status) call close_file(unit) ierr = check_nml_error(io_status,'ocean_solo_nml') - if (years+months+days+hours+minutes+seconds > 0) then - if (is_root_pe()) write(*,ocean_solo_nml) - endif + if (is_root_pe() .and. (years+months+days+hours+minutes+seconds > 0)) write(*,ocean_solo_nml) endif -!$ call omp_set_num_threads(ocean_nthreads) -!$ base_cpu = get_cpu_affinity() -!$OMP PARALLEL private(adder) -!$ if (use_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 -!$ else -!$ adder = ncores_per_node + omp_get_thread_num()/2 -!$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity (base_cpu + adder) -!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() -!$ call flush(6) -!$OMP END PARALLEL + ! This call sets the number and affinity of threads with openMP. + !$ call set_MOM_thread_affinity(ocean_nthreads, use_hyper_thread) + ! This call is required to initiate dirs%restart_input_dir for ocean_solo.res + ! The contents of dirs will be reread in initialize_MOM. + call get_MOM_input(dirs=dirs) + + segment_start_time_set = .false. ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ocean_solo.res')) then - call open_file(unit,trim(dirs%restart_input_dir)//'ocean_solo.res', & - form=ASCII_FILE,action=READONLY_FILE) + date(:) = -1 + call open_ASCII_file(unit, trim(dirs%restart_input_dir)//'ocean_solo.res', action=READONLY_FILE) read(unit,*) calendar_type read(unit,*) date_init read(unit,*) date call close_file(unit) + + call set_calendar_type(calendar_type) + if (sum(date) >= 0) then + ! In this case, the segment starts at a time fixed by ocean_solo.res + segment_start_time = set_date(date(1), date(2), date(3), date(4), date(5), date(6)) + segment_start_time_set = .true. + endif else calendar = uppercase(calendar) - if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN + 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 @@ -286,37 +262,53 @@ program MOM_main else call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') endif + call set_calendar_type(calendar_type) endif - call set_calendar_type(calendar_type) 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 - call time_interp_external_init + call time_interp_external_init() - if (sum(date) >= 0) then + ! Call initialize MOM with an optional Ice Shelf CS which, if present triggers + ! initialization of ice shelf parameters and arrays. + if (segment_start_time_set) then ! In this case, the segment starts at a time fixed by ocean_solo.res - segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time - call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, & segment_start_time, offline_tracer_mode=offline_tracer_mode, & - diag_ptr=diag, tracer_flow_CSp=tracer_flow_CSp) + diag_ptr=diag, tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp, & + waves_CSp=Waves_CSp) else ! In this case, the segment starts at a time read from the MOM restart file - ! or left as Start_time by MOM_initialize. + ! or is left at Start_time by MOM_initialize. Time = Start_time - call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, & offline_tracer_mode=offline_tracer_mode, diag_ptr=diag, & - tracer_flow_CSp=tracer_flow_CSp) + tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp, waves_CSp=Waves_CSp) endif - call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p=fluxes%C_p) + call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p_scaled=fluxes%C_p) Master_Time = Time + use_ice_shelf = associated(ice_shelf_CSp) + + if (use_ice_shelf) then + ! These arrays are not initialized in most solo cases, but are needed + ! when using an ice shelf + call initialize_ice_shelf_fluxes(ice_shelf_CSp, grid, US, fluxes) + call initialize_ice_shelf_forces(ice_shelf_CSp, grid, US, forces) + call ice_shelf_query(ice_shelf_CSp, grid, data_override_shelf_fluxes=override_shelf_fluxes) + if (override_shelf_fluxes) call data_override_init(Ocean_Domain_in=grid%domain%mpp_domain) + call get_param(param_file, mod_name, "INITIALIZE_ICE_SHEET_SMB", & + initialize_smb, "Read in a constant SMB for the ice sheet", default=.false.) + if (initialize_smb) call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, grid, US, param_file) + endif + call callTree_waypoint("done initialize_MOM") @@ -326,46 +318,40 @@ program MOM_main surface_forcing_CSp, tracer_flow_CSp) call callTree_waypoint("done surface_forcing_init") - call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & - "If true, enables the ice shelf model.", default=.false.) - if (use_ice_shelf) then - ! These arrays are not initialized in most solo cases, but are needed - ! when using an ice shelf - call initialize_ice_shelf(param_file, grid, Time, ice_shelf_CSp, & - diag, forces, fluxes) - endif - call get_param(param_file,mod_name,"USE_WAVES",Use_Waves,& + call get_param(param_file, mod_name, "USE_WAVES", Use_Waves, & "If true, enables surface wave modules.",default=.false.) - if (use_waves) then - call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) - else - call MOM_wave_interface_init_lite(param_file) - endif + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because + ! it also initializes statistical waves. + call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) segment_start_time = Time elapsed_time = 0.0 ! Read all relevant parameters and write them to the model log. call log_version(param_file, mod_name, version, "") - call get_param(param_file, mod_name, "DT", dt, fail_if_missing=.true.) + call get_param(param_file, mod_name, "DT", dt, & + units="s", scale=US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mod_name, "DT_FORCING", dt_forcing, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics. "//& - "The default value is given by DT.", units="s", default=dt) + "The default value is given by DT.", & + units="s", default=US%T_to_s*dt, scale=US%s_to_T) if (offline_tracer_mode) then call get_param(param_file, mod_name, "DT_OFFLINE", dt_forcing, & - "Time step for the offline time step") + "Length of time between reading in of input fields", & + units="s", scale=US%s_to_T, fail_if_missing=.true.) dt = dt_forcing endif ntstep = MAX(1,ceiling(dt_forcing/dt - 0.001)) - Time_step_ocean = real_to_time(dt_forcing) - elapsed_time_master = (abs(dt_forcing - time_type_to_real(Time_step_ocean)) > 1.0e-12*dt_forcing) + Time_step_ocean = real_to_time(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) if (elapsed_time_master) & call MOM_mesg("Using real elapsed time for the master clock.", 2) ! Determine the segment end time, either from the namelist file or parsed input file. + ! Note that Time_unit always is in [s]. call get_param(param_file, mod_name, "TIMEUNIT", Time_unit, & "The time unit for DAYMAX, ENERGYSAVEDAYS, and RESTINT.", & units="s", default=86400.0) @@ -390,6 +376,8 @@ program MOM_main Time_end = daymax endif + call diag_manager_set_time_end_infra(Time_end) + call get_param(param_file, mod_name, "SINGLE_STEPPING_CALL", single_step_call, & "If true, advance the state of MOM with a single step "//& "including both dynamics and thermodynamics. If false "//& @@ -400,7 +388,8 @@ program MOM_main "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=dt) + "default DT_THERM is set to DT.", & + units="s", default=US%T_to_s*dt, scale=US%s_to_T) call get_param(param_file, mod_name, "DIABATIC_FIRST", diabatic_first, & "If true, apply diabatic and thermodynamic processes, "//& "including buoyancy forcing and mass gain or loss, "//& @@ -441,19 +430,9 @@ program MOM_main call diag_mediator_close_registration(diag) ! Write out a time stamp file. - if (calendar_type /= NO_CALENDAR) then - call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & - threading=SINGLE_FILE) - call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call close_file(unit) - endif + if (is_root_pe() .and. (calendar_type /= NO_CALENDAR)) call write_time_stamp_file(Time) - if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (cpu_steps > 0) call write_cputime(Time, 0, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. @@ -488,7 +467,7 @@ program MOM_main if (use_ice_shelf) then call shelf_calc_flux(sfc_state, fluxes, Time, dt_forcing, ice_shelf_CSp) - call add_shelf_forces(grid, Ice_shelf_CSp, forces) + call add_shelf_forces(grid, US, Ice_shelf_CSp, forces, external_call=.true.) endif fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = dt_forcing @@ -498,7 +477,7 @@ program MOM_main endif if (ns==1) then - call finish_MOM_initialization(Time, dirs, MOM_CSp, restart_CSp) + call finish_MOM_initialization(Time, dirs, MOM_CSp) endif ! This call steps the model over a time dt_forcing. @@ -536,7 +515,7 @@ program MOM_main dtdia = dt_dyn*(n - n_last_thermo) ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & - Time2 = Time2 - real_to_time(dtdia - dt_dyn) + Time2 = Time2 - real_to_time(US%T_to_s*(dtdia - dt_dyn)) 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) @@ -545,44 +524,40 @@ program MOM_main endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + real_to_time(t_elapsed_seg) + Time2 = Time1 + real_to_time(US%T_to_s*t_elapsed_seg) enddo endif ! Time = Time + Time_step_ocean ! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + dt_forcing - if (elapsed_time > 2e9) then + if (elapsed_time > 2.0e9*US%s_to_T) then ! This is here to ensure that the conversion from a real to an integer can be accurately ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time ! does not lose resolution of order the timetype's resolution, provided that the timestep and ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller ! value would be required. - time_chg = real_to_time(elapsed_time) + time_chg = real_to_time(US%T_to_s*elapsed_time) segment_start_time = segment_start_time + time_chg - elapsed_time = elapsed_time - time_type_to_real(time_chg) + elapsed_time = elapsed_time - US%s_to_T*time_type_to_real(time_chg) endif if (elapsed_time_master) then - Master_Time = segment_start_time + real_to_time(elapsed_time) + Master_Time = segment_start_time + real_to_time(US%T_to_s*elapsed_time) else Master_Time = Master_Time + Time_step_ocean endif Time = Master_Time if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then - call write_cputime(Time, ns+ntstep-1, nmax, write_CPU_CSp) + call write_cputime(Time, ns+ntstep-1, write_CPU_CSp, nmax) endif ; endif - call enable_averaging(dt_forcing, Time, diag) - call mech_forcing_diags(forces, dt_forcing, grid, diag, surface_forcing_CSp%handles) - call disable_averaging(diag) + call mech_forcing_diags(forces, dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) if (.not. offline_tracer_mode) then if (fluxes%fluxes_used) then - call enable_averaging(fluxes%dt_buoy_accum, Time, diag) - call forcing_diagnostics(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, & + call forcing_diagnostics(fluxes, sfc_state, grid, US, Time, & diag, surface_forcing_CSp%handles) - call disable_averaging(diag) else call MOM_error(FATAL, "The solo MOM_driver is not yet set up to handle "//& "thermodynamic time steps that are longer than the coupling timestep.") @@ -593,16 +568,15 @@ program MOM_main if ((permit_incr_restart) .and. (fluxes%fluxes_used) .and. & (Time + (Time_step_ocean/2) > restart_time)) then if (BTEST(Restart_control,1)) then - call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, .true., GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, & + time_stamped=.true., GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir, .true.) endif if (BTEST(Restart_control,0)) then - call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & @@ -627,46 +601,101 @@ program MOM_main "For conservation, the ocean restart files can only be "//& "created after the buoyancy forcing is applied.") - call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, GV=GV) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - ! Write ocean solo restart file. - call open_file(unit, trim(dirs%restart_output_dir)//'ocean_solo.res', nohdrs=.true.) - if (is_root_pe())then - write(unit, '(i6,8x,a)') calendar_type, & - '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' - - call get_date(Start_time, yr, mon, day, hr, mins, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & - 'Model start time: year, month, day, hour, minute, second' - call get_date(Time, yr, mon, day, hr, mins, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & - 'Current model time: year, month, day, hour, minute, second' - endif - call close_file(unit) + + ! Write the ocean solo restart file. + call write_ocean_solo_res(Time, Start_time, calendar_type, & + trim(dirs%restart_output_dir)//'ocean_solo.res') endif if (is_root_pe()) then - do unit=10,1967 - INQUIRE(unit,OPENED=unit_in_use) - if (.not.unit_in_use) exit - enddo - open(unit,FILE="exitcode",FORM="FORMATTED",STATUS="REPLACE",action="WRITE") + call open_ASCII_file(unit, "exitcode") if (Time < daymax) then write(unit,*) 9 else write(unit,*) 0 endif - close(unit) + call close_file(unit) endif call callTree_waypoint("End MOM_main") + if (use_ice_shelf) call ice_shelf_end(ice_shelf_CSp) call diag_mediator_end(Time, diag, end_diag_manager=.true.) + if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end call MOM_end(MOM_CSp) - if (use_ice_shelf) call ice_shelf_end(ice_shelf_CSp) -end program MOM_main +contains + +!> Write out the ocean solo restart file to the indicated path. +subroutine write_ocean_solo_res(Time, Start_time, calendar, file_path) + type(time_type), intent(in) :: Time !< The current model time. + type(time_type), intent(in) :: Start_Time !< The start time of the simulation. + integer, intent(in) :: calendar !< A coded integer indicating the calendar type. + character(len=*), intent(in) :: file_path !< The full path and name of the restart file + + ! Local variables + integer :: unit + integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. + + if (.not.is_root_pe()) return + + call open_ASCII_file(unit, trim(file_path)) + write(unit, '(i6,8x,a)') calendar, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Model start time: year, month, day, hour, minute, second' + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Current model time: year, month, day, hour, minute, second' + call close_file(unit) +end subroutine write_ocean_solo_res + + +!> Write out an ascii time stamp file with the model time, following FMS conventions. +subroutine write_time_stamp_file(Time) + type(time_type), intent(in) :: Time !< The current model time. + ! Local variables + integer :: unit + integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. + character(len=9) :: month ! The name of the month + + if (.not.is_root_PE()) return + + call open_ASCII_file(unit, 'time_stamp.out', action=APPEND_FILE) + call get_date(Time, yr, mon, day, hr, mins, sec) + month = month_name(mon) + write(unit,'(6i4,2x,a3)') yr, mon, day, hr, mins, sec, month(1:3) + call get_date(Time_end, yr, mon, day, hr, mins, sec) + month = month_name(mon) + write(unit,'(6i4,2x,a3)') yr, mon, day, hr, mins, sec, month(1:3) + call close_file(unit) +end subroutine write_time_stamp_file + +!> Initialize the ensemble manager. If there are no settings for ensemble_size +!! in input.nml(ensemble.nml), these should not do anything. In coupled +!! configurations, this all occurs in the external driver. +subroutine initialize_ocean_only_ensembles() + integer, dimension(:), allocatable :: ocean_PElist + integer, dimension(0) :: atm_PElist, land_PElist, ice_PElist + integer :: ensemble_size, nPEs_per, ensemble_info(6) + + call ensemble_manager_init() ; ensemble_info(:) = get_ensemble_size() + ensemble_size = ensemble_info(1) ; nPEs_per = ensemble_info(2) + if (ensemble_size > 1) then ! There are multiple ensemble members. + allocate(ocean_pelist(nPEs_per)) + call ensemble_pelist_setup(.true., 0, nPEs_per, 0, 0, atm_pelist, ocean_pelist, & + land_pelist, ice_pelist) + call Set_PElist(ocean_pelist) + deallocate(ocean_pelist) + endif +end subroutine initialize_ocean_only_ensembles + +end program MOM6 diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 similarity index 66% rename from config_src/solo_driver/MOM_surface_forcing.F90 rename to config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 4d9458a1c9..3de43eec85 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1,5 +1,5 @@ !> Functions that calculate the surface wind stresses and fluxes of buoyancy -!! or temperature/salinity andfresh water, in ocean-only (solo) mode. +!! or temperature/salinity and fresh water, in ocean-only (solo) mode. !! !! These functions are called every time step, even if the wind stresses !! or buoyancy fluxes are constant in time - in that case these routines @@ -12,13 +12,14 @@ module MOM_surface_forcing use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE +use MOM_data_override, only : data_override_init, data_override use MOM_diag_mediator, only : post_data, query_averaging_enabled use MOM_diag_mediator, only : diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All use MOM_domains, only : fill_symmetric_edges, CGRID_NE use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_string_functions, only : uppercase use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : set_net_mass_forcing, copy_common_forcing_fields @@ -29,6 +30,7 @@ module MOM_surface_forcing use MOM_grid, only : ocean_grid_type use MOM_get_input, only : Get_MOM_Input, directories use MOM_io, only : file_exists, MOM_read_data, MOM_read_vector, slasher +use MOM_io, only : read_netCDF_data use MOM_io, only : EAST_FACE, NORTH_FACE, num_timelevels use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state @@ -39,8 +41,6 @@ module MOM_surface_forcing use MOM_variables, only : surface use MESO_surface_forcing, only : MESO_buoyancy_forcing use MESO_surface_forcing, only : MESO_surface_forcing_init, MESO_surface_forcing_CS -use Neverland_surface_forcing, only : Neverland_wind_forcing, Neverland_buoyancy_forcing -use Neverland_surface_forcing, only : Neverland_surface_forcing_init, Neverland_surface_forcing_CS use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init @@ -56,7 +56,6 @@ module MOM_surface_forcing use BFB_surface_forcing, only : BFB_surface_forcing_init, BFB_surface_forcing_CS use dumbbell_surface_forcing, only : dumbbell_surface_forcing_init, dumbbell_surface_forcing_CS use dumbbell_surface_forcing, only : dumbbell_buoyancy_forcing -use data_override_mod, only : data_override_init, data_override implicit none ; private @@ -73,55 +72,68 @@ module MOM_surface_forcing logical :: use_temperature !< if true, temp & salinity used as state variables logical :: restorebuoy !< if true, use restoring surface buoyancy forcing logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing + logical :: nonBous !< If true, this run is fully non-Boussinesq logical :: variable_winds !< if true, wind stresses vary with time logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. - real :: south_lat !< southern latitude of the domain - real :: len_lat !< domain length in latitude + real :: south_lat !< southern latitude of the domain [degrees_N] or [km] or [m] + real :: len_lat !< domain length in latitude [degrees_N] or [km] or [m] - real :: Rho0 !< Boussinesq reference density [kg m-3] + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< piston velocity for surface restoring [m s-1] - real :: Flux_const_T !< piston velocity for surface temperature restoring [m s-1] - real :: Flux_const_S !< piston velocity for surface salinity restoring [m s-1] - real :: latent_heat_fusion !< latent heat of fusion [J kg-1] - real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] - real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" forcing - real :: tau_y0 !< Constant meridional wind stress used in the WIND_CONFIG="const" forcing - - real :: gust_const !< constant unresolved background gustiness for ustar [Pa] + real :: Flux_const = 0.0 !< piston velocity for surface restoring [Z T-1 ~> m s-1] + real :: Flux_const_T = 0.0 !< piston velocity for surface temperature restoring [Z T-1 ~> m s-1] + real :: Flux_const_S = 0.0 !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] + real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] + real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] + real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" + !! forcing [R L Z T-2 ~> Pa] + real :: tau_y0 !< Constant meridional wind stress used in the WIND_CONFIG="const" + !! forcing [R L Z T-2 ~> Pa] + real :: taux_mag !< Peak magnitude of the zonal wind stress for several analytic + !! profiles [R L Z T-2 ~> Pa] + + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [Pa] + real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-2 ~> Pa] !! gust is used when read_gust_2d is true. - real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] - real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] - real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [kg m-3] + real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [C ~> degC] + real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [S ~> ppt] + real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [R ~> kg m-3] integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files ! if WIND_CONFIG=='gyres' then use the following as = A, B, C and n respectively for ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) - real :: gyres_taux_const !< A constant wind stress [Pa]. - real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. - real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. - real :: gyres_taux_n_pis !< The number of sine lobes in the basin if if WIND_CONFIG=='gyres' - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover - !! the answers from the end of 2018. Otherwise, use a form of the gyre - !! wind stresses that are rotationally invariant and more likely to be - !! the same between compilers. - - real :: T_north !< target temperatures at north used in buoyancy_forcing_linear - real :: T_south !< target temperatures at south used in buoyancy_forcing_linear - real :: S_north !< target salinity at north used in buoyancy_forcing_linear - real :: S_south !< target salinity at south used in buoyancy_forcing_linear + real :: gyres_taux_const !< A constant wind stress [R L Z T-2 ~> Pa]. + real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [R L Z T-2 ~> Pa], if WIND_CONFIG=='gyres' + real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [R L Z T-2 ~> Pa], if WIND_CONFIG=='gyres' + real :: gyres_taux_n_pis !< The number of sine lobes in the basin if WIND_CONFIG=='gyres' [nondim] + integer :: answer_date !< This 8-digit integer gives the approximate date with which the order + !! of arithmetic and expressions were added to the code. + !! Dates before 20190101 use original answers. + !! Dates after 20190101 use a form of the gyre wind stresses that are + !! rotationally invariant and more likely to be the same between compilers. + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the + !! gustless wind friction velocity. + ! if WIND_CONFIG=='scurves' then use the following to define a piecewise scurve profile + real :: scurves_ydata(20) = 90. !< Latitudes of scurve nodes [degreesN] + real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [R L Z T-2 ~> Pa] + + real :: T_north !< Target temperatures at north used in buoyancy_forcing_linear [C ~> degC] + real :: T_south !< Target temperatures at south used in buoyancy_forcing_linear [C ~> degC] + real :: S_north !< Target salinity at north used in buoyancy_forcing_linear [S ~> ppt] + real :: S_south !< Target salinity at south used in buoyancy_forcing_linear [S ~> ppt] logical :: first_call_set_forcing = .true. !< True until after the first call to set_forcing logical :: archaic_OMIP_file = .true. !< If true use the variable names and data fields from !! a very old version of the OMIP forcing logical :: dataOverrideIsInitialized = .false. !< If true, data override has been initialized - real :: wind_scale !< value by which wind-stresses are scaled, ND. - real :: constantHeatForcing !< value used for sensible heat flux when buoy_config="const" + real :: wind_scale !< value by which wind-stresses are scaled [nondim] + real :: constantHeatForcing !< value used for sensible heat flux when buoy_config="const" [Q R Z T-1 ~> W m-2] character(len=8) :: wind_stagger !< A character indicating how the wind stress components !! are staggered in WIND_FILE. Valid values are A or C for now. @@ -148,17 +160,17 @@ module MOM_surface_forcing character(len=200) :: runoff_file = '' !< The file from which the runoff is read character(len=200) :: longwaveup_file = '' !< The file from which the upward longwave heat flux is read - character(len=200) :: shortwaveup_file = '' !< The file from which the upward shorwave heat flux is read + character(len=200) :: shortwaveup_file = '' !< The file from which the upward shortwave heat flux is read character(len=200) :: SSTrestore_file = '' !< The file from which to read the sea surface !! temperature to restore toward character(len=200) :: salinityrestore_file = '' !< The file from which to read the sea surface !! salinity to restore toward - character(len=80) :: stress_x_var = '' !< X-windstress variable name in the input file - character(len=80) :: stress_y_var = '' !< Y-windstress variable name in the input file + character(len=80) :: stress_x_var = '' !< X-wind stress variable name in the input file + character(len=80) :: stress_y_var = '' !< Y-wind stress variable name in the input file character(len=80) :: ustar_var = '' !< ustar variable name in the input file - character(len=80) :: LW_var = '' !< lonngwave heat flux variable name in the input file + character(len=80) :: LW_var = '' !< longwave heat flux variable name in the input file character(len=80) :: SW_var = '' !< shortwave heat flux variable name in the input file character(len=80) :: latent_var = '' !< latent heat flux variable name in the input file character(len=80) :: sens_var = '' !< sensible heat flux variable name in the input file @@ -167,7 +179,7 @@ module MOM_surface_forcing character(len=80) :: snow_var = '' !< snowfall variable name in the input file character(len=80) :: lrunoff_var = '' !< liquid runoff variable name in the input file character(len=80) :: frunoff_var = '' !< frozen runoff variable name in the input file - character(len=80) :: SST_restore_var = '' !< target sea surface temeperature variable name in the input file + character(len=80) :: SST_restore_var = '' !< target sea surface temperature variable name in the input file character(len=80) :: SSS_restore_var = '' !< target sea surface salinity variable name in the input file ! These variables give the number of time levels in the various forcing files. @@ -202,10 +214,9 @@ module MOM_surface_forcing type(BFB_surface_forcing_CS), pointer :: BFB_forcing_CSp => NULL() type(dumbbell_surface_forcing_CS), pointer :: dumbbell_forcing_CSp => NULL() type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() - type(Neverland_surface_forcing_CS), pointer :: Neverland_forcing_CSp => NULL() type(idealized_hurricane_CS), pointer :: idealized_hurricane_CSp => NULL() type(SCM_CVmix_tests_CS), pointer :: SCM_CVmix_tests_CSp => NULL() - !!@} + !>@} end type surface_forcing_CS @@ -226,10 +237,10 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: dt ! length of time over which fluxes applied [s] + real :: dt ! length of time over which fluxes applied [T ~> s] type(time_type) :: day_center ! central time of the fluxes. integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -238,13 +249,14 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call callTree_enter("set_forcing, MOM_surface_forcing.F90") day_center = day_start + day_interval/2 - dt = time_type_to_real(day_interval) + dt = US%s_to_T * time_type_to_real(day_interval) if (CS%first_call_set_forcing) then - ! Allocate memory for the mechanical and thermodyanmic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + ! Allocate memory for the mechanical and thermodynamic forcing fields. + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) - call allocate_forcing_type(G, fluxes, ustar=.true.) + call allocate_forcing_type(G, fluxes, ustar=.not.CS%nonBous, tau_mag=CS%nonBous, & + fix_accum_bug=.not.CS%ustar_gustless_bug) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) @@ -278,8 +290,10 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call wind_forcing_const(sfc_state, forces, 0., 0., day_center, G, US, CS) elseif (trim(CS%wind_config) == "const") then call wind_forcing_const(sfc_state, forces, CS%tau_x0, CS%tau_y0, day_center, G, US, CS) - elseif (trim(CS%wind_config) == "Neverland") then - call Neverland_wind_forcing(sfc_state, forces, day_center, G, US, CS%Neverland_forcing_CSp) + elseif (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then + call Neverworld_wind_forcing(sfc_state, forces, day_center, G, US, CS) + elseif (trim(CS%wind_config) == "scurves") then + call scurve_wind_forcing(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "ideal_hurr") then call idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then @@ -292,12 +306,18 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call MOM_error(FATAL, & "MOM_surface_forcing: Variable winds defined with no wind config") else - call MOM_error(FATAL, & + call MOM_error(FATAL, & "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) endif endif ! calls to various buoyancy forcing options + if (CS%restorebuoy .and. .not.CS%variable_buoyforce) then + call MOM_error(FATAL, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& + "Otherwise, this can lead to diverging solutions when a simulation "//& + "is continued using a restart file.") + endif + if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & (.not.CS%adiabatic)) then if (trim(CS%buoy_config) == "file") then @@ -307,34 +327,33 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US elseif (trim(CS%buoy_config) == "zero") then call buoyancy_forcing_zero(sfc_state, fluxes, day_center, dt, G, CS) elseif (trim(CS%buoy_config) == "const") then - call buoyancy_forcing_const(sfc_state, fluxes, day_center, dt, G, CS) + call buoyancy_forcing_const(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "linear") then - call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, CS) + call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "MESO") then call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "Neverland") then - call Neverland_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%Neverland_forcing_CSp) elseif (trim(CS%buoy_config) == "SCM_CVmix_tests") then - call SCM_CVmix_tests_buoyancy_forcing(sfc_state, fluxes, day_center, G, CS%SCM_CVmix_tests_CSp) + call SCM_CVmix_tests_buoyancy_forcing(sfc_state, fluxes, day_center, G, US, CS%SCM_CVmix_tests_CSp) elseif (trim(CS%buoy_config) == "USER") then call USER_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%user_forcing_CSp) elseif (trim(CS%buoy_config) == "BFB") then call BFB_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%BFB_forcing_CSp) elseif (trim(CS%buoy_config) == "dumbbell") then - call dumbbell_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%dumbbell_forcing_CSp) + call dumbbell_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%dumbbell_forcing_CSp) elseif (trim(CS%buoy_config) == "NONE") then call MOM_mesg("MOM_surface_forcing: buoyancy forcing has been set to omitted.") elseif (CS%variable_buoyforce .and. .not.CS%first_call_set_forcing) then call MOM_error(FATAL, & "MOM_surface_forcing: Variable buoy defined with no buoy config.") else - call MOM_error(FATAL, & + call MOM_error(FATAL, & "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) endif endif if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) + call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, CS%Rho0, & + CS%tracer_flow_CSp) endif ! Allow for user-written code to alter the fluxes after all the above @@ -348,7 +367,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & (.not.CS%adiabatic)) then - call set_net_mass_forcing(fluxes, forces, G) + call set_net_mass_forcing(fluxes, forces, G, US) endif CS%first_call_set_forcing = .false. @@ -363,24 +382,24 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: tau_x0 !< The zonal wind stress [Pa] - real, intent(in) :: tau_y0 !< The meridional wind stress [Pa] + real, intent(in) :: tau_x0 !< The zonal wind stress [R Z L T-2 ~> Pa] + real, intent(in) :: tau_y0 !< The meridional wind stress [R Z L T-2 ~> Pa] type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: mag_tau + real :: mag_tau ! Magnitude of the wind stress [R Z L T-2 ~> Pa] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq call callTree_enter("wind_forcing_const, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - !set steady surface wind stresses, in units of Pa. mag_tau = sqrt( tau_x0**2 + tau_y0**2) + ! Set the steady surface wind stresses, in units of [R L Z T-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq forces%taux(I,j) = tau_x0 enddo ; enddo @@ -391,11 +410,17 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) if (CS%read_gust_2d) then if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt( ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) + forces%ustar(i,j) = sqrt( US%L_to_Z * ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) + enddo ; enddo ; endif + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau + CS%gust(i,j) enddo ; enddo ; endif else if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt( ( mag_tau + CS%gust_const ) / CS%Rho0 ) + forces%ustar(i,j) = sqrt( US%L_to_Z * ( mag_tau + CS%gust_const ) / CS%Rho0 ) + enddo ; enddo ; endif + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau + CS%gust_const enddo ; enddo ; endif endif @@ -411,28 +436,29 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: PI + real :: PI ! A common irrational number, 3.1415926535... [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq call callTree_enter("wind_forcing_2gyre, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - !set the steady surface wind stresses, in units of Pa. PI = 4.0*atan(1.0) + ! Set the steady surface wind stresses, in units of [R L Z T-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = 0.1*(1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / & - CS%len_lat)) + forces%taux(I,j) = CS%taux_mag * (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 enddo ; enddo + if (associated(forces%ustar)) call stresses_to_ustar(forces, G, US, CS) + call callTree_leave("wind_forcing_2gyre") end subroutine wind_forcing_2gyre @@ -445,27 +471,29 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: PI + real :: PI ! A common irrational number, 3.1415926535... [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq call callTree_enter("wind_forcing_1gyre, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - ! set the steady surface wind stresses, in units of Pa. PI = 4.0*atan(1.0) + ! Set the steady surface wind stresses, in units of [R Z L T-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) =-0.2*cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) + forces%taux(I,j) = CS%taux_mag * cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 enddo ; enddo + if (associated(forces%ustar)) call stresses_to_ustar(forces, G, US, CS) + call callTree_leave("wind_forcing_1gyre") end subroutine wind_forcing_1gyre @@ -477,24 +505,25 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: PI, y, I_rho + real :: PI ! A common irrational number, 3.1415926535... [nondim] + real :: y ! The latitude relative to the south normalized by the domain extent [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq call callTree_enter("wind_forcing_gyres, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - ! steady surface wind stresses [Pa] PI = 4.0*atan(1.0) + ! steady surface wind stresses [R L Z T-2 ~> Pa] do j=js-1,je+1 ; do I=is-1,Ieq y = (G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat - forces%taux(I,j) = CS%gyres_taux_const + & - ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & - + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) ) + forces%taux(I,j) = CS%gyres_taux_const + & + ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & + + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) ) enddo ; enddo do J=js-1,Jeq ; do i=is-1,ie+1 @@ -502,24 +531,139 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) enddo ; enddo ! set the friction velocity - if (CS%answers_2018) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & - forces%tauy(i,j)*forces%tauy(i,j) + forces%taux(i-1,j)*forces%taux(i-1,j) + & - forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) - enddo ; enddo + if (CS%answer_date < 20190101) then + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt(US%L_to_Z * ((CS%gust_const/CS%Rho0) + & + sqrt(0.5*(forces%tauy(i,J-1)*forces%tauy(i,J-1) + forces%tauy(i,J)*forces%tauy(i,J) + & + forces%taux(I-1,j)*forces%taux(I-1,j) + forces%taux(I,j)*forces%taux(I,j)))/CS%Rho0) ) + enddo ; enddo ; endif else - I_rho = 1.0 / CS%Rho0 - do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt( (CS%gust_const + & - sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & - (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) - enddo ; enddo + call stresses_to_ustar(forces, G, US, CS) endif call callTree_leave("wind_forcing_gyres") end subroutine wind_forcing_gyres +!> Sets the surface wind stresses, forces%taux and forces%tauy for the +!! Neverworld forcing configuration. +subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< Grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by + !! a previous surface_forcing_init call + ! Local variables + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: PI ! A common irrational number, 3.1415926535... [nondim] + real :: y ! The latitude relative to the south normalized by the domain extent [nondim] + real :: tau_max ! The magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: off ! An offset in the relative latitude [nondim] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true.) + + ! Set the surface wind stresses, in units of [R Z L T-2 ~> Pa]. A positive taux + ! accelerates the ocean to the (pseudo-)east. + + ! The i-loop extends to is-1 so that taux can be used later in the + ! calculation of ustar - otherwise the lower bound would be Isq. + PI = 4.0*atan(1.0) + + forces%taux(:,:) = 0.0 + tau_max = CS%taux_mag + off = 0.02 + do j=js,je ; do I=is-1,Ieq + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat + + if (y <= 0.29) then + forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) + endif + if ((y > 0.29) .and. (y <= (0.8-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) + endif + if ((y > (0.8-off)) .and. (y <= (1-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) + endif + forces%taux(I,j) = G%mask2dCu(I,j) * forces%taux(I,j) + enddo ; enddo + + do J=js-1,Jeq ; do i=is,ie + forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 + enddo ; enddo + + ! Set the surface friction velocity, in units of [Z T-1 ~> m s-1]. ustar is always positive. + if (associated(forces%ustar)) call stresses_to_ustar(forces, G, US, CS) + +end subroutine Neverworld_wind_forcing + +!> Sets the zonal wind stresses to a piecewise series of s-curves. +subroutine scurve_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< Grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by + !! a previous surface_forcing_init call + ! Local variables + integer :: i, j, kseg + real :: y_curve ! The latitude relative to the southern end of a curve segment [degreesN] + real :: L_curve ! The latitudinal extent of a curve segment [degreesN] +! real :: ydata(7) = (/ -70., -45., -15., 0., 15., 45., 70. /) +! real :: taudt(7) = (/ 0., 0.2, -0.1, -0.02, -0.1, 0.1, 0. /) + + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true.) + + kseg = 1 + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + ! Find segment k s.t. ydata(k)<= G%geoLatCu(I,j) < ydata(k+1) + do while (G%geoLatCu(I,j) >= CS%scurves_ydata(kseg+1) .and. kseg<6) ! Should this be kseg<19? + kseg = kseg+1 + enddo + do while (G%geoLatCu(I,j) < CS%scurves_ydata(kseg) .and. kseg>1) + kseg = kseg-1 + enddo + + y_curve = G%geoLatCu(I,j) - CS%scurves_ydata(kseg) + L_curve = CS%scurves_ydata(kseg+1) - CS%scurves_ydata(kseg) + forces%taux(I,j) = CS%scurves_taux(kseg) + & + (CS%scurves_taux(kseg+1) - CS%scurves_taux(kseg)) * scurve(y_curve, L_curve) + forces%taux(I,j) = G%mask2dCu(I,j) * forces%taux(I,j) + enddo ; enddo + + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 + enddo ; enddo + + ! Set the surface friction velocity, in units of [Z T-1 ~> m s-1]. ustar is always positive. + if (associated(forces%ustar)) call stresses_to_ustar(forces, G, US, CS) + +end subroutine scurve_wind_forcing + +!> Returns the value of a cosine-bell function evaluated at x/L +real function scurve(x,L) + real , intent(in) :: x !< non-dimensional position [nondim] + real , intent(in) :: L !< non-dimensional width [nondim] + real :: s ! The evaluated function value [nondim] + + s = x/L + scurve = (3. - 2.*s) * (s*s) +end function scurve ! Sets the surface wind stresses from input files. subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) @@ -529,14 +673,17 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables character(len=200) :: filename ! The name of the input file. - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. + real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R L Z T-2 ~> Pa] + real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R L Z T-2 ~> Pa] + real :: ustar_loc(SZI_(G),SZJ_(G)) ! The local value of ustar [Z T-1 ~> m s-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] integer :: time_lev_daily ! The time levels to read for fields with - integer :: time_lev_monthly ! daily and montly cycles. + integer :: time_lev_monthly ! daily and monthly cycles. integer :: time_lev ! The time level that is used for a field. integer :: days, seconds integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -582,8 +729,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) case ("A") temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & - temp_x(:,:), temp_y(:,:), & - G%Domain, stagger=AGRID, timelevel=time_lev) + temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & + timelevel=time_lev, scale=US%Pa_to_RLZ_T2) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=js,je ; do I=is-1,Ieq @@ -595,15 +742,21 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + forces%ustar(i,j) = sqrt(tau_mag * US%L_to_Z / CS%Rho0) + enddo ; enddo ; endif else - do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & + sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) + enddo ; enddo ; endif endif endif case ("C") @@ -616,7 +769,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), & - G%Domain_aux, stagger=CGRID_NE, timelevel=time_lev) + G%Domain_aux, stagger=CGRID_NE, timelevel=time_lev, & + scale=US%Pa_to_RLZ_T2) do j=js,je ; do i=is,ie forces%taux(I,j) = CS%wind_scale * temp_x(I,j) forces%tauy(i,J) = CS%wind_scale * temp_y(i,J) @@ -625,7 +779,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) else call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & forces%taux(:,:), forces%tauy(:,:), & - G%Domain, stagger=CGRID_NE, timelevel=time_lev) + G%Domain, stagger=CGRID_NE, timelevel=time_lev, & + scale=US%Pa_to_RLZ_T2) if (CS%wind_scale /= 1.0) then do j=js,je ; do I=Isq,Ieq @@ -640,17 +795,28 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) if (.not.read_Ustar) then if (CS%read_gust_2d) then - do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & - forces%taux(i,j)**2))) + CS%gust(i,j)) / CS%Rho0 ) - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + forces%ustar(i,j) = sqrt( tau_mag * US%L_to_Z / CS%Rho0 ) + enddo ; enddo ; endif else - do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & - forces%taux(i,j)**2)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt(US%L_to_Z * ( (CS%gust_const/CS%Rho0) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2)))/CS%Rho0)) + enddo ; enddo ; endif endif endif case default @@ -659,8 +825,14 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) end select if (read_Ustar) then - call MOM_read_data(filename, CS%Ustar_var, forces%ustar(:,:), & + call MOM_read_data(filename, CS%Ustar_var, ustar_loc(:,:), & G%Domain, timelevel=time_lev, scale=US%m_to_Z*US%T_to_s) + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * ustar_loc(i,j)**2 + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = ustar_loc(i,j) + enddo ; enddo ; endif endif CS%wind_last_lev = time_lev @@ -679,33 +851,30 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. - real :: temp_ustar(SZI_(G),SZJ_(G)) ! ustar [m s-1] (not rescaled). - integer :: i, j, is_in, ie_in, js_in, je_in - logical :: read_uStar + real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R Z L T-2 ~> Pa]. + real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R Z L T-2 ~> Pa]. + real :: ustar_prev(SZI_(G),SZJ_(G)) ! The pre-override value of ustar [Z T-1 ~> m s-1] + real :: ustar_loc(SZI_(G),SZJ_(G)) ! The value of ustar, perhaps altered by data override [Z T-1 ~> m s-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] + integer :: i, j call callTree_enter("wind_forcing_by_data_override, MOM_surface_forcing.F90") if (.not.CS%dataOverrideIsInitialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) + call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif - is_in = G%isc - G%isd + 1 - ie_in = G%iec - G%isd + 1 - js_in = G%jsc - G%jsd + 1 - je_in = G%jec - G%jsd + 1 - temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 - call data_override('OCN', 'taux', temp_x, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - call data_override('OCN', 'tauy', temp_y, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + ! CS%wind_scale is ignored here because it is not set in this mode. + call data_override(G%Domain, 'taux', temp_x, day, scale=US%Pa_to_RLZ_T2) + call data_override(G%Domain, 'tauy', temp_y, day, scale=US%Pa_to_RLZ_T2) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - ! Ignore CS%wind_scale when using data_override ????? do j=G%jsc,G%jec ; do I=G%isc-1,G%IecB forces%taux(I,j) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) enddo ; enddo @@ -713,58 +882,119 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) forces%tauy(i,J) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) enddo ; enddo - read_Ustar = (len_trim(CS%ustar_var) > 0) ! Need better control higher up ???? - if (read_Ustar) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; temp_ustar(i,j) = US%Z_to_m*US%s_to_T*forces%ustar(i,j) ; enddo ; enddo - call data_override('OCN', 'ustar', temp_ustar, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; forces%ustar(i,j) = US%m_to_Z*US%T_to_s*temp_ustar(i,j) ; enddo ; enddo + if (CS%read_gust_2d) then + call data_override(G%Domain, 'gust', CS%gust, day, scale=US%Pa_to_RLZ_T2) + if (associated(forces%tau_mag)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust(i,j) + enddo ; enddo ; endif + do j=G%jsc,G%jec ; do i=G%isc,G%iec + tau_mag = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust(i,j) + ustar_loc(i,j) = sqrt( tau_mag * US%L_to_Z / CS%Rho0 ) + enddo ; enddo else - if (CS%read_gust_2d) then - call data_override('OCN', 'gust', CS%gust, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) - enddo ; enddo - else + if (associated(forces%tau_mag)) then do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust_const + ! ustar_loc(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) enddo ; enddo endif + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ustar_loc(i,j) = sqrt(US%L_to_Z * (sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)/CS%Rho0 + & + CS%gust_const/CS%Rho0)) + enddo ; enddo + endif + + ! Give the data override the option to modify the newly calculated forces%ustar. + ustar_prev(:,:) = ustar_loc(:,:) + call data_override(G%Domain, 'ustar', ustar_loc, day, scale=US%m_to_Z*US%T_to_s) + + ! Only reset values where data override of ustar has occurred + if (associated(forces%tau_mag)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ustar_prev(i,j) /= ustar_loc(i,j)) then + forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * ustar_loc(i,j)**2 + endif ; enddo ; enddo endif + if (associated(forces%ustar)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = ustar_loc(i,j) + enddo ; enddo ; endif + call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) -! call pass_var(forces%ustar, G%Domain, To_All) Not needed ????? call callTree_leave("wind_forcing_by_data_override") end subroutine wind_forcing_by_data_override +!> Translate the wind stresses into the friction velocity, including effects of background gustiness. +subroutine stresses_to_ustar(forces, G, US, CS) + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by + !! a previous surface_forcing_init call + ! Local variables + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] + integer :: i, j, is, ie, js, je -!> Specifies zero surface bouyancy fluxes from input files. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + I_rho = US%L_to_Z / CS%Rho0 + + if (CS%read_gust_2d) then + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + forces%ustar(i,j) = sqrt( tau_mag * I_rho ) + enddo ; enddo ; endif + else + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + forces%ustar(i,j) = sqrt( tau_mag * I_rho ) + enddo ; enddo ; endif + endif + +end subroutine stresses_to_ustar + +!> Specifies zero surface buoyancy fluxes from input files. subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] + !! the fluxes apply [T ~> s] type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - temp, & ! A 2-d temporary work array with various units. - SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value [degC]. - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value [ppt]. - SSS_mean ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation - ! anomalies [ppt]. - - real :: rhoXcp ! reference density times heat capacity [J m-3 degC-1] - real :: Irho0 ! inverse of the Boussinesq reference density [m3 kg-1] + temp ! A 2-d temporary work array in various units of [Q R Z T-1 ~> W m-2] or + ! [R Z T-1 ~> kg m-2 s-1] +!#CTRL# real, dimension(SZI_(G),SZJ_(G)) :: & +!#CTRL# SST_anom, & ! Instantaneous sea surface temperature anomalies from a +!#CTRL# ! target (observed) value [C ~> degC]. +!#CTRL# SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target +!#CTRL# ! (observed) value [S ~> ppt]. +!#CTRL# SSS_mean ! A (mean?) salinity about which to normalize local salinity +!#CTRL# ! anomalies when calculating restorative precipitation anomalies [S ~> ppt]. + + real :: rhoXcp ! reference density times heat capacity [Q R C-1 ~> J m-3 degC-1] integer :: time_lev_daily ! time levels to read for fields with daily cycle integer :: time_lev_monthly ! time levels to read for fields with monthly cycle @@ -777,8 +1007,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/CS%Rho0 + if (CS%use_temperature) rhoXcp = CS%rho_restore * fluxes%C_p ! Read the buoyancy forcing file call get_time(day, seconds, days) @@ -810,11 +1039,11 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case (365) ; time_lev = time_lev_daily case default ; time_lev = 1 end select - call MOM_read_data(CS%longwave_file, CS%LW_var, fluxes%LW(:,:), & - G%Domain, timelevel=time_lev) + call MOM_read_data(CS%longwave_file, CS%LW_var, fluxes%lw(:,:), & + G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) if (CS%archaic_OMIP_file) then call MOM_read_data(CS%longwaveup_file, "lwup_sfc", temp(:,:), G%Domain, & - timelevel=time_lev) + timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo endif CS%LW_last_lev = time_lev @@ -826,16 +1055,15 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select if (CS%archaic_OMIP_file) then - call MOM_read_data(CS%evaporation_file, CS%evap_var, temp(:,:), & - G%Domain, timelevel=time_lev) + call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & + G%Domain, timelevel=time_lev, scale=-US%kg_m2s_to_RZ_T) do j=js,je ; do i=is,ie - fluxes%latent(i,j) = -CS%latent_heat_vapor*temp(i,j) - fluxes%evap(i,j) = -temp(i,j) + fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo else call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) endif CS%evap_last_lev = time_lev @@ -846,7 +1074,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) end select if (.not.CS%archaic_OMIP_file) then call MOM_read_data(CS%latentheat_file, CS%latent_var, fluxes%latent(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo @@ -859,12 +1087,11 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select if (CS%archaic_OMIP_file) then - call MOM_read_data(CS%sensibleheat_file, CS%sens_var, temp(:,:), & - G%Domain, timelevel=time_lev) - do j=js,je ; do i=is,ie ; fluxes%sens(i,j) = -temp(i,j) ; enddo ; enddo + call MOM_read_data(CS%sensibleheat_file, CS%sens_var, fluxes%sens(:,:), & + G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T) else call MOM_read_data(CS%sensibleheat_file, CS%sens_var, fluxes%sens(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) endif CS%sens_last_lev = time_lev @@ -873,11 +1100,11 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case (365) ; time_lev = time_lev_daily case default ; time_lev = 1 end select - call MOM_read_data(CS%shortwave_file, CS%SW_var, fluxes%sw(:,:), & - G%Domain, timelevel=time_lev) + call MOM_read_data(CS%shortwave_file, CS%SW_var, fluxes%sw(:,:), G%Domain, & + timelevel=time_lev, scale=US%W_m2_to_QRZ_T) if (CS%archaic_OMIP_file) then - call MOM_read_data(CS%shortwaveup_file, "swup_sfc", temp(:,:), & - G%Domain, timelevel=time_lev) + call MOM_read_data(CS%shortwaveup_file, "swup_sfc", temp(:,:), G%Domain, & + timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie fluxes%sw(i,j) = fluxes%sw(i,j) - temp(i,j) enddo ; enddo @@ -890,9 +1117,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select call MOM_read_data(CS%snow_file, CS%snow_var, & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev) + fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) call MOM_read_data(CS%rain_file, CS%rain_var, & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev) + fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) if (CS%archaic_OMIP_file) then do j=js,je ; do i=is,ie fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) @@ -907,20 +1134,20 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) end select if (CS%archaic_OMIP_file) then call MOM_read_data(CS%runoff_file, CS%lrunoff_var, temp(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T*US%m_to_L**2) do j=js,je ; do i=is,ie fluxes%lrunoff(i,j) = temp(i,j)*G%IareaT(i,j) enddo ; enddo call MOM_read_data(CS%runoff_file, CS%frunoff_var, temp(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T*US%m_to_L**2) do j=js,je ; do i=is,ie fluxes%frunoff(i,j) = temp(i,j)*G%IareaT(i,j) enddo ; enddo else call MOM_read_data(CS%runoff_file, CS%lrunoff_var, fluxes%lrunoff(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) call MOM_read_data(CS%runoff_file, CS%frunoff_var, fluxes%frunoff(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) endif CS%runoff_last_lev = time_lev @@ -932,7 +1159,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select call MOM_read_data(CS%SSTrestore_file, CS%SST_restore_var, & - CS%T_Restore(:,:), G%Domain, timelevel=time_lev) + CS%T_Restore(:,:), G%Domain, timelevel=time_lev, scale=US%degC_to_C) CS%SST_last_lev = time_lev select case (CS%SSS_nlev) @@ -941,14 +1168,14 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select call MOM_read_data(CS%salinityrestore_file, CS%SSS_restore_var, & - CS%S_Restore(:,:), G%Domain, timelevel=time_lev) + CS%S_Restore(:,:), G%Domain, timelevel=time_lev, scale=US%ppt_to_S) CS%SSS_last_lev = time_lev endif CS%buoy_last_lev_read = time_lev_daily ! mask out land points and compute heat content of water fluxes - ! assume liquid precip enters ocean at SST - ! assume frozen precip enters ocean at 0degC + ! assume liquid precipitation enters ocean at SST + ! assume frozen precipitation enters ocean at 0degC ! assume liquid runoff enters ocean at SST ! assume solid runoff (calving) enters ocean at 0degC ! mass leaving the ocean has heat_content determined in MOM_diabatic_driver.F90 @@ -958,7 +1185,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%fprec(i,j) = fluxes%fprec(i,j) * G%mask2dT(i,j) fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * G%mask2dT(i,j) fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * G%mask2dT(i,j) - fluxes%LW(i,j) = fluxes%LW(i,j) * G%mask2dT(i,j) + fluxes%lw(i,j) = fluxes%lw(i,j) * G%mask2dT(i,j) fluxes%sens(i,j) = fluxes%sens(i,j) * G%mask2dT(i,j) fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) @@ -976,22 +1203,22 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 endif enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) + (CS%G_Earth * CS%Flux_const / CS%rho_restore) else fluxes%buoy(i,j) = 0.0 endif @@ -1013,130 +1240,91 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) !#CTRL# SSS_mean(i,j) = 0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j)) !#CTRL# enddo ; enddo !#CTRL# call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_added, & -!#CTRL# fluxes%vprec, day, dt, G, CS%ctrl_forcing_CSp) +!#CTRL# fluxes%vprec, day, dt, G, US, CS%ctrl_forcing_CSp) !#CTRL# endif call callTree_leave("buoyancy_forcing_from_files") end subroutine buoyancy_forcing_from_files -!> Specifies zero surface bouyancy fluxes from data over-ride. +!> Specifies zero surface buoyancy fluxes from data over-ride. subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] + !! the fluxes apply [T ~> s] type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: & - temp, & ! A 2-d temporary work array with various units. - SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value [degC]. - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value [ppt]. - SSS_mean ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation - ! anomalies [ppt]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. - real :: Irho0 ! The inverse of the Boussinesq density [m3 kg-1]. - - integer :: time_lev_daily ! The time levels to read for fields with - integer :: time_lev_monthly ! daily and montly cycles. - integer :: itime_lev ! The time level that is used for a field. - - integer :: days, seconds +!#CTRL# real, dimension(SZI_(G),SZJ_(G)) :: & +!#CTRL# SST_anom, & ! Instantaneous sea surface temperature anomalies from a +!#CTRL# ! target (observed) value [C ~> degC]. +!#CTRL# SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target +!#CTRL# ! (observed) value [S ~> ppt]. +!#CTRL# SSS_mean ! A (mean?) salinity about which to normalize local salinity +!#CTRL# ! anomalies when calculating restorative precipitation anomalies [S ~> ppt]. + real :: rhoXcp ! The mean density times the heat capacity [Q R C-1 ~> J m-3 degC-1]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - integer :: is_in, ie_in, js_in, je_in call callTree_enter("buoyancy_forcing_from_data_override, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/CS%Rho0 + if (CS%use_temperature) rhoXcp = CS%rho_restore * fluxes%C_p if (.not.CS%dataOverrideIsInitialized) then - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif - is_in = G%isc - G%isd + 1 - ie_in = G%iec - G%isd + 1 - js_in = G%jsc - G%jsd + 1 - je_in = G%jec - G%jsd + 1 + call data_override(G%Domain, 'lw', fluxes%lw, day, scale=US%W_m2_to_QRZ_T) + call data_override(G%Domain, 'sw', fluxes%sw, day, scale=US%W_m2_to_QRZ_T) - call data_override('OCN', 'lw', fluxes%LW(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - call data_override('OCN', 'evap', fluxes%evap(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + ! The normal MOM6 sign conventions are that fluxes%evap and fluxes%sens are positive into the + ! ocean but evap and sens are normally positive quantities in the files. + call data_override(G%Domain, 'evap', fluxes%evap, day, scale=-US%kg_m2s_to_RZ_T) + call data_override(G%Domain, 'sens', fluxes%sens, day, scale=-US%W_m2_to_QRZ_T) - ! note the sign convention do j=js,je ; do i=is,ie - fluxes%evap(i,j) = -fluxes%evap(i,j) ! Normal convention is positive into the ocean - ! but evap is normally a positive quantity in the files - fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) + fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) + fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo - call data_override('OCN', 'sens', fluxes%sens(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - - ! note the sign convention - do j=js,je ; do i=is,ie - fluxes%sens(i,j) = -fluxes%sens(i,j) ! Normal convention is positive into the ocean - ! but sensible is normally a positive quantity in the files - enddo ; enddo - - call data_override('OCN', 'sw', fluxes%sw(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - - call data_override('OCN', 'snow', fluxes%fprec(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - - call data_override('OCN', 'rain', fluxes%lprec(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - - call data_override('OCN', 'runoff', fluxes%lrunoff(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - - call data_override('OCN', 'calving', fluxes%frunoff(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + call data_override(G%Domain, 'snow', fluxes%fprec, day, scale=US%kg_m2s_to_RZ_T) + call data_override(G%Domain, 'rain', fluxes%lprec, day, scale=US%kg_m2s_to_RZ_T) + call data_override(G%Domain, 'runoff', fluxes%lrunoff, day, scale=US%kg_m2s_to_RZ_T) + call data_override(G%Domain, 'calving', fluxes%frunoff, day, scale=US%kg_m2s_to_RZ_T) ! Read the SST and SSS fields for damping. if (CS%restorebuoy) then !#CTRL# .or. associated(CS%ctrl_forcing_CSp)) then - call data_override('OCN', 'SST_restore', CS%T_restore(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - - call data_override('OCN', 'SSS_restore', CS%S_restore(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) - + call data_override(G%Domain, 'SST_restore', CS%T_restore, day, scale=US%degC_to_C) + call data_override(G%Domain, 'SSS_restore', CS%S_restore, day, scale=US%ppt_to_S) endif ! restoring boundary fluxes if (CS%restorebuoy) then if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 endif enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) + (CS%G_Earth * CS%Flux_const / CS%rho_restore) else fluxes%buoy(i,j) = 0.0 endif @@ -1162,7 +1350,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%fprec(i,j) = fluxes%fprec(i,j) * G%mask2dT(i,j) fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * G%mask2dT(i,j) fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * G%mask2dT(i,j) - fluxes%LW(i,j) = fluxes%LW(i,j) * G%mask2dT(i,j) + fluxes%lw(i,j) = fluxes%lw(i,j) * G%mask2dT(i,j) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) fluxes%sens(i,j) = fluxes%sens(i,j) * G%mask2dT(i,j) fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) @@ -1172,7 +1360,6 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo - !#CTRL# if (associated(CS%ctrl_forcing_CSp)) then !#CTRL# do j=js,je ; do i=is,ie !#CTRL# SST_anom(i,j) = sfc_state%SST(i,j) - CS%T_Restore(i,j) @@ -1180,22 +1367,22 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US !#CTRL# SSS_mean(i,j) = 0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j)) !#CTRL# enddo ; enddo !#CTRL# call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_added, & -!#CTRL# fluxes%vprec, day, dt, G, CS%ctrl_forcing_CSp) +!#CTRL# fluxes%vprec, day, dt, G, US, CS%ctrl_forcing_CSp) !#CTRL# endif call callTree_leave("buoyancy_forcing_from_data_override") end subroutine buoyancy_forcing_from_data_override -!> This subroutine specifies zero surface bouyancy fluxes +!> This subroutine specifies zero surface buoyancy fluxes subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] + !! the fluxes apply [T ~> s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables integer :: i, j, is, ie, js, je @@ -1230,15 +1417,16 @@ end subroutine buoyancy_forcing_zero !> Sets up spatially and temporally constant surface heat fluxes. -subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) +subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] + !! the fluxes apply [T ~> s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables integer :: i, j, is, ie, js, je @@ -1272,18 +1460,21 @@ end subroutine buoyancy_forcing_const !> Sets surface fluxes of heat and salinity by restoring to temperature and !! salinity profiles that vary linearly with latitude. -subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) +subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] + !! the fluxes apply [T ~> s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: y, T_restore, S_restore + real :: y ! The latitude relative to the south normalized by the domain extent [nondim] + real :: T_restore ! The temperature towards which to restore [C ~> degC] + real :: S_restore ! The salinity towards which to restore [S ~> ppt] integer :: i, j, is, ie, js, je call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") @@ -1318,24 +1509,24 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + ((T_Restore - sfc_state%SST(i,j)) * ((CS%rho_restore * fluxes%C_p) * CS%Flux_const)) + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 endif enddo ; enddo else call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then + ! if (G%mask2dT(i,j) > 0.0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) + ! (CS%G_Earth * CS%Flux_const / CS%rho_restore) ! else ! fluxes%buoy(i,j) = 0.0 ! endif @@ -1354,7 +1545,7 @@ end subroutine buoyancy_forcing_linear !> Save a restart file for the forcing fields subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(time_type), intent(in) :: Time !< model time at this call; needed for mpp_write calls @@ -1362,7 +1553,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & logical, optional, intent(in) :: time_stamped !< If true, the restart file names !! include a unique time stamp; the default is false. character(len=*), optional, intent(in) :: filename_suffix !< optional suffix (e.g., a time-stamp) - !! to append to the restart fname + !! to append to the restart file name if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return @@ -1378,7 +1569,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< Forcing for tracers? @@ -1388,7 +1579,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C type(time_type) :: Time_frc ! This include declares and sets the variable "version". # include "version_variable.h" - logical :: default_2018_answers + real :: flux_const_default ! The unscaled value of FLUXCONST [m day-1] + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq + logical :: fix_ustar_gustless_bug ! If false, include a bug using an older run-time parameter. + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. @@ -1410,6 +1607,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + CS%nonBous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & default=".") @@ -1427,10 +1632,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "If true, the buoyancy forcing varies in time after the "//& "initialization of the model.", default=.true.) + ! Determine parameters related to the buoyancy forcing. call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & - "The character string that indicates how buoyancy forcing "//& - "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), (BFB) and (NONE).", fail_if_missing=.true.) + "The character string that indicates how buoyancy forcing is specified. Valid "//& + "options include (file), (data_override), (zero), (const), (linear), (MESO), "//& + "(SCM_CVmix_tests), (BFB), (dumbbell), (USER) and (NONE).", default="zero") if (trim(CS%buoy_config) == "file") then call get_param(param_file, mdl, "ARCHAIC_OMIP_FORCING_FILE", CS%archaic_OMIP_file, & "If true, use the forcing variable decomposition from "//& @@ -1567,12 +1773,15 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "SENSIBLE_HEAT_FLUX", CS%constantHeatForcing, & "A constant heat forcing (positive into ocean) applied "//& "through the sensible heat flux field. ", & - units='W/m2', fail_if_missing=.true.) + units='W/m2', scale=US%W_m2_to_QRZ_T, fail_if_missing=.true.) endif + + ! Determine parameters related to the wind forcing. call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing "//& - "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", fail_if_missing=.true.) + "The character string that indicates how wind forcing is specified. Valid "//& + "options include (file), (data_override), (2gyre), (1gyre), (gyres), (zero), "//& + "(const), (Neverworld), (scurves), (ideal_hurr), (SCM_ideal_hurr), "//& + "(SCM_CVmix_tests) and (USER).", default="zero") if (trim(CS%wind_config) == "file") then call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & "The file in which the wind stresses are found in "//& @@ -1583,17 +1792,17 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & "The name of the y-wind stress variable in WIND_FILE.", & default="STRESS_Y") - call get_param(param_file, mdl, "WINDSTRESS_STAGGER",CS%wind_stagger, & + call get_param(param_file, mdl, "WIND_STAGGER",CS%wind_stagger, & "A character indicating how the wind stress components "//& "are staggered in WIND_FILE. This may be A or C for now.", & - default="A") + default="C") call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & "A value by which the wind stresses in WIND_FILE are rescaled.", & default=1.0, units="nondim") call get_param(param_file, mdl, "USTAR_FORCING_VAR", CS%ustar_var, & "The name of the friction velocity variable in WIND_FILE "//& "or blank to get ustar from the wind stresses plus the "//& - "gustiness.", default=" ", units="nondim") + "gustiness.", default=" ") CS%wind_file = trim(CS%inputdir) // trim(CS%wind_file) endif if (trim(CS%wind_config) == "gyres") then @@ -1601,33 +1810,60 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "With the gyres wind_config, the constant offset in the "//& "zonal wind stress profile: "//& " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_SIN_AMP",CS%gyres_taux_sin_amp, & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) + call get_param(param_file, mdl, "TAUX_SIN_AMP", CS%gyres_taux_sin_amp, & "With the gyres wind_config, the sine amplitude in the "//& "zonal wind stress profile: "//& " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_COS_AMP",CS%gyres_taux_cos_amp, & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) + call get_param(param_file, mdl, "TAUX_COS_AMP", CS%gyres_taux_cos_amp, & "With the gyres wind_config, the cosine amplitude in "//& "the zonal wind stress profile: "//& " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & "With the gyres wind_config, the number of gyres in "//& "the zonal wind stress profile: "//& " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="nondim", default=0.0) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) - call get_param(param_file, mdl, "WIND_GYRES_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions for the gyre friction velocities "//& - "that are rotationally invariant and more likely to be the same between compilers.", & - default=default_2018_answers) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "WIND_GYRES_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions used to set gyre wind stresses. "//& + "Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values use a form of the gyre wind stresses that are "//& + "rotationally invariant and more likely to be the same between compilers.", & + default=default_answer_date) else - CS%answers_2018 = .false. + CS%answer_date = 20190101 + endif + if (trim(CS%wind_config) == "scurves") then + call get_param(param_file, mdl, "WIND_SCURVES_LATS", CS%scurves_ydata, & + "A list of latitudes defining a piecewise scurve profile "//& + "for zonal wind stress.", & + units="degrees N", fail_if_missing=.true.) + call get_param(param_file, mdl, "WIND_SCURVES_TAUX", CS%scurves_taux, & + "A list of zonal wind stress values at latitudes "//& + "WIND_SCURVES_LATS defining a piecewise scurve profile.", & + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) + endif + if (trim(CS%wind_config) == "2gyre") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = 2gyre.", & + units="Pa", default=0.1, scale=US%Pa_to_RLZ_T2) + endif + if (trim(CS%wind_config) == "1gyre") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = 1gyre.", & + units="Pa", default=-0.2, scale=US%Pa_to_RLZ_T2) endif + if (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = Neverworld.", & + units="Pa", default=0.2, scale=US%Pa_to_RLZ_T2) + endif + if ((trim(CS%wind_config) == "2gyre") .or. & (trim(CS%wind_config) == "1gyre") .or. & (trim(CS%wind_config) == "gyres") .or. & @@ -1635,71 +1871,100 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%south_lat = G%south_lat CS%len_lat = G%len_lat endif + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "If true, the buoyancy fluxes drive the model back toward some "//& + "specified surface state with a rate given by FLUXCONST.", default=.false.) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) + "The latent heat of fusion.", default=hlf, & + units="J/kg", scale=US%J_kg_to_Q) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & - "The latent heat of fusion.", units="J/kg", default=hlv) + "The latent heat of fusion.", default=hlv, units="J/kg", scale=US%J_kg_to_Q) if (CS%restorebuoy) then + ! These three variables use non-standard time units, but are rescaled as they are read. call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) if (CS%use_temperature) then + call get_param(param_file, mdl, "FLUXCONST", flux_const_default, & + default=0.0, units="m day-1", do_not_log=.true.) call get_param(param_file, mdl, "FLUXCONST_T", CS%Flux_const_T, & - "The constant that relates the restoring surface temperature "//& - "flux to the relative surface anomaly (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - default=CS%Flux_const) + "The constant that relates the restoring surface temperature flux to the "//& + "relative surface anomaly (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, default=flux_const_default) call get_param(param_file, mdl, "FLUXCONST_S", CS%Flux_const_S, & - "The constant that relates the restoring surface salinity "//& - "flux to the relative surface anomaly (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - default=CS%Flux_const) + "The constant that relates the restoring surface salinity flux to the "//& + "relative surface anomaly (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, default=flux_const_default) endif - ! Convert flux constants from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 - CS%Flux_const_T = CS%Flux_const_T / 86400.0 - CS%Flux_const_S = CS%Flux_const_S / 86400.0 - if (trim(CS%buoy_config) == "linear") then call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & "With buoy_config linear, the sea surface temperature "//& "at the northern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) + "to restore.", units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & "With buoy_config linear, the sea surface temperature "//& "at the southern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) + "to restore.", units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & "With buoy_config linear, the sea surface salinity "//& "at the northern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) + "to restore.", units="ppt", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & "With buoy_config linear, the sea surface salinity "//& "at the southern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) + "to restore.", units="ppt", default=35.0, scale=US%ppt_to_S) endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(((CS%Flux_const==0.0).and.(CS%Flux_const_T==0.0).and.(CS%Flux_const_S==0.0))& + .or.(.not.CS%restorebuoy))) endif call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & + "If true correct a bug in the time-averaging of the gustless wind friction velocity", & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) + call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) @@ -1709,8 +1974,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, & - timelevel=1) ! units should be Pa + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(filename, 'gustiness', CS%gust, G%Domain, & + rescale=US%Pa_to_RLZ_T2) ! units in file should be [Pa] endif ! All parameter settings are now known. @@ -1723,22 +1990,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS%dumbbell_forcing_CSp) elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then call MESO_surface_forcing_init(Time, G, US, param_file, diag, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "Neverland") then - call Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS%Neverland_forcing_CSp) elseif (trim(CS%wind_config) == "ideal_hurr" .or.& trim(CS%wind_config) == "SCM_ideal_hurr") then - call idealized_hurricane_wind_init(Time, G, param_file, CS%idealized_hurricane_CSp) + call idealized_hurricane_wind_init(Time, G, US, param_file, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "const") then call get_param(param_file, mdl, "CONST_WIND_TAUX", CS%tau_x0, & - "With wind_config const, this is the constant zonal "//& - "wind-stress", units="Pa", fail_if_missing=.true.) + "With wind_config const, this is the constant zonal wind-stress", & + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) call get_param(param_file, mdl, "CONST_WIND_TAUY", CS%tau_y0, & - "With wind_config const, this is the constant meridional "//& - "wind-stress", units="Pa", fail_if_missing=.true.) + "With wind_config const, this is the constant meridional wind-stress", & + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) elseif (trim(CS%wind_config) == "SCM_CVmix_tests" .or. & trim(CS%buoy_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_surface_forcing_init(Time, G, param_file, CS%SCM_CVmix_tests_CSp) - CS%SCM_CVmix_tests_CSp%Rho0 = CS%Rho0 !copy reference density for pass endif call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) @@ -1779,7 +2043,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C if (trim(CS%wind_config) == "file") & CS%wind_nlev = num_timelevels(CS%wind_file, CS%stress_x_var, min_dims=3) -!#CTRL# call controlled_forcing_init(Time, G, param_file, diag, CS%ctrl_forcing_CSp) +!#CTRL# call controlled_forcing_init(Time, G, US, param_file, diag, CS%ctrl_forcing_CSp) call user_revise_forcing_init(param_file, CS%urf_CS) @@ -1789,13 +2053,9 @@ end subroutine surface_forcing_init !> Deallocate memory associated with the surface forcing module subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call type(forcing), optional, intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields -! Arguments: CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init, it will be deallocated here. -! (inout) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. if (present(fluxes)) call deallocate_forcing_type(fluxes) diff --git a/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 similarity index 76% rename from config_src/ice_solo_driver/atmos_ocean_fluxes.F90 rename to config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 index 5494954398..fb9fbe3e22 100644 --- a/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 @@ -13,15 +13,19 @@ module atmos_ocean_fluxes_mod !> This subroutine duplicates an interface used by the FMS coupler, but only !! returns a value of -1. None of the arguments are used for anything. function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, & - param, flag, ice_restart_file, ocean_restart_file, & + param, flag, mol_wt, ice_restart_file, ocean_restart_file, & units, caller, verbosity) result (coupler_index) character(len=*), intent(in) :: name !< An unused argument character(len=*), intent(in) :: flux_type !< An unused argument character(len=*), intent(in) :: implementation !< An unused argument integer, optional, intent(in) :: atm_tr_index !< An unused argument - real, dimension(:), optional, intent(in) :: param !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument that would be used to + !! pass parameters for flux parameterizations + !! in other contexts [various] logical, dimension(:), optional, intent(in) :: flag !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument that would usually be + !! the tracer's molecular weight [g mol-1] character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 similarity index 82% rename from config_src/solo_driver/user_surface_forcing.F90 rename to config_src/drivers/solo_driver/user_surface_forcing.F90 index 92151e6cde..7d4ea94603 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -11,7 +11,6 @@ module user_surface_forcing use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS @@ -28,16 +27,18 @@ module user_surface_forcing !! It can be readily modified for a specific case, and because it is private there !! will be no changes needed in other code (although they will have to be recompiled). type, public :: user_surface_forcing_CS ; private - ! The variables in the cannonical example are used for some common + ! The variables in the canonical example are used for some common ! cases, but do not need to be used. logical :: use_temperature !< If true, temperature and salinity are used as state variables. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. - real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. - real :: G_Earth !< The gravitational acceleration [L2 Z-1 s-2 ~> m s-2]. - real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. + real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. + real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [Pa]. + !! that contributes to ustar [R L Z T-2 ~> Pa]. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -45,7 +46,7 @@ module user_surface_forcing contains -!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [Pa]. +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [R Z L T-2 ~> Pa]. !! These are the stresses in the direction of the model grid (i.e. the same !! direction as the u- and v- velocities). subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) @@ -70,27 +71,30 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) - ! Set the surface wind stresses, in units of Pa. A positive taux + ! Set the surface wind stresses, in units of [R L Z T-2 ~> Pa]. A positive taux ! accelerates the ocean to the (pseudo-)east. ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 ! Change this to the desired expression. + ! Change this to the desired expression. + forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%Pa_to_RLZ_T2 enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. enddo ; enddo - ! Set the surface friction velocity, in units of m s-1. ustar + ! Set the surface friction velocity, in units of [Z T-1 ~> m s-1]. ustar ! is always positive. if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gust_const + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) + if (associated(forces%ustar)) & + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(forces%tau_mag(i,j) * (US%L_to_Z/CS%Rho0)) enddo ; enddo ; endif end subroutine USER_wind_forcing @@ -104,7 +108,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] + !! the fluxes apply [T ~> s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned @@ -122,16 +126,16 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! (fprec, lrunoff and frunoff) left as arrays full of zeros. ! Evap is usually negative and precip is usually positive. All heat fluxes ! are in W m-2 and positive for heat going into the ocean. All fresh water -! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. +! fluxes are in [R Z T-1 ~> kg m-2 s-1] and positive for water moving into the ocean. ! Local variables - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] + real :: Temp_restore ! The temperature that is being restored toward [C ~> degC]. + real :: Salin_restore ! The salinity that is being restored toward [S ~> ppt] real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. + ! toward [R ~> kg m-3]. + real :: rhoXcp ! The mean density times the heat capacity [Q R C-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. + ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -169,7 +173,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! Set whichever fluxes are to be used here. Any fluxes that ! are always zero do not need to be changed here. do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] + ! Fluxes of fresh water through the surface are in units of [R Z T-1 ~> kg m-2 s-1] ! and are positive downward - i.e. evaporation should be negative. fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) @@ -177,7 +181,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! vprec will be set later, if it is needed for salinity restoring. fluxes%vprec(i,j) = 0.0 - ! Heat fluxes are in units of W m-2 and are positive into the ocean. + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) @@ -199,18 +203,17 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in degC) and - ! salinity (in PSU or ppt) that are being restored toward. + ! Set Temp_restore and Salin_restore to the temperature (in [C ~> degC]) and + ! salinity (in [S ~> ppt]) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((Salin_restore - sfc_state%SSS(i,j)) / & - (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const)) * & + ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else ! When modifying the code, comment out this error message. It is here @@ -219,11 +222,11 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 + ! density [R ~> kg m-3] that is being restored toward. + density_restore = 1030.0*US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & (density_restore - sfc_state%sfc_density(i,j)) @@ -243,8 +246,8 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to !! the control structure for this module -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "user_surface_forcing" ! This module's name. if (associated(CS)) then @@ -269,10 +272,10 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -280,13 +283,15 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T)) endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0).or.(.not.CS%restorebuoy)) end subroutine USER_surface_forcing_init diff --git a/config_src/drivers/timing_tests/time_MOM_EOS.F90 b/config_src/drivers/timing_tests/time_MOM_EOS.F90 new file mode 100644 index 0000000000..94e3282511 --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_EOS.F90 @@ -0,0 +1,213 @@ +program time_MOM_EOS + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_manual_init +use MOM_EOS, only : calculate_density, calculate_spec_vol +use MOM_EOS, only : list_of_eos, get_EOS_name + +implicit none + +! This macro is used to write out timings of a single test rather than conduct +! a suite of tests. It is not meant for general consumption. +#undef PDF_ONLY + +integer, parameter :: n_fns = 4 +character(len=40) :: fn_labels(n_fns) + +! Testing parameters: +! nic is number of elements to compute density for (array size), per call +! halo is data on either end of the array that should not be used +! nits is how many times to repeat the call between turning the timer on/off +! to overcome limited resolution of the timer +! nsamp repeats the timing to collect statistics on the measurement +#ifdef PDF_ONLY +integer, parameter :: nic=26, halo=4, nits=10000, nsamp=400 +#else +integer, parameter :: nic=23, halo=4, nits=1000, nsamp=400 +#endif + +real :: times(nsamp) ! CPU times for observing the PDF [seconds] + +! Arrays to hold timings in [seconds]: +! first axis corresponds to the form of EOS +! second axis corresponds to the function being timed +real, dimension(:,:), allocatable :: timings, tmean, tstd, tmin, tmax +integer :: n_eos, i, j + +n_eos = size(list_of_eos) +allocate( timings(n_eos,n_fns), tmean(n_eos,n_fns) ) +allocate( tstd(n_eos,n_fns), tmin(n_eos,n_fns), tmax(n_eos,n_fns) ) + +fn_labels(1) = 'calculate_density_scalar()' +fn_labels(2) = 'calculate_density_array()' +fn_labels(3) = 'calculate_spec_vol_scalar()' +fn_labels(4) = 'calculate_spec_vol_array()' + +tmean(:,:) = 0. +tstd(:,:) = 0. +tmin(:,:) = 1.e9 +tmax(:,:) = 0. +do i = 1, nsamp +#ifdef PDF_ONLY + call run_one(list_of_EOS, nic, halo, nits, times(i)) +#else + call run_suite(list_of_EOS, nic, halo, nits, timings) + tmean(:,:) = tmean(:,:) + timings(:,:) + tstd(:,:) = tstd(:,:) + timings(:,:)**2 ! tstd contains sum or squares here + tmin(:,:) = min( tmin(:,:), timings(:,:) ) + tmax(:,:) = max( tmax(:,:), timings(:,:) ) +#endif +enddo +tmean(:,:) = tmean(:,:) / real(nsamp) +tstd(:,:) = tstd(:,:) / real(nsamp) ! convert to mean of squares +tstd(:,:) = tstd(:,:) - tmean(:,:)**2 ! convert to variance +tstd(:,:) = sqrt( tstd(:,:) * ( real(nsamp) / real(nsamp-1) ) ) ! Standard deviation + +#ifdef PDF_ONLY +open(newunit=i, file='times.txt', status='replace', action='write') +write(i,'(1pE9.3)') times(:) +close(i) +#else + +! Display results in YAML +write(*,'(a)') "{" +do i = 1, n_eos + do j = 1, n_fns + write(*,"(2x,5a)") '"MOM_EOS_', trim(get_EOS_name(list_of_EOS(i))), & + ' ', trim(fn_labels(j)), '": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(i,j) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(i,j) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(i,j) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (i*j.ne.n_eos*n_fns) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(i,j) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(i,j) + endif + enddo +enddo +write(*,'(a)') "}" +#endif + +contains + +subroutine run_suite(EOS_list, nic, halo, nits, timings) + integer, intent(in) :: EOS_list(n_eos) !< IDs of EOS forms to loop over + integer, intent(in) :: nic !< Width of computational domain + integer, intent(in) :: halo !< Width of halo to add on either end + integer, intent(in) :: nits !< Number of calls to sample + !! (large enough that the CPU timers can resolve + !! the loop) + real, intent(out) :: timings(n_eos,n_fns) !< The average time taken for nits calls [seconds] + !! First index corresponds to EOS + !! Second index: 1 = scalar args, + !! 2 = array args without halo, + !! 3 = array args with halo and "dom". + type(EOS_type) :: EOS + integer :: e, i, dom(2) + real :: start, finish ! CPU times [seconds] + real :: T ! A potential or conservative temperature [degC] + real :: S ! A practical salinity or absolute salinity [ppt] + real :: P ! A pressure [Pa] + real :: rho ! A density [kg m-3] or specific volume [m3 kg-1] + real, dimension(nic+2*halo) :: T1, S1, P1, rho1 + + T = 10. + S = 35. + P = 2000.e4 + + ! Time the scalar interface + do e = 1, n_eos + call EOS_manual_init(EOS, form_of_EOS=EOS_list(e), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits*nic ! Calling nic* to make similar cost to array call + call calculate_density(T, S, P, rho, EOS) + enddo + call cpu_time(finish) + timings(e,1) = (finish - start) / real(nits) + + call cpu_time(start) + do i = 1, nits*nic ! Calling nic* to make similar cost to array call + call calculate_spec_vol(T, S, P, rho, EOS) + enddo + call cpu_time(finish) + timings(e,2) = (finish - start) / real(nits) + + enddo + + ! Time the "dom" interface, 1D array + halos + T1(:) = T + S1(:) = S + P1(:) = P + dom(:) = [1+halo,nic+halo] + + do e = 1, n_eos + call EOS_manual_init(EOS, form_of_EOS=EOS_list(e), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits + call calculate_density(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timings(e,3) = (finish - start) / real(nits) + + call cpu_time(start) + do i = 1, nits + call calculate_spec_vol(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timings(e,4) = (finish - start) / real(nits) + + enddo + +end subroutine run_suite + +!> Return timing for just one fixed call to explore the PDF +subroutine run_one(EOS_list, nic, halo, nits, timing) + integer, intent(in) :: EOS_list(n_eos) !< IDs of EOS forms to loop over + integer, intent(in) :: nic !< Width of computational domain + integer, intent(in) :: halo !< Width of halo to add on either end + integer, intent(in) :: nits !< Number of calls to sample + !! (large enough that the CPU timers can resolve + !! the loop) + real, intent(out) :: timing !< The average time taken for nits calls [seconds] + !! First index corresponds to EOS + !! Second index: 1 = scalar args, + !! 2 = array args without halo, + !! 3 = array args with halo and "dom". + type(EOS_type) :: EOS + integer :: i, dom(2) + real :: start, finish ! CPU times [seconds] + real, dimension(nic+2*halo) :: T1 ! Potential or conservative temperatures [degC] + real, dimension(nic+2*halo) :: S1 ! A practical salinities or absolute salinities [ppt] + real, dimension(nic+2*halo) :: P1 ! Pressures [Pa] + real, dimension(nic+2*halo) :: rho1 ! Densities [kg m-3] or specific volumes [m3 kg-1] + + ! Time the scalar interface + call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + ! Time the "dom" interface, 1D array + halos + T1(:) = 10. + S1(:) = 35. + P1(:) = 2000.e4 + dom(:) = [1+halo,nic+halo] + + call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits + call calculate_density(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timing = (finish-start)/real(nits) + +end subroutine run_one + +end program time_MOM_EOS diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 new file mode 100644 index 0000000000..5f4c0258ca --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -0,0 +1,100 @@ +program time_MOM_remapping + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_remapping, only : remapping_CS +use MOM_remapping, only : initialize_remapping +use MOM_remapping, only : remapping_core_h + +implicit none + +type(remapping_CS) :: CS +integer, parameter :: nk=75, nij=20*20, nits=10, nsamp=100, nschemes = 2 +character(len=10) :: scheme_labels(nschemes) +real, dimension(nschemes) :: timings ! Time for nits of nij calls for each scheme [s] +real, dimension(nschemes) :: tmean ! Mean time for a call [s] +real, dimension(nschemes) :: tstd ! Standard deviation of time for a call [s] +real, dimension(nschemes) :: tmin ! Shortest time for a call [s] +real, dimension(nschemes) :: tmax ! Longest time for a call [s] +real, dimension(:,:), allocatable :: u0, u1 ! Source/target values [arbitrary but same units as each other] +real, dimension(:,:), allocatable :: h0, h1 ! Source target thicknesses [0..1] +real :: start, finish ! Times [s] +real :: h0sum, h1sum ! Totals of h0 and h1 [nondim] +integer :: ij, k, isamp, iter, ischeme ! Indices and counters +integer :: seed_size ! Number of integers used by seed +integer, allocatable :: seed(:) ! Random number seed + +! Set seed for random numbers +call random_seed(size=seed_size) +allocate( seed(seed_Size) ) +seed(:) = 102030405 +call random_seed(put=seed) + +scheme_labels(1) = 'PCM' +scheme_labels(2) = 'PLM' + +! Set up some test data (note: using k,i indexing rather than i,k) +allocate( u0(nk,nij), h0(nk,nij), u1(nk,nij), h1(nk,nij) ) +call random_number(u0) ! In range 0-1 +call random_number(h0) ! In range 0-1 +call random_number(h1) ! In range 0-1 +do ij = 1, nij + h0(:,ij) = max(0., h0(:,ij) - 0.05) ! Make 5% of values equal to zero + h1(:,ij) = max(0., h1(:,ij) - 0.05) ! Make 5% of values equal to zero + h0sum = h0(1,ij) + h1sum = h1(1,ij) + do k = 2, nk + h0sum = h0sum + h0(k,ij) + h1sum = h1sum + h1(k,ij) + enddo + h0(:,ij) = h0(:,ij) / h0sum + h1(:,ij) = h1(:,ij) / h1sum +enddo + +! Loop over many samples of timing loop to collect statistics +tmean(:) = 0. +tstd(:) = 0. +tmin(:) = 1.e9 +tmax(:) = 0. +do isamp = 1, nsamp + ! Time reconstruction + remapping + do ischeme = 1, nschemes + call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme))) + call cpu_time(start) + do iter = 1, nits ! Make many passes to reduce sampling error + do ij = 1, nij ! Calling nij times to make similar to cost in MOM_ALE() + call remapping_core_h(CS, nk, h0(:,ij), u0(:,ij), nk, h1(:,ij), u1(:,ij)) + enddo + enddo + call cpu_time(finish) + timings(ischeme) = (finish-start)/real(nits*nij) ! Average time per call + enddo + tmean(:) = tmean(:) + timings(:) + tstd(:) = tstd(:) + timings(:)**2 ! tstd contains sum of squares here + tmin(:) = min( tmin(:), timings(:) ) + tmax(:) = max( tmax(:), timings(:) ) +enddo +tmean(:) = tmean(:) / real(nsamp) ! convert to mean +tstd(:) = tstd(:) / real(nsamp) ! convert to mean of squares +tstd(:) = tstd(:) - tmean(:)**2 ! convert to variance +tstd(:) = sqrt( tstd(:) * real(nsamp) / real(nsamp-1) ) ! convert to standard deviation + + +! Display results in YAML +write(*,'(a)') "{" +do ischeme = 1, nschemes + write(*,"(2x,5a)") '"MOM_remapping remapping_core_h(remapping_scheme=', & + trim(scheme_labels(ischeme)), ')": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(ischeme) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (ischeme.ne.nschemes) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(ischeme) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(ischeme) + endif +enddo +write(*,'(a)') "}" + +end program time_MOM_remapping diff --git a/config_src/unit_drivers/MOM_sum_driver.F90 b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 similarity index 71% rename from config_src/unit_drivers/MOM_sum_driver.F90 rename to config_src/drivers/unit_drivers/MOM_sum_driver.F90 index 5673b201ee..7a1ba82843 100644 --- a/config_src/unit_drivers/MOM_sum_driver.F90 +++ b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 @@ -1,4 +1,4 @@ -program MOM_main +program MOM_sum_driver ! This file is part of MOM6. See LICENSE.md for the license. @@ -18,45 +18,47 @@ program MOM_main use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_to_real, real_to_EFP use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT -! use MOM_diag_mediator, only : diag_mediator_end, diag_mediator_init -! use MOM_diag_mediator, only : diag_mediator_close_registration - use MOM_domains, only : MOM_domains_init, MOM_infra_init, MOM_infra_end + use MOM_domains, only : MOM_domain_type, MOM_domains_init, MOM_infra_init, MOM_infra_end + use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe use MOM_error_handler, only : MOM_set_verbosity use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_file_parser, only : open_param_file, close_param_file - use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_grid_initialize, only : set_grid_metrics + use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_io, only : MOM_io_init, file_exists, open_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE + use MOM_unit_scaling, only : unit_scale_type, unit_no_scaling_init, unit_scaling_end implicit none #include - type(ocean_grid_type) :: grid ! A structure containing metrics and grid info. - - type(param_file_type) :: param_file ! The structure indicating the file(s) + type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain + type(dyn_horgrid_type), pointer :: grid => NULL() ! A structure containing metrics and grid info + type(hor_index_type) :: HI ! A hor_index_type for array extents + type(param_file_type) :: param_file ! The structure indicating the file(s) ! containing all run-time parameters. - real :: max_depth + type(unit_scale_type), pointer :: US => NULL() !< A structure containing various unit + ! conversion factors, but in this case all are 1. + real :: max_depth ! The maximum ocean depth [m] integer :: verbosity integer :: num_sums - integer :: n, i, j, is, ie, js, je, nz - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: n, i, j, is, ie, js, je, isd, ied, jsd, jed integer :: unit, io_status, ierr logical :: unit_in_use real, allocatable, dimension(:) :: & - depth_tot_R, depth_tot_std, depth_tot_fastR + depth_tot_R, depth_tot_std, depth_tot_fastR ! Various sums of the depths [m] integer :: reproClock, fastreproClock, stdClock, initClock !----------------------------------------------------------------------- character(len=4), parameter :: vers_num = 'v2.0' -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_main (MOM_sum_driver)" ! This module's name. character(len=200) :: mesg @@ -79,15 +81,16 @@ program MOM_main verbosity = 2 ; call read_param(param_file, "VERBOSITY", verbosity) call MOM_set_verbosity(verbosity) - call MOM_domains_init(grid%domain, param_file) + call MOM_domains_init(Domain, param_file) call MOM_io_init(param_file) ! call diag_mediator_init(param_file) - call MOM_grid_init(grid, param_file) + call hor_index_init(Domain, HI, param_file) + call create_dyn_horgrid(grid, HI) + grid%Domain => Domain - is = grid%isc ; ie = grid%iec ; js = grid%jsc ; je = grid%jec ; nz = grid%ke - isd = grid%isd ; ied = grid%ied ; jsd = grid%jsd ; jed = grid%jed - IsdB = grid%IsdB ; IedB = grid%IedB ; JsdB = grid%JsdB ; JedB = grid%JedB + is = HI%isc ; ie = HI%iec ; js = HI%jsc ; je = HI%jec + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ! Read all relevant parameters and write them to the model log. call log_version(param_file, "MOM", version, "") @@ -103,8 +106,9 @@ program MOM_main allocate(depth_tot_std(num_sums)) ; depth_tot_std(:) = 0.0 allocate(depth_tot_fastR(num_sums)) ; depth_tot_fastR(:) = 0.0 -! Set up the parameters of the physical domain (i.e. the grid), G - call set_grid_metrics(grid, param_file) +! Set up the parameters of the physical grid + call unit_no_scaling_init(US) + call set_grid_metrics(grid, param_file, US) ! Set up the bottom depth, grid%bathyT either analytically or from file call get_param(param_file, "MOM", "MAXIMUM_DEPTH", max_depth, & @@ -161,42 +165,47 @@ program MOM_main endif enddo + call destroy_dyn_horgrid(grid) + call unit_scaling_end(US) call io_infra_end ; call MOM_infra_end contains +!> This subroutine sets up the benchmark test case topography for debugging subroutine benchmark_init_topog_local(D, G, param_file, max_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D !< The ocean bottom depth in m + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth in [m] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real, intent(in) :: max_depth !< The maximum ocean depth in m - -! This subroutine sets up the benchmark test case topography - real :: min_depth ! The minimum ocean depth in m. - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: D0 ! A constant to make the maximum ! - ! basin depth MAXIMUM_DEPTH. ! - real :: x, y -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "benchmark_initialize_topography" ! This subroutine's name. + real, intent(in) :: max_depth !< The maximum ocean depth [m] + + real :: min_depth ! The minimum ocean depth in [m]. + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: D0 ! A constant to make the maximum + ! basin depth MAXIMUM_DEPTH [m] + real :: m_to_Z ! A dimensional rescaling factor [Z m-1 ~> 1] + real :: x ! A fractional position in the x-direction [nondim] + real :: y ! A fractional position in the y-direction [nondim] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "benchmark_init_topog_local" ! This subroutine's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - call MOM_mesg(" benchmark_initialization.F90, benchmark_initialize_topography: setting topography", 5) + m_to_Z = 1.0 ! ; if (present(US)) m_to_Z = US%m_to_Z - call log_version(param_file, mdl, version) + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=m_to_Z) PI = 4.0*atan(1.0) - D0 = max_depth / 0.5; + D0 = max_depth / 0.5 ! Calculate the depth of the bottom. do i=is,ie ; do j=js,je - x=(G%geoLonT(i,j)-G%west_lon)/G%len_lon - y=(G%geoLatT(i,j)-G%south_lat)/G%len_lat + x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat ! This sets topography that has a reentrant channel to the south. D(i,j) = -D0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & + 0.75*exp(-6.0*y) & @@ -207,4 +216,4 @@ subroutine benchmark_init_topog_local(D, G, param_file, max_depth) end subroutine benchmark_init_topog_local -end program MOM_main +end program MOM_sum_driver diff --git a/config_src/drivers/unit_tests/test_MOM_EOS.F90 b/config_src/drivers/unit_tests/test_MOM_EOS.F90 new file mode 100644 index 0000000000..070bec04f6 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_EOS.F90 @@ -0,0 +1,10 @@ +program test_MOM_EOS + +use MOM_EOS, only : EOS_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( EOS_unit_tests(.true.) ) stop 1 + +end program test_MOM_EOS diff --git a/config_src/drivers/unit_tests/test_MOM_file_parser.F90 b/config_src/drivers/unit_tests/test_MOM_file_parser.F90 new file mode 100644 index 0000000000..55f57d5fc2 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_file_parser.F90 @@ -0,0 +1,65 @@ +program test_MOM_file_parser + +use MPI +use MOM_domains, only : MOM_infra_init +use MOM_domains, only : MOM_infra_end +use MOM_file_parser_tests, only : run_file_parser_tests + +implicit none + +integer, parameter :: comm = MPI_COMM_WORLD +integer, parameter :: root = 0 +integer :: rank +logical :: file_exists_on_rank +logical :: input_nml_exists, MOM_input_exists +integer :: io_unit +logical :: is_open, is_file +integer :: rc + +! NOTE: Bootstrapping requires external MPI configuration. +! - FMS initialization requires the presence of input.nml +! - MOM initialization requires MOM_input (if unspecificed by input.nml) +! - Any MPI-based I/O prior to MOM and FMS init will MPI initialization +! Thus, we need to do some minimal MPI setup. +call MPI_Init(rc) +call MPI_Comm_rank(comm, rank, rc) + +inquire(file='input.nml', exist=file_exists_on_rank) +call MPI_Reduce(file_exists_on_rank, input_nml_exists, 1, MPI_LOGICAL, & + MPI_LOR, root, comm, rc) + +inquire(file='MOM_input', exist=file_exists_on_rank) +call MPI_Reduce(file_exists_on_rank, MOM_input_exists, 1, MPI_LOGICAL, & + MPI_LOR, root, comm, rc) + +if (rank == root) then + ! Abort if at least one rank sees either input.nml or MOM_input + if (input_nml_exists) error stop "Remove existing 'input.nml' file." + if (MOM_input_exists) error stop "Remove existing 'MOM_input' file." + + ! Otherwise, create the (empty) files + open(newunit=io_unit, file='input.nml', status='replace') + write(io_unit, '(a)') "&fms2_io_nml /" + close(io_unit) + + open(newunit=io_unit, file='MOM_input', status='replace') + close(io_unit) +endif + +call MOM_infra_init(comm) + +! Run tests +call run_file_parser_tests + +! Cleanup +call MOM_infra_end + +if (rank == root) then + open(newunit=io_unit, file='MOM_input') + close(io_unit, status='delete') + + open(newunit=io_unit, file='input.nml') + close(io_unit, status='delete') +endif + +end program test_MOM_file_parser diff --git a/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 new file mode 100644 index 0000000000..3e5eec64fc --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 @@ -0,0 +1,10 @@ +program test_MOM_mixedlayer_restrat + +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( mixedlayer_restrat_unit_tests(.true.) ) stop 1 + +end program test_MOM_mixedlayer_restrat diff --git a/config_src/drivers/unit_tests/test_MOM_remapping.F90 b/config_src/drivers/unit_tests/test_MOM_remapping.F90 new file mode 100644 index 0000000000..e62b779bd6 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_remapping.F90 @@ -0,0 +1,7 @@ +program test_MOM_remapping + +use MOM_remapping, only : remapping_unit_tests + +if (remapping_unit_tests(.true.)) stop 1 + +end program test_MOM_remapping diff --git a/config_src/drivers/unit_tests/test_MOM_string_functions.F90 b/config_src/drivers/unit_tests/test_MOM_string_functions.F90 new file mode 100644 index 0000000000..2376afbbae --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_string_functions.F90 @@ -0,0 +1,10 @@ +program test_MOM_string_functions + +use MOM_string_functions, only : string_functions_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( string_functions_unit_tests(.true.) ) stop 1 + +end program test_MOM_string_functions diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 new file mode 100644 index 0000000000..5d78e0d501 --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 @@ -0,0 +1,45 @@ +module FMS_coupler_util + +use coupler_types_mod, only : coupler_2d_bc_type + +implicit none ; private + +public :: extract_coupler_values, set_coupler_values + +contains + +!> Get element and index of a boundary condition +subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb, jlb, & + is, ie, js, je, conversion) + integer, intent(in) :: ilb !< Lower bounds + integer, intent(in) :: jlb !< Lower bounds + real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values + type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted + integer, intent(in) :: BC_index !< The boundary condition number being extracted + integer, intent(in) :: BC_element !< The element of the boundary condition being extracted + integer, optional, intent(in) :: is !< The i- limits of array_out to be filled + integer, optional, intent(in) :: ie !< The i- limits of array_out to be filled + integer, optional, intent(in) :: js !< The j- limits of array_out to be filled + integer, optional, intent(in) :: je !< The j- limits of array_out to be filled + real, optional, intent(in) :: conversion !< A number that every element is multiplied by + + array_out(:,:) = -1. +end subroutine extract_coupler_values + +!> Set element and index of a boundary condition +subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb,& + is, ie, js, je, conversion) + integer, intent(in) :: ilb !< Lower bounds + integer, intent(in) :: jlb !< Lower bounds + real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC + type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type into which the data is being loaded + integer, intent(in) :: BC_index !< The boundary condition number being set + integer, intent(in) :: BC_element !< The element of the boundary condition being set + integer, optional, intent(in) :: is !< The i- limits of array_out to be filled + integer, optional, intent(in) :: ie !< The i- limits of array_out to be filled + integer, optional, intent(in) :: js !< The j- limits of array_out to be filled + integer, optional, intent(in) :: je !< The j- limits of array_out to be filled + real, optional, intent(in) :: conversion !< A number that every element is multiplied by +end subroutine set_coupler_values + +end module FMS_coupler_util diff --git a/config_src/external/GFDL_ocean_BGC/README.md b/config_src/external/GFDL_ocean_BGC/README.md new file mode 100644 index 0000000000..198575c8a7 --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/README.md @@ -0,0 +1,6 @@ +GFDL_ocean_BGC +============== + +These APIs reflect those for the GFDL ocean_BGC available at https://github.com/NOAA-GFDL/ocean_BGC. + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 new file mode 100644 index 0000000000..42c386497a --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 @@ -0,0 +1,149 @@ +!> A non-functioning template of the GFDL ocean BGC +module generic_tracer + + use time_manager_mod, only : time_type + use coupler_types_mod, only : coupler_2d_bc_type + + use g_tracer_utils, only : g_tracer_type, g_diag_type + + implicit none ; private + + public generic_tracer_register + public generic_tracer_init + public generic_tracer_register_diag + public generic_tracer_source + public generic_tracer_update_from_bottom + public generic_tracer_coupler_get + public generic_tracer_coupler_set + public generic_tracer_end + public generic_tracer_get_list + public do_generic_tracer + public generic_tracer_vertdiff_G + public generic_tracer_get_diag_list + public generic_tracer_coupler_accumulate + + !> Turn on generic tracers (note dangerous use of module data) + logical :: do_generic_tracer = .true. + +contains + + !> Unknown + subroutine generic_tracer_register + end subroutine generic_tracer_register + + !> Initialize generic tracers + subroutine generic_tracer_init(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) + integer, intent(in) :: isc !< Computation start index in i direction + integer, intent(in) :: iec !< Computation end index in i direction + integer, intent(in) :: jsc !< Computation start index in j direction + integer, intent(in) :: jec !< Computation end index in j direction + integer, intent(in) :: isd !< Data start index in i direction + integer, intent(in) :: ied !< Data end index in i direction + integer, intent(in) :: jsd !< Data start index in j direction + integer, intent(in) :: jed !< Data end index in j direction + integer, intent(in) :: nk !< Number of levels in k direction + integer, intent(in) :: ntau !< The number of tracer time levels (always 1 for MOM6) + integer, intent(in) :: axes(3) !< Domain axes? + type(time_type), intent(in) :: init_time !< Time + real, dimension(:,:,:),target, intent(in) :: grid_tmask !< Mask + integer, dimension(:,:) , intent(in) :: grid_kmt !< Number of wet cells in column + end subroutine generic_tracer_init + + !> Unknown + subroutine generic_tracer_register_diag + end subroutine generic_tracer_register_diag + + !> Get coupler values + subroutine generic_tracer_coupler_get(IOB_struc) + type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure + end subroutine generic_tracer_coupler_get + + !> Unknown + subroutine generic_tracer_coupler_accumulate(IOB_struc, weight, model_time) + type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure + real, intent(in) :: weight !< A weight for accumulating these fluxes + type(time_type), optional,intent(in) :: model_time !< Time + end subroutine generic_tracer_coupler_accumulate + + !> Calls the corresponding generic_X_update_from_source routine for each package X + subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& + grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& + frunoff,grid_ht, current_wave_stress, sosga) + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain + real, dimension(ilb:,jlb:,:), intent(in) :: Temp !< Potential temperature [deg C] + real, dimension(ilb:,jlb:,:), intent(in) :: Salt !< Salinity [psu] + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt !< Mass per unit area of each layer [kg m-2] + real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] + real, dimension(ilb:,jlb:), intent(in) :: hblt_depth !< Boundary layer depth [m] + integer, intent(in) :: tau !< Time step index of %field + real, intent(in) :: dtts !< The time step for this call [s] + real, dimension(ilb:,jlb:), intent(in) :: grid_dat !< Grid cell areas [m2] + type(time_type), intent(in) :: model_time !< Time + integer, intent(in) :: nbands !< The number of bands of penetrating shortwave radiation + real, dimension(:), intent(in) :: max_wavelength_band !< The maximum wavelength in each band + !! of penetrating shortwave radiation [nm] + real, dimension(:,ilb:,jlb:), intent(in) :: sw_pen_band !< Penetrating shortwave radiation per band [W m-2]. + !! The wavelength or angular direction band is the first index. + real, dimension(:,ilb:,jlb:,:), intent(in) :: opacity_band !< Opacity of seawater averaged over each band [m-1]. + !! The wavelength or angular direction band is the first index. + real, dimension(ilb:,jlb:),optional, intent(in) :: internal_heat !< Any internal or geothermal heat + !! sources that are applied to the ocean integrated + !! over this timestep [degC kg m-2] + real, dimension(ilb:,jlb:),optional, intent(in) :: frunoff !< Rate of iceberg calving [kg m-2 s-1] + real, dimension(ilb:,jlb:),optional, intent(in) :: grid_ht !< Unknown, and presently unused by MOM6 + real, dimension(ilb:,jlb:),optional , intent(in) :: current_wave_stress !< Unknown, and presently unused by MOM6 + real, optional , intent(in) :: sosga !< Global average sea surface salinity [ppt] + end subroutine generic_tracer_source + + !> Update the tracers from bottom fluxes + subroutine generic_tracer_update_from_bottom(dt, tau, model_time) + real, intent(in) :: dt !< Time step increment [s] + integer, intent(in) :: tau !< Time step index used for the concentration field + type(time_type), intent(in) :: model_time !< Time + end subroutine generic_tracer_update_from_bottom + + !> Vertically diffuse all generic tracers for GOLD ocean + subroutine generic_tracer_vertdiff_G(h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau) + real, dimension(:,:,:), intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2] + real, dimension(:,:,:), intent(in) :: ea !< The amount of fluid entrained from the layer + !! above during this call [H ~> m or kg m-2] + real, dimension(:,:,:), intent(in) :: eb !< The amount of fluid entrained from the layer + !! below during this call [H ~> m or kg m-2] + real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: kg_m2_to_H !< A unit conversion factor from mass per unit + !! area to thickness units [H m2 kg-1 ~> m3 kg-1 or 1] + real, intent(in) :: m_to_H !< A unit conversion factor from heights to + !! thickness units [H m-1 ~> 1 or kg m-3] + integer, intent(in) :: tau !< The time level to work on (always 1 for MOM6) + end subroutine generic_tracer_vertdiff_G + + !> Set the coupler values for each generic tracer + subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sosga,model_time) + type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain + integer, intent(in) :: tau !< Time step index of %field + real, dimension(ilb:,jlb:), intent(in) :: ST !< Sea surface temperature [degC] + real, dimension(ilb:,jlb:), intent(in) :: SS !< Sea surface salinity [ppt] + real, dimension(ilb:,jlb:,:,:), intent(in) :: rho !< Ocean density [kg m-3] + real, dimension(ilb:,jlb:,:), optional, intent(in) :: dzt !< Layer thickness [m] + real, optional, intent(in) :: sosga !< Global mean sea surface salinity [ppt] + type(time_type),optional, intent(in) :: model_time !< Time + end subroutine generic_tracer_coupler_set + + !> End this module by calling the corresponding generic_X_end for each package X + subroutine generic_tracer_end + end subroutine generic_tracer_end + + !> Get a pointer to the head of the generic tracers list + subroutine generic_tracer_get_list(list) + type(g_tracer_type), pointer :: list !< Pointer to head of the linked list + end subroutine generic_tracer_get_list + + !> Unknown + subroutine generic_tracer_get_diag_list(list) + type(g_diag_type), pointer :: list !< Pointer to head of the linked list + end subroutine generic_tracer_get_diag_list + +end module generic_tracer diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 new file mode 100644 index 0000000000..5c87c37e70 --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -0,0 +1,355 @@ +!> g_tracer_utils module consists of core utility subroutines to be used by +!! all generic tracer modules. These include the lowest level functions +!! for adding, allocating memory, and record keeping of individual generic +!! tracers irrespective of their physical/chemical nature. +module g_tracer_utils + + use coupler_types_mod, only: coupler_2d_bc_type + use time_manager_mod, only : time_type + use field_manager_mod, only: fm_string_len + use MOM_diag_mediator, only : g_diag_ctrl=>diag_ctrl + +implicit none ; private + + !> Each generic tracer node is an instant of a FORTRAN type with the following member variables. + !! These member fields are supposed to uniquely define an individual tracer. + !! One such type shall be instantiated for EACH individual tracer. + type g_tracer_type + !> Tracer concentration field in space (and time) + !! MOM keeps the prognostic tracer fields at 3 time levels, hence 4D. + real, pointer, dimension(:,:,:,:) :: field => NULL() + !> Tracer concentration in river runoff + real, allocatable, dimension(:,:) :: trunoff + logical :: requires_restart = .true. !< Unknown + character(len=fm_string_len) :: src_file !< Tracer source filename + character(len=fm_string_len) :: src_var_name !< Tracer source variable name + character(len=fm_string_len) :: src_var_unit !< Tracer source variable units + character(len=fm_string_len) :: src_var_gridspec !< Tracer source grid file name + character(len=fm_string_len) :: obc_src_file_name !< Boundary condition tracer source filename + character(len=fm_string_len) :: obc_src_field_name !< Boundary condition tracer source fieldname + integer :: src_var_record !< Unknown + logical :: runoff_added_to_stf = .false. !< Has flux in from runoff been added to stf? + logical :: requires_src_info = .false. !< Unknown + real :: src_var_unit_conversion = 1.0 !< This factor depends on the tracer. Ask Jasmin + real :: src_var_valid_min = 0.0 !< Unknown + end type g_tracer_type + + !> Unknown + type g_diag_type + integer :: dummy !< A dummy member, not part of the API + end type g_diag_type + + !> The following type fields are common to ALL generic tracers and hence has to be instantiated only once + type g_tracer_common +! type(g_diag_ctrl) :: diag_CS !< Unknown + !> Domain extents + integer :: isd !< Start index of the data domain in the i-direction + integer :: jsd !< Start index of the data domain in the j-direction + end type g_tracer_common + + !> Unknown dangerous module data! + type(g_tracer_common), target, save :: g_tracer_com + + public :: g_tracer_type + public :: g_tracer_flux_init + public :: g_tracer_set_values + public :: g_tracer_get_values + public :: g_tracer_get_pointer + public :: g_tracer_get_common + public :: g_tracer_set_common + public :: g_tracer_set_csdiag + public :: g_tracer_send_diag + public :: g_tracer_get_name + public :: g_tracer_get_alias + public :: g_tracer_get_next + public :: g_tracer_is_prog + public :: g_diag_type + public :: g_tracer_get_obc_segment_props + + !> Set the values of various (array) members of the tracer node g_tracer_type + !! + !! This function is overloaded to set the values of the following member variables + interface g_tracer_set_values + module procedure g_tracer_set_real + module procedure g_tracer_set_2D + module procedure g_tracer_set_3D + module procedure g_tracer_set_4D + end interface + + !> Reverse of interface g_tracer_set_values for getting the tracer member arrays in the argument value + !! + !! This means "get the values of array %field_name for tracer tracer_name and put them in argument array_out" + interface g_tracer_get_values + module procedure g_tracer_get_4D_val + module procedure g_tracer_get_3D_val + module procedure g_tracer_get_2D_val + module procedure g_tracer_get_real + module procedure g_tracer_get_string + end interface + + !> Return the pointer to the requested field of a particular tracer + !! + !! This means "get the pointer of array %field_name for tracer tracer_name in argument array_ptr" + interface g_tracer_get_pointer + module procedure g_tracer_get_4D + module procedure g_tracer_get_3D + module procedure g_tracer_get_2D + end interface + +contains + + !> Unknown + subroutine g_tracer_flux_init(g_tracer, verbosity) + type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity + end subroutine g_tracer_flux_init + + !> Unknown + subroutine g_tracer_set_csdiag(diag_CS) + type(g_diag_ctrl), target,intent(in) :: diag_CS !< Unknown + end subroutine g_tracer_set_csdiag + + subroutine g_tracer_set_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) + integer, intent(in) :: isc !< Computation start index in i direction + integer, intent(in) :: iec !< Computation end index in i direction + integer, intent(in) :: jsc !< Computation start index in j direction + integer, intent(in) :: jec !< Computation end index in j direction + integer, intent(in) :: isd !< Data start index in i direction + integer, intent(in) :: ied !< Data end index in i direction + integer, intent(in) :: jsd !< Data start index in j direction + integer, intent(in) :: jed !< Data end index in j direction + integer, intent(in) :: nk !< Number of levels in k direction + integer, intent(in) :: ntau !< Unknown + integer, intent(in) :: axes(3) !< Domain axes? + real, dimension(isd:,jsd:,:),intent(in) :: grid_tmask !< Unknown + integer,dimension(isd:,jsd:),intent(in) :: grid_kmt !< Unknown + type(time_type), intent(in) :: init_time !< Unknown + end subroutine g_tracer_set_common + + subroutine g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,& + axes,grid_tmask,grid_mask_coast,grid_kmt,init_time,diag_CS) + integer, intent(out) :: isc !< Computation start index in i direction + integer, intent(out) :: iec !< Computation end index in i direction + integer, intent(out) :: jsc !< Computation start index in j direction + integer, intent(out) :: jec !< Computation end index in j direction + integer, intent(out) :: isd !< Data start index in i direction + integer, intent(out) :: ied !< Data end index in i direction + integer, intent(out) :: jsd !< Data start index in j direction + integer, intent(out) :: jed !< Data end index in j direction + integer, intent(out) :: nk !< Number of levels in k direction + integer, intent(out) :: ntau !< Unknown + integer, optional, intent(out) :: axes(3) !< Unknown + type(time_type), optional, intent(out) :: init_time !< Unknown + real, optional, dimension(:,:,:), pointer :: grid_tmask !< Unknown + integer, optional, dimension(:,:), pointer :: grid_mask_coast !< Unknown + integer, optional, dimension(:,:), pointer :: grid_kmt !< Unknown + type(g_diag_ctrl), optional, pointer :: diag_CS !< Unknown + + isc = -1 + iec = -1 + jsc = -1 + jec = -1 + isd = -1 + ied = -1 + jsd = -1 + jed = -1 + nk = -1 + ntau = -1 + end subroutine g_tracer_get_common + + !> Unknown + subroutine g_tracer_get_4D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + real, dimension(:,:,:,:), pointer :: array_ptr !< Unknown + end subroutine g_tracer_get_4D + + !> Unknown + subroutine g_tracer_get_3D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + real, dimension(:,:,:), pointer :: array_ptr !< Unknown + end subroutine g_tracer_get_3D + + !> Unknown + subroutine g_tracer_get_2D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + real, dimension(:,:), pointer :: array_ptr !< Unknown + end subroutine g_tracer_get_2D + + !> Unknown + subroutine g_tracer_get_4D_val(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + integer, intent(in) :: isd !< Unknown + integer, intent(in) :: jsd !< Unknown + real, dimension(isd:,jsd:,:,:), intent(out):: array !< Unknown + + array(:,:,:,:) = -1. + end subroutine g_tracer_get_4D_val + + !> Unknown + subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,positive) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + integer, intent(in) :: isd !< Unknown + integer, intent(in) :: jsd !< Unknown + integer, optional, intent(in) :: ntau !< Unknown + logical, optional, intent(in) :: positive !< Unknown + real, dimension(isd:,jsd:,:), intent(out):: array !< Unknown + character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' + + array(:,:,:) = -1. + end subroutine g_tracer_get_3D_val + + !> Unknown + subroutine g_tracer_get_2D_val(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + integer, intent(in) :: isd !< Unknown + integer, intent(in) :: jsd !< Unknown + real, dimension(isd:,jsd:), intent(out):: array !< Unknown + + array(:,:) = -1. + end subroutine g_tracer_get_2D_val + + !> Unknown + subroutine g_tracer_get_real(g_tracer_list,name,member,value) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + real, intent(out):: value !< Unknown + + value = -1 + end subroutine g_tracer_get_real + + !> Unknown + subroutine g_tracer_get_string(g_tracer_list,name,member,string) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + character(len=fm_string_len), intent(out) :: string !< Unknown + + string = "" + end subroutine g_tracer_get_string + + !> Unknown + subroutine g_tracer_set_2D(g_tracer_list,name,member,array,isd,jsd,weight) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + integer, intent(in) :: isd !< Unknown + integer, intent(in) :: jsd !< Unknown + real, dimension(isd:,jsd:),intent(in) :: array !< Unknown + real, optional ,intent(in) :: weight !< Unknown + end subroutine g_tracer_set_2D + + !> Unknown + subroutine g_tracer_set_3D(g_tracer_list,name,member,array,isd,jsd,ntau) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + integer, intent(in) :: isd !< Unknown + integer, intent(in) :: jsd !< Unknown + integer, optional, intent(in) :: ntau !< Unknown + real, dimension(isd:,jsd:,:), intent(in) :: array !< Unknown + end subroutine g_tracer_set_3D + + !> Unknown + subroutine g_tracer_set_4D(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + integer, intent(in) :: isd !< Unknown + integer, intent(in) :: jsd !< Unknown + real, dimension(isd:,jsd:,:,:), intent(in) :: array !< Unknown + end subroutine g_tracer_set_4D + + !> Unknown + subroutine g_tracer_set_real(g_tracer_list,name,member,value) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list !< Unknown + real, intent(in) :: value !< Unknown + end subroutine g_tracer_set_real + + subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) + type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list + type(time_type), intent(in) :: model_time !< Time + integer, intent(in) :: tau !< The time step for the %field 4D field to be reported + end subroutine g_tracer_send_diag + + !> Unknown + subroutine g_tracer_get_name(g_tracer,string) + type(g_tracer_type), pointer :: g_tracer !< Unknown + character(len=*), intent(out) :: string !< Unknown + + string = "" + end subroutine g_tracer_get_name + + !> Unknown + subroutine g_tracer_get_alias(g_tracer,string) + type(g_tracer_type), pointer :: g_tracer !< Unknown + character(len=*), intent(out) :: string !< Unknown + + string = "" + end subroutine g_tracer_get_alias + + !> Is the tracer prognostic? + function g_tracer_is_prog(g_tracer) + logical :: g_tracer_is_prog + type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node + + g_tracer_is_prog = .false. + end function g_tracer_is_prog + + !> get the next tracer in the list + subroutine g_tracer_get_next(g_tracer,g_tracer_next) + type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node + type(g_tracer_type), pointer :: g_tracer_next !< Pointer to the next tracer node in the list + end subroutine g_tracer_get_next + + !> get obc segment properties for each tracer + subroutine g_tracer_get_obc_segment_props(g_tracer_list, name, obc_has, src_file, src_var_name,lfac_in,lfac_out) + type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list + character(len=*), intent(in) :: name !< tracer name + logical, intent(out):: obc_has !< .true. if This tracer has OBC + real, optional,intent(out):: lfac_in !< OBC reservoir inverse lengthscale factor + real, optional,intent(out):: lfac_out !< OBC reservoir inverse lengthscale factor + character(len=*),optional,intent(out):: src_file !< OBC source file + character(len=*),optional,intent(out):: src_var_name !< OBC source variable in file + + obc_has = .false. + end subroutine g_tracer_get_obc_segment_props + + !>Vertical Diffusion of a tracer node + !! + !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field + !! for a tracer node.This is ported from GOLD (vertdiff) and simplified + !! Since the surface flux from the atmosphere (%stf) has the units of mol/m^2/sec the resulting + !! tracer concentration has units of mol/Kg + subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau, mom) + type(g_tracer_type), pointer :: g_tracer !< Unknown + !> Layer thickness before entrainment, in m or kg m-2. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: h_old + !> The amount of fluid entrained from the layer above, in H. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: ea + !> The amount of fluid entrained from the layer below, in H. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: eb + real, intent(in) :: dt !< The amount of time covered by this call, in s. + real, intent(in) :: kg_m2_to_H !< A conversion factor that translates kg m-2 into + !! the units of h_old (H) + real, intent(in) :: m_to_H !< A conversion factor that translates m into the units + !! of h_old (H). + integer, intent(in) :: tau !< Unknown + logical, intent(in), optional :: mom !< Unknown + end subroutine g_tracer_vertdiff_G + +end module g_tracer_utils diff --git a/config_src/external/ODA_hooks/README.md b/config_src/external/ODA_hooks/README.md new file mode 100644 index 0000000000..b26731a463 --- /dev/null +++ b/config_src/external/ODA_hooks/README.md @@ -0,0 +1,9 @@ +ODA_hooks +========= + +These APIs reflect those for the ocean data assimilation hooks similar to https://github.com/MJHarrison-GFDL/MOM6_DA_hooks + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. + +- kdtree.f90 - would come from https://github.com/travissluka/geoKdTree +- ocean_da_core.F90, ocean_da_types.F90, write_ocean_obs.F90 were copied from https://github.com/MJHarrison-GFDL/MOM6_DA_hooks diff --git a/config_src/external/ODA_hooks/kdtree.f90 b/config_src/external/ODA_hooks/kdtree.f90 new file mode 100644 index 0000000000..a27716dde1 --- /dev/null +++ b/config_src/external/ODA_hooks/kdtree.f90 @@ -0,0 +1,12 @@ +!> A null version of K-d tree from geoKdTree +module kdtree + implicit none + private + + public :: kd_root + + !> A K-d tree tpe + type kd_root + integer :: dummy !< To stop a compiler from doing nothing + end type kd_root +end module kdtree diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90 new file mode 100644 index 0000000000..769e44b2aa --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_core.F90 @@ -0,0 +1,47 @@ +!> A set of dummy interfaces for compiling the MOM6 DA driver code. +module ocean_da_core_mod + ! MOM modules + use MOM_domains, only : MOM_domain_type, domain2D + use MOM_time_manager, only : time_type, set_time, get_date + ! ODA_tools modules + use ocean_da_types_mod, only : ocean_profile_type, grid_type + use kdtree, only : kd_root + + implicit none + private + public :: ocean_da_core_init + public :: get_profiles + +contains + + !> Initializes the MOM6 DA driver code. + subroutine ocean_da_core_init(Domain, global_grid, Profiles, model_time) + type(domain2D), pointer, intent(in) :: Domain !< A MOM domain type + type(grid_type), pointer, intent(in) :: global_grid !< The global ODA horizontal grid type + type(ocean_profile_type), pointer :: Profiles !< This is an unstructured recursive list of profiles + !! which are either within the localized domain corresponding + !! to the Domain argument, or the global profile list (type). + type(time_type), intent(in) :: model_time !< The current model time type. + + + + Profiles=>NULL() + return + end subroutine ocean_da_core_init + + + !> Get profiles obs within the current analysis interval + subroutine get_profiles(model_time, Profiles, Current_profiles) + type(time_type), intent(in) :: model_time !< The current analysis time. + type(ocean_profile_type), pointer :: Profiles !< The full recursive list of profiles. + type(ocean_profile_type), pointer :: Current_profiles !< A returned list of profiles for the + !! current analysis step. + + Profiles=>NULL() + Current_Profiles=>NULL() + + return + end subroutine get_profiles + + +end module ocean_da_core_mod diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 new file mode 100644 index 0000000000..a99f1ae669 --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -0,0 +1,88 @@ +!> Dummy aata structures and methods for ocean data assimilation. +module ocean_da_types_mod + +use MOM_time_manager, only : time_type + +implicit none ; private + +!> Example type for ocean ensemble DA state +type, public :: OCEAN_CONTROL_STRUCT + integer :: ensemble_size !< ensemble size + real, pointer, dimension(:,:,:) :: SSH => NULL() !< sea surface height across ensembles [m] + real, pointer, dimension(:,:,:,:) :: h => NULL() !< layer thicknesses across ensembles [m or kg m-2] + real, pointer, dimension(:,:,:,:) :: T => NULL() !< layer potential temperature across ensembles [degC] + real, pointer, dimension(:,:,:,:) :: S => NULL() !< layer salinity across ensembles [ppt] + real, pointer, dimension(:,:,:,:) :: U => NULL() !< layer zonal velocity across ensembles [m s-1] + real, pointer, dimension(:,:,:,:) :: V => NULL() !< layer meridional velocity across ensembles [m s-1] +end type OCEAN_CONTROL_STRUCT + +!> Example of a profile type +type, public :: ocean_profile_type + integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) + logical :: initialized !< a True value indicates that this profile has been allocated for use + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are + !! co-located in space-time + integer :: ensemble_size !< size of the ensemble of model states used in association with this profile + integer :: num_variables !< number of measurement types associated with this profile. + integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) + !! and instrument type (XBT, CDT, etc.) + integer :: levels !< number of levels in the current profile + integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + integer :: profile_flag !< an overall flag for the profile + real :: lat !< latitude [degrees_N] + real :: lon !< longitude [degrees_E] + logical :: accepted !< logical flag to disable a profile + type(time_type) :: time_window !< The time window associated with this profile + real, pointer, dimension(:) :: obs_error !< The observation error by variable [various units] + real :: loc_dist !< The impact radius of this observation [m] + type(ocean_profile_type), pointer :: next => NULL() !< all profiles are stored as linked list. + type(ocean_profile_type), pointer :: prev => NULL() !< previous + type(ocean_profile_type), pointer :: cnext => NULL() !< current profiles are stored as linked list. + type(ocean_profile_type), pointer :: cprev => NULL() !< previous + integer :: nbr_xi !< x nearest neighbor model gridpoint for the profile + integer :: nbr_yi !< y nearest neighbor model gridpoint for the profile + real :: nbr_dist !< distance to nearest neighbor model gridpoint [m] + logical :: compute !< profile is within current compute domain + real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] + real, dimension(:,:), pointer :: data => NULL() !< data by variable type [various units] + integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type + real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess + real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis + type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator + type(time_type) :: time !< profile time type + real :: i_index !< model longitude indices respectively + real :: j_index !< model latitude indices respectively + real, dimension(:,:), pointer :: k_index !< model depth indices + type(time_type) :: tdiff !< difference between model time and observation time + character(len=128) :: filename !< a filename +end type ocean_profile_type + +!> Example forward operator type. +type, public :: forward_operator_type + integer :: num !< how many? + integer, dimension(2) :: state_size !< for + integer, dimension(:), pointer :: state_var_index !< for flattened data + integer, dimension(:), pointer :: i_index !< i-dimension index + integer, dimension(:), pointer :: j_index !< j-dimension index + real, dimension(:), pointer :: coef !< coefficient +end type forward_operator_type + +!> Grid type for DA +type, public :: grid_type + real, pointer, dimension(:,:) :: x => NULL() !< x + real, pointer, dimension(:,:) :: y => NULL() !< y + real, pointer, dimension(:,:,:) :: z => NULL() !< z + real, pointer, dimension(:,:,:) :: h => NULL() !< h + real, pointer, dimension(:,:) :: basin_mask => NULL() !< basin mask + real, pointer, dimension(:,:,:) :: mask => NULL() !< land mask? + real, pointer, dimension(:,:) :: bathyT => NULL() !< bathymetry at T points [m] + logical :: tripolar_N !< True for tripolar grids + integer :: ni !< ni + integer :: nj !< nj + integer :: nk !< nk +end type grid_type + +end module ocean_da_types_mod diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 new file mode 100644 index 0000000000..51b5d2a1d7 --- /dev/null +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -0,0 +1,46 @@ +!> Dummy interfaces for writing ODA data +module write_ocean_obs_mod + +use ocean_da_types_mod, only : ocean_profile_type +use MOM_time_manager, only : time_type, get_time, set_date + +implicit none ; private + +public :: open_profile_file, write_profile, close_profile_file, write_ocean_obs_init + +contains + +!> Open a profile file +integer function open_profile_file(name, nvar, grid_lon, grid_lat, thread, fset) + character(len=*), intent(in) :: name !< File name + integer, intent(in), optional :: nvar !< Number of variables + real, dimension(:), optional, intent(in) :: grid_lon !< Longitude [degreeE] + real, dimension(:), optional, intent(in) :: grid_lat !< Latitude [degreeN] + integer, optional, intent(in) :: thread !< Thread number + integer, optional, intent(in) :: fset !< File set + + open_profile_file=-1 +end function open_profile_file + +!> Write a profile +subroutine write_profile(unit,profile) + integer, intent(in) :: unit !< File unit + type(ocean_profile_type), intent(in) :: profile !< Profile to write + + return +end subroutine write_profile + +!> Close a profile file +subroutine close_profile_file(unit) + integer, intent(in) :: unit !< File unit + + return +end subroutine close_profile_file + +!> Initialize write_ocean_obs module +subroutine write_ocean_obs_init() + + return +end subroutine write_ocean_obs_init + +end module write_ocean_obs_mod diff --git a/config_src/external/README.md b/config_src/external/README.md new file mode 100644 index 0000000000..ff70f35915 --- /dev/null +++ b/config_src/external/README.md @@ -0,0 +1,10 @@ +config_src/external +=================== + +Subdirectories in here provide null versions of external packages that +can be called by, or used with, MOM6 but that are not needed in all +configurations/executables. + +The APIs in these modules should be consistent with the actual external +package. To build with the actual external package include it in the +search path for your build system and remove the associated null version. diff --git a/config_src/external/database_comms/MOM_database_comms.F90 b/config_src/external/database_comms/MOM_database_comms.F90 new file mode 100644 index 0000000000..4c3eb38b5c --- /dev/null +++ b/config_src/external/database_comms/MOM_database_comms.F90 @@ -0,0 +1,37 @@ +!> Contains routines necessary to initialize communication with a database +module MOM_database_comms +! This file is part of MOM6. See LICENSE.md for the license. +use MOM_file_parser, only : param_file_type +use MOM_error_handler, only : MOM_error, WARNING +use database_client_interface, only : dbclient_type + +implicit none; private + +!> Control structure to store Database communication related parameters and objects +type, public :: dbcomms_CS_type + type(dbclient_type) :: client !< The Database client itself + logical :: use_dbclient !< If True, use Database within MOM6 + logical :: colocated !< If True, the orchestrator was setup in 'co-located' mode + logical :: cluster !< If True, the orchestrator has three shards or more + integer :: colocated_stride !< Sets which ranks will load the model from the file + !! e.g. mod(rank,colocated_stride) == 0 +end type dbcomms_CS_type + +public :: database_comms_init +public :: dbclient_type + +contains + +subroutine database_comms_init(param_file, CS, client_in) + type(param_file_type), intent(in ) :: param_file !< Parameter file structure + type(dbcomms_CS_type), intent(inout) :: CS !< Control structure for Database + type(dbclient_type), optional, intent(in ) :: client_in !< If present, use a previously initialized + !! Database client + + call MOM_error(WARNING,"dbcomms_init was compiled using the dummy module. If this was\n"//& + "a mistake, please follow the instructions in:\n"//& + "MOM6/config_src/external/dbclient/README.md") +end subroutine database_comms_init + +end module MOM_database_comms + diff --git a/config_src/external/database_comms/README.md b/config_src/external/database_comms/README.md new file mode 100644 index 0000000000..05f1f07259 --- /dev/null +++ b/config_src/external/database_comms/README.md @@ -0,0 +1,25 @@ +# Overview +This module is designed to be used in conjunction with the SmartSim and +SmartRedis libraries found at https://github.com/CrayLabs/. These +libraries are used to perform machine-learning inference and online +analysis using a Redis-based database. + +An earlier implementation of these routines was used in Partee et al. [2022]: +"Using Machine Learning at scale in numerical simulations with SmartSim: +An application to ocean climate modeling" (doi.org/10.1016/j.jocs.2022.101707) +to predict eddy kinetic energy for use in the MEKE module. The additional +scripts and installation instructions for compiling MOM6 for this case can +be found at: https://github.com/CrayLabs/NCAR_ML_EKE/. The substantive +code in the new implementation is part of `MOM_MEKE.F90`. + +# File description + +- `MOM_database_comms` contains just method signatures and elements of the + control structure that are imported elsewhere within the primary MOM6 + code. This includes: `dbcomms_CS_type`, `dbclient_type`, and `database_comms_init` + +- `database_client_interface.F90` contains the methods for a communication client + to transfer data and/or commands between MOM6 and a remote database. This is + roughly based on the SmartRedis library, though only the methods that are most + likely to be used with MOM6 are retained. This is to ensure that the API can be + tested without requiring MOM6 users to compile in the the full library. diff --git a/config_src/external/database_comms/database_client_interface.F90 b/config_src/external/database_comms/database_client_interface.F90 new file mode 100644 index 0000000000..8b05b83daf --- /dev/null +++ b/config_src/external/database_comms/database_client_interface.F90 @@ -0,0 +1,833 @@ +module database_client_interface + +! This file is part of MOM6. See LICENSE.md for the license. + use iso_fortran_env, only : int8, int16, int32, int64, real32, real64 + + implicit none; private + + !> Dummy type for dataset + type, public :: dataset_type + private + end type dataset_type + + !> Stores all data and methods associated with the communication client that is used to communicate with the database + type, public :: dbclient_type + private + + contains + + ! Public procedures + !> Puts a tensor into the database for a variety of datatypes + generic :: put_tensor => put_tensor_float_1d, put_tensor_float_2d, put_tensor_float_3d, put_tensor_float_4d, & + put_tensor_double_1d, put_tensor_double_2d, put_tensor_double_3d, put_tensor_double_4d, & + put_tensor_int32_1d, put_tensor_int32_2d, put_tensor_int32_3d, put_tensor_int32_4d + !> Retrieve the tensor in the database into already allocated memory for a variety of datatypesm + generic :: unpack_tensor => unpack_tensor_float_1d, unpack_tensor_float_2d, & + unpack_tensor_float_3d, unpack_tensor_float_4d, & + unpack_tensor_double_1d, unpack_tensor_double_2d, & + unpack_tensor_double_3d, unpack_tensor_double_4d, & + unpack_tensor_int32_1d, unpack_tensor_int32_2d, & + unpack_tensor_int32_3d, unpack_tensor_int32_4d + + !> Decode a response code from an API function + procedure :: SR_error_parser + !> Initializes a new instance of the communication client + procedure :: initialize => initialize_client + !> Check if a communication client has been initialized + procedure :: isinitialized + !> Destructs a new instance of the communication client + procedure :: destructor + !> Rename a tensor within the database + procedure :: rename_tensor + !> Delete a tensor from the database + procedure :: delete_tensor + !> Copy a tensor within the database to a new name + procedure :: copy_tensor + !> Set a model from a file + procedure :: set_model_from_file + !> Set a model from a file on a system with multiple GPUs + procedure :: set_model_from_file_multigpu + !> Set a model from a byte string that has been loaded within the application + procedure :: set_model + !> Set a model from a byte string that has been loaded within the application on a system with multiple GPUs + procedure :: set_model_multigpu + !> Retrieve the model as a byte string + procedure :: get_model + !> Set a script from a specified file + procedure :: set_script_from_file + !> Set a script from a specified file on a system with multiple GPUS + procedure :: set_script_from_file_multigpu + !> Set a script as a byte or text string + procedure :: set_script + !> Set a script as a byte or text string on a system with multiple GPUs + procedure :: set_script_multigpu + !> Retrieve the script from the database + procedure :: get_script + !> Run a script that has already been stored in the database + procedure :: run_script + !> Run a script that has already been stored in the database with multiple GPUs + procedure :: run_script_multigpu + !> Run a model that has already been stored in the database + procedure :: run_model + !> Run a model that has already been stored in the database with multiple GPUs + procedure :: run_model_multigpu + !> Remove a script from the database + procedure :: delete_script + !> Remove a script from the database with multiple GPUs + procedure :: delete_script_multigpu + !> Remove a model from the database + procedure :: delete_model + !> Remove a model from the database with multiple GPUs + procedure :: delete_model_multigpu + !> Put a communication dataset into the database + procedure :: put_dataset + !> Retrieve a communication dataset from the database + procedure :: get_dataset + !> Rename the dataset within the database + procedure :: rename_dataset + !> Copy a dataset stored in the database into another name + procedure :: copy_dataset + !> Delete the dataset from the database + procedure :: delete_dataset + + ! Private procedures + !> Put a 1d, 32-bit real tensor into database + procedure, private :: put_tensor_float_1d + !> Put a 2d, 32-bit real tensor into database + procedure, private :: put_tensor_float_2d + !> Put a 3d, 32-bit real tensor into database + procedure, private :: put_tensor_float_3d + !> Put a 4d, 32-bit real tensor into database + procedure, private :: put_tensor_float_4d + !> Put a 1d, 64-bit real tensor into database + procedure, private :: put_tensor_double_1d + !> Put a 2d, 64-bit real tensor into database + procedure, private :: put_tensor_double_2d + !> Put a 3d, 64-bit real tensor into database + procedure, private :: put_tensor_double_3d + !> Put a 4d, 64-bit real tensor into database + procedure, private :: put_tensor_double_4d + !> Put a 1d, 32-bit integer tensor into database + procedure, private :: put_tensor_int32_1d + !> Put a 2d, 32-bit integer tensor into database + procedure, private :: put_tensor_int32_2d + !> Put a 3d, 32-bit integer tensor into database + procedure, private :: put_tensor_int32_3d + !> Put a 4d, 32-bit integer tensor into database + procedure, private :: put_tensor_int32_4d + !> Unpack a 1d, 32-bit real tensor from the database + procedure, private :: unpack_tensor_float_1d + !> Unpack a 2d, 32-bit real tensor from the database + procedure, private :: unpack_tensor_float_2d + !> Unpack a 3d, 32-bit real tensor from the database + procedure, private :: unpack_tensor_float_3d + !> Unpack a 4d, 32-bit real tensor from the database + procedure, private :: unpack_tensor_float_4d + !> Unpack a 1d, 64-bit real tensor from the database + procedure, private :: unpack_tensor_double_1d + !> Unpack a 2d, 64-bit real tensor from the database + procedure, private :: unpack_tensor_double_2d + !> Unpack a 3d, 64-bit real tensor from the database + procedure, private :: unpack_tensor_double_3d + !> Unpack a 4d, 64-bit real tensor from the database + procedure, private :: unpack_tensor_double_4d + !> Unpack a 1d, 32-bit integer tensor from the database + procedure, private :: unpack_tensor_int32_1d + !> Unpack a 2d, 32-bit integer tensor from the database + procedure, private :: unpack_tensor_int32_2d + !> Unpack a 3d, 32-bit integer tensor from the database + procedure, private :: unpack_tensor_int32_3d + !> Unpack a 4d, 32-bit integer tensor from the database + procedure, private :: unpack_tensor_int32_4d + + end type dbclient_type + + contains + + !> Decode a response code from an API function + function SR_error_parser(self, response_code) result(is_error) + class(dbclient_type), intent(in) :: self !< Receives the initialized client + integer, intent(in) :: response_code !< The response code to decode + logical :: is_error !< Indicates whether this is an error response + + is_error = .true. + end function SR_error_parser + + !> Initializes a new instance of a communication client + function initialize_client(self, cluster) + integer :: initialize_client + class(dbclient_type), intent(inout) :: self !< Receives the initialized client + logical, optional, intent(in ) :: cluster !< If true, client uses a database cluster (Default: .false.) + + initialize_client = -1 + end function initialize_client + + !> Check whether the client has been initialized + logical function isinitialized(this) + class(dbclient_type) :: this + isinitialized = .false. + end function isinitialized + + !> A destructor for the communication client + function destructor(self) + integer :: destructor + class(dbclient_type), intent(inout) :: self + + destructor = -1 + end function destructor + + !> Put a 32-bit real 1d tensor into the database + function put_tensor_float_1d(self, name, data, dims) result(code) + real(kind=real32), dimension(:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_float_1d + + !> Put a 32-bit real 2d tensor into the database + function put_tensor_float_2d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_float_2d + + !> Put a 32-bit real 3d tensor into the database + function put_tensor_float_3d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_float_3d + + !> Put a 32-bit real 4d tensor into the database + function put_tensor_float_4d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_float_4d + + !> Put a 64-bit real 1d tensor into the database + function put_tensor_double_1d(self, name, data, dims) result(code) + real(kind=real64), dimension(:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_double_1d + + !> Put a 64-bit real 2d tensor into the database + function put_tensor_double_2d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_double_2d + + !> Put a 64-bit real 3d tensor into the database + function put_tensor_double_3d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_double_3d + + !> Put a 64-bit real 4d tensor into the database + function put_tensor_double_4d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_double_4d + + !> Put a 32-bit integer 1d tensor into the database + function put_tensor_int32_1d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_int32_1d + + !> Put a 32-bit integer 2d tensor into the database + function put_tensor_int32_2d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_int32_2d + + !> Put a 32-bit integer 3d tensor into the database + function put_tensor_int32_3d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_int32_3d + + !> Put a 32-bit integer 4d tensor into the database + function put_tensor_int32_4d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_int32_4d + + !> Unpack a 32-bit real 1d tensor from the database + function unpack_tensor_float_1d(self, name, data, dims) result(code) + real(kind=real32), dimension(:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:) = -1. + end function unpack_tensor_float_1d + + !> Unpack a 32-bit real 2d tensor from the database + function unpack_tensor_float_2d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:) = -1. + end function unpack_tensor_float_2d + + !> Unpack a 32-bit real 3d tensor from the database + function unpack_tensor_float_3d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:) = -1. + end function unpack_tensor_float_3d + + !> Unpack a 32-bit real 4d tensor from the database + function unpack_tensor_float_4d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:,:) = -1. + end function unpack_tensor_float_4d + + !> Unpack a 64-bit real 1d tensor from the database + function unpack_tensor_double_1d(self, name, data, dims) result(code) + real(kind=real64), dimension(:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:) = -1. + end function unpack_tensor_double_1d + + !> Unpack a 64-bit real 2d tensor from the database + function unpack_tensor_double_2d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:) = -1. + end function unpack_tensor_double_2d + + !> Unpack a 64-bit real 3d tensor from the database + function unpack_tensor_double_3d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:) = -1. + end function unpack_tensor_double_3d + + !> Unpack a 64-bit real 4d tensor from the database + function unpack_tensor_double_4d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:,:) = -1. + end function unpack_tensor_double_4d + + !> Unpack a 32-bit integer 1d tensor from the database + function unpack_tensor_int32_1d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:) = -1_int32 + end function unpack_tensor_int32_1d + + !> Unpack a 32-bit integer 2d tensor from the database + function unpack_tensor_int32_2d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:) = -1_int32 + end function unpack_tensor_int32_2d + + !> Unpack a 32-bit integer 3d tensor from the database + function unpack_tensor_int32_3d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:) = -1_int32 + end function unpack_tensor_int32_3d + + !> Unpack a 32-bit integer 4d tensor from the database + function unpack_tensor_int32_4d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:,:) = -1_int32 + end function unpack_tensor_int32_4d + + !> Move a tensor to a new name + function rename_tensor(self, old_name, new_name) result(code) + class(dbclient_type), intent(in) :: self !< The initialized Fortran communication client + character(len=*), intent(in) :: old_name !< The current name for the tensor + !! excluding null terminating character + character(len=*), intent(in) :: new_name !< The new tensor name + integer :: code + + code = -1 + end function rename_tensor + + !> Delete a tensor + function delete_tensor(self, name) result(code) + class(dbclient_type), intent(in) :: self !< The initialized Fortran communication client + character(len=*), intent(in) :: name !< The name associated with the tensor + integer :: code + + code = -1 + end function delete_tensor + + !> Copy a tensor to the destination name + function copy_tensor(self, src_name, dest_name) result(code) + class(dbclient_type), intent(in) :: self !< The initialized Fortran communication client + character(len=*), intent(in) :: src_name !< The name associated with the tensor + !! excluding null terminating character + character(len=*), intent(in) :: dest_name !< The new tensor name + integer :: code + + code = -1 + end function copy_tensor + + !> Retrieve the model from the database + function get_model(self, name, model) result(code) + class(dbclient_type), intent(in ) :: self !< An initialized communication client + character(len=*), intent(in ) :: name !< The name associated with the model + character(len=*), intent( out) :: model !< The model as a continuous buffer + integer :: code + + code = -1 + model = "" + end function get_model + + !> Load the machine learning model from a file and set the configuration + function set_model_from_file(self, name, model_file, backend, device, batch_size, min_batch_size, tag, & + inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), intent(in) :: model_file !< The file storing the model + character(len=*), intent(in) :: backend !< The name of the backend + !! (TF, TFLITE, TORCH, ONNX) + character(len=*), intent(in) :: device !< The name of the device + !! (CPU, GPU, GPU:0, GPU:1...) + integer, optional, intent(in) :: batch_size !< The batch size for model execution + integer, optional, intent(in) :: min_batch_size !< The minimum batch size for model execution + character(len=*), optional, intent(in) :: tag !< A tag to attach to the model for + !! information purposes + character(len=*), dimension(:), optional, intent(in) :: inputs !< One or more names of model + !! input nodes (TF models) + character(len=*), dimension(:), optional, intent(in) :: outputs !< One or more names of model + !! output nodes (TF models) + integer :: code + + code = -1 + end function set_model_from_file + + !> Load the machine learning model from a file and set the configuration for use in multi-GPU systems + function set_model_from_file_multigpu(self, name, model_file, backend, first_gpu, num_gpus, batch_size, & + min_batch_size, tag, inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), intent(in) :: model_file !< The file storing the model + character(len=*), intent(in) :: backend !< The name of the backend + !! (TF, TFLITE, TORCH, ONNX) + integer, intent(in) :: first_gpu !< The first GPU (zero-based) + !! to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer, optional, intent(in) :: batch_size !< The batch size for model execution + integer, optional, intent(in) :: min_batch_size !< The minimum batch size for model execution + character(len=*), optional, intent(in) :: tag !< A tag to attach to the model for + !! information purposes + character(len=*), dimension(:), optional, intent(in) :: inputs !< One or more names of model + !! input nodes (TF models) + character(len=*), dimension(:), optional, intent(in) :: outputs !< One or more names of model + !! output nodes (TF models) + integer :: code + + code = -1 + end function set_model_from_file_multigpu + + !> Establish a model to run + function set_model(self, name, model, backend, device, batch_size, min_batch_size, tag, & + inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), intent(in) :: model !< The binary representation of the model + character(len=*), intent(in) :: backend !< The name of the backend (TF, TFLITE, TORCH, ONNX) + character(len=*), intent(in) :: device !< The name of the device (CPU, GPU, GPU:0, GPU:1...) + integer, intent(in) :: batch_size !< The batch size for model execution + integer, intent(in) :: min_batch_size !< The minimum batch size for model execution + character(len=*), intent(in) :: tag !< A tag to attach to the model for + !! information purposes + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of model input nodes (TF models) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of model output nodes (TF models) + integer :: code + + code = -1 + end function set_model + + !> Set a model from a byte string to run on a system with multiple GPUs + function set_model_multigpu(self, name, model, backend, first_gpu, num_gpus, batch_size, min_batch_size, tag, & + inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), intent(in) :: model !< The binary representation of the model + character(len=*), intent(in) :: backend !< The name of the backend (TF, TFLITE, TORCH, ONNX) + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer, intent(in) :: batch_size !< The batch size for model execution + integer, intent(in) :: min_batch_size !< The minimum batch size for model execution + character(len=*), intent(in) :: tag !< A tag to attach to the model for + !! information purposes + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of model input nodes (TF models) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of model output nodes (TF models) + integer :: code + + code = -1 + end function set_model_multigpu + + !> Run a model in the database using the specified input and output tensors + function run_model(self, name, inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of model input nodes (TF models) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of model output nodes (TF models) + integer :: code + + code = -1 + end function run_model + + !> Run a model in the database using the specified input and output tensors in a multi-GPU system + function run_model_multigpu(self, name, inputs, outputs, offset, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of model input nodes (TF models) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of model output nodes (TF models) + integer, intent(in) :: offset !< Index of the current image, such as a processor ID + !! or MPI rank + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function run_model_multigpu + + !> Remove a model from the database + function delete_model(self, name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to remove the model + integer :: code + + code = -1 + end function delete_model + + !> Remove a model from the database + function delete_model_multigpu(self, name, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to remove the model + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function delete_model_multigpu + + !> Retrieve the script from the database + function get_script(self, name, script) result(code) + class(dbclient_type), intent(in ) :: self !< An initialized communication client + character(len=*), intent(in ) :: name !< The name to use to place the script + character(len=*), intent( out) :: script !< The script as a continuous buffer + integer :: code + + code = -1 + script = "" + end function get_script + + !> Set a script (from file) in the database for future execution + function set_script_from_file(self, name, device, script_file) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: device !< The name of the device (CPU, GPU, GPU:0, GPU:1...) + character(len=*), intent(in) :: script_file !< The file storing the script + integer :: code + + code = -1 + end function set_script_from_file + + !> Set a script (from file) in the database for future execution in a multi-GPU system + function set_script_from_file_multigpu(self, name, script_file, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: script_file !< The file storing the script + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function set_script_from_file_multigpu + + !> Set a script (from buffer) in the database for future execution + function set_script(self, name, device, script) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: device !< The name of the device (CPU, GPU, GPU:0, GPU:1...) + character(len=*), intent(in) :: script !< The file storing the script + integer :: code + + code = -1 + end function set_script + + !> Set a script (from buffer) in the database for future execution in a multi-GPU system + function set_script_multigpu(self, name, script, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: script !< The file storing the script + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function set_script_multigpu + + function run_script(self, name, func, inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: func !< The name of the function in the script to call + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of script + !! input nodes (TF scripts) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of script + !! output nodes (TF scripts) + integer :: code + + code = -1 + end function run_script + + function run_script_multigpu(self, name, func, inputs, outputs, offset, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: func !< The name of the function in the script to call + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of script + !! input nodes (TF scripts) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of script + !! output nodes (TF scripts) + integer, intent(in) :: offset !< Index of the current image, such as a processor ID + !! or MPI rank + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function run_script_multigpu + + !> Remove a script from the database + function delete_script(self, name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to delete the script + integer :: code + + code = -1 + end function delete_script + + !> Remove a script_multigpu from the database + function delete_script_multigpu(self, name, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to delete the script_multigpu + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function delete_script_multigpu + + !> Store a dataset in the database + function put_dataset(self, dataset) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + type(dataset_type), intent(in) :: dataset !< Dataset to store in the dataset + integer :: code + + code = -1 + end function put_dataset + + !> Retrieve a dataset from the database + function get_dataset(self, name, dataset) result(code) + class(dbclient_type), intent(in ) :: self !< An initialized communication client + character(len=*), intent(in ) :: name !< Name of the dataset to get + type(dataset_type), intent( out) :: dataset !< receives the dataset + integer :: code + + type(dataset_type) :: dataset_out + ! Placeholder dataset to prevent compiler warnings + ! Since dataset_type contains no data, any declared instance should work. + + code = -1 + dataset = dataset_out + end function get_dataset + + !> Rename a dataset stored in the database + function rename_dataset(self, name, new_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< Original name of the dataset + character(len=*), intent(in) :: new_name !< New name of the dataset + integer :: code + + code = -1 + end function rename_dataset + + !> Copy a dataset within the database to a new name + function copy_dataset(self, name, new_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< Source name of the dataset + character(len=*), intent(in) :: new_name !< Name of the new dataset + integer :: code + + code = -1 + end function copy_dataset + + !> Delete a dataset stored within a database + function delete_dataset(self, name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< Name of the dataset to delete + integer :: code + + code = -1 + end function delete_dataset + + !> Appends a dataset to the aggregation list When appending a dataset to an aggregation list, the list will + !! automatically be created if it does not exist (i.e. this is the first entry in the list). Aggregation + !! lists work by referencing the dataset by storing its key, so appending a dataset to an aggregation list + !! does not create a copy of the dataset. Also, for this reason, the dataset must have been previously + !! placed into the database with a separate call to put_dataset(). + function append_to_list(self, list_name, dataset) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: list_name !< Name of the dataset to get + type(dataset_type), intent(in) :: dataset !< Dataset to append to the list + integer :: code + + code = -1 + end function append_to_list + + !> Delete an aggregation list + function delete_list(self, list_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: list_name !< Name of the aggregated dataset list to delete + integer :: code + + code = -1 + end function delete_list + + !> Copy an aggregation list + function copy_list(self, src_name, dest_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: src_name !< Name of the dataset to copy + character(len=*), intent(in) :: dest_name !< The new list name + integer :: code + + code = -1 + end function copy_list + + !> Rename an aggregation list + function rename_list(self, src_name, dest_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: src_name !< Name of the dataset to rename + character(len=*), intent(in) :: dest_name !< The new list name + integer :: code + + code = -1 + end function rename_list + + end module database_client_interface + diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 new file mode 100644 index 0000000000..95470e6510 --- /dev/null +++ b/config_src/external/drifters/MOM_particles.F90 @@ -0,0 +1,85 @@ +!> A set of dummy interfaces for compiling the MOM6 drifters code +module MOM_particles_mod + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_grid, only : ocean_grid_type +use MOM_time_manager, only : time_type, get_date, operator(-) +use MOM_variables, only : thermo_var_ptrs +use particles_types_mod, only : particles, particles_gridded + +implicit none ; private + +public particles, particles_run, particles_init, particles_save_restart, particles_end +public particles_to_k_space, particles_to_z_space + +contains + +!> Initializes particles container "parts" +subroutine particles_init(parts, Grid, Time, dt, u, v, h) + ! Arguments + type(particles), pointer, intent(out) :: parts !< Container for all types and memory + type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model + type(time_type), intent(in) :: Time !< Time type from parent model + real, intent(in) :: dt !< particle timestep in seconds [T ~> s] + real, dimension(:,:,:),intent(in) :: u !< Zonal velocity field [L T-1 ~> m s-1] + real, dimension(:,:,:),intent(in) :: v !< Meridional velocity field [L T-1 ~> m s-1] + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] +end subroutine particles_init + +!> The main driver the steps updates particles +subroutine particles_run(parts, time, uo, vo, ho, tv, use_uh, stagger) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + type(time_type), intent(in) :: time !< Model time + real, dimension(:,:,:), intent(in) :: uo !< If use_uh is false, ocean zonal velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated zonal thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] + real, dimension(:,:,:), intent(in) :: vo !< If use_uh is false, ocean meridional velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated meridional thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] + real, dimension(:,:,:), intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields + logical :: use_uh !< Flag for whether u and v are weighted by thickness + integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered + +end subroutine particles_run + + +!>Save particle locations (and sometimes other vars) to restart file +subroutine particles_save_restart(parts, h, directory, time, time_stamped) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] + character(len=*), intent(in) :: directory !< The directory where the restart files are to be written + type(time_type), intent(in) :: time !< The current model time + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp to the restart file names + +end subroutine particles_save_restart + +!> Deallocate all memory and disassociated pointer +subroutine particles_end(parts, h, temp, salt) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] + +end subroutine particles_end + +subroutine particles_to_k_space(parts, h) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of layers [H ~> m or kg m-2] + +end subroutine particles_to_k_space + + +subroutine particles_to_z_space(parts, h) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of layers [H ~> m or kg m-2] + +end subroutine particles_to_z_space + +end module MOM_particles_mod diff --git a/config_src/external/drifters/MOM_particles_types.F90 b/config_src/external/drifters/MOM_particles_types.F90 new file mode 100644 index 0000000000..30fecad7a2 --- /dev/null +++ b/config_src/external/drifters/MOM_particles_types.F90 @@ -0,0 +1,165 @@ +!> Dummy data structures and methods for drifters package +module particles_types_mod + +! This file is part of MOM6. See LICENSE.md for the license. + +use, intrinsic :: iso_fortran_env, only : int64 +use MOM_grid, only : ocean_grid_type +use MOM_domains, only: domain2D + +implicit none ; private + +!> Container for gridded fields +type, public :: particles_gridded + type(domain2D), pointer :: domain !< MPP parallel domain + integer :: halo !< Nominal halo width + integer :: isc !< Start i-index of computational domain + integer :: iec !< End i-index of computational domain + integer :: jsc !< Start j-index of computational domain + integer :: jec !< End j-index of computational domain + integer :: isd !< Start i-index of data domain + integer :: ied !< End i-index of data domain + integer :: jsd !< Start j-index of data domain + integer :: jed !< End j-index of data domain + integer :: isg !< Start i-index of global domain + integer :: ieg !< End i-index of global domain + integer :: jsg !< Start j-index of global domain + integer :: jeg !< End j-index of global domain + integer :: is_offset=0 !< add to i to recover global i-index + integer :: js_offset=0 !< add to j to recover global j-index + integer :: my_pe !< MPI PE index + integer :: pe_N !< MPI PE index of PE to the north + integer :: pe_S !< MPI PE index of PE to the south + integer :: pe_E !< MPI PE index of PE to the east + integer :: pe_W !< MPI PE index of PE to the west + logical :: grid_is_latlon !< Flag to say whether the coordinate is in lat-lon degrees, or meters + logical :: grid_is_regular !< Flag to say whether point in cell can be found assuming regular Cartesian grid + real :: Lx !< Length of the domain in x direction + real, dimension(:,:), allocatable :: lon !< Longitude of cell corners (degree E) + real, dimension(:,:), allocatable :: lat !< Latitude of cell corners (degree N) + real, dimension(:,:), allocatable :: lonc !< Longitude of cell centers (degree E) + real, dimension(:,:), allocatable :: latc !< Latitude of cell centers (degree N) + real, dimension(:,:), allocatable :: dx !< Length of cell edge (m) + real, dimension(:,:), allocatable :: dy !< Length of cell edge (m) + real, dimension(:,:), allocatable :: area !< Area of cell (m^2) + real, dimension(:,:), allocatable :: msk !< Ocean-land mask (1=ocean) + real, dimension(:,:), allocatable :: cos !< Cosine from rotation matrix to lat-lon coords + real, dimension(:,:), allocatable :: sin !< Sine from rotation matrix to lat-lon coords + real, dimension(:,:), allocatable :: ocean_depth !< Depth of ocean (m) + real, dimension(:,:), allocatable :: uo !< Ocean zonal flow (m/s) + real, dimension(:,:), allocatable :: vo !< Ocean meridional flow (m/s) + real, dimension(:,:), allocatable :: tmp !< Temporary work space + real, dimension(:,:), allocatable :: tmpc !< Temporary work space + real, dimension(:,:), allocatable :: parity_x !< X component of vector point from i,j to i+1,j+1 + real, dimension(:,:), allocatable :: parity_y !< Y component of vector point from i,j to i+1,j+1 + ! (For detecting tri-polar fold) + integer, dimension(:,:), allocatable :: particle_counter_grd !< Counts particles created for naming purposes + !>@{ + !! Diagnostic handle + integer :: id_uo=-1, id_vo=-1, id_unused=-1 + integer :: id_count=-1, id_chksum=-1 + !>@} + +end type particles_gridded + + +!>xyt is a data structure containing particle position and velocity fields. +type, public :: xyt + real :: lon !< Longitude of particle (degree N or unit of grid coordinate) + real :: lat !< Latitude of particle (degree N or unit of grid coordinate) + real :: day !< Day of this record (days) + real :: lat_old !< Previous latitude + real :: lon_old !< Previous longitude + real :: uvel !< Zonal velocity of particle (m/s) + real :: vvel !< Meridional velocity of particle (m/s) + real :: uvel_old !< Previous zonal velocity component (m/s) + real :: vvel_old !< Previous meridional velocity component (m/s) + integer :: year !< Year of this record + integer :: particle_num !< Current particle number + integer(kind=int64) :: id = -1 !< Particle Identifier + type(xyt), pointer :: next=>null() !< Pointer to the next position in the list +end type xyt + +!>particle types are data structures describing a tracked particle +type, public :: particle + type(particle), pointer :: prev=>null() !< Previous link in list + type(particle), pointer :: next=>null() !< Next link in list +! State variables (specific to the particles, needed for restarts) + real :: lon !< Longitude of particle (degree N or unit of grid coordinate) + real :: lat !< Latitude of particle (degree E or unit of grid coordinate) + real :: depth !< Depth of particle + real :: uvel !< Zonal velocity of particle (m/s) + real :: vvel !< Meridional velocity of particle (m/s) + real :: lon_old !< previous lon (degrees) + real :: lat_old !< previous lat (degrees) + real :: uvel_old !< previous uvel + real :: vvel_old !< previous vvel + real :: start_lon !< starting longitude where particle was created + real :: start_lat !< starting latitude where particle was created + real :: start_day !< origination position (degrees) and day + integer :: start_year !< origination year + real :: halo_part !< equal to zero for particles on the computational domain, and 1 for particles on the halo + integer(kind=int64) :: id !< particle identifier + integer(kind=int64) :: drifter_num !< particle identifier + integer :: ine !< nearest i-index in NE direction (for convenience) + integer :: jne !< nearest j-index in NE direction (for convenience) + real :: xi !< non-dimensional x-coordinate within current cell (0..1) + real :: yj !< non-dimensional y-coordinate within current cell (0..1) + real :: uo !< zonal ocean velocity + real :: vo !< meridional ocean velocity + !< by the particle (m/s) + type(xyt), pointer :: trajectory=>null() !< Trajectory for this particle +end type particle + + +!>A buffer structure for message passing +type, public :: buffer + integer :: size=0 !< Size of buffer + real, dimension(:,:), pointer :: data !< Buffer memory +end type buffer + +!> A wrapper for the particle linked list (since an array of pointers is not allowed) +type, public :: linked_list + type(particle), pointer :: first=>null() !< Pointer to the beginning of a linked list of parts +end type linked_list + + +!> A grand data structure for the particles in the local MOM domain +type, public :: particles !; private + type(particles_gridded) :: grd !< Container with all gridded data + type(linked_list), dimension(:,:), allocatable :: list !< Linked list of particles + type(xyt), pointer :: trajectories=>null() !< A linked list for detached segments of trajectories + real :: dt !< Time-step between particle calls + integer :: current_year !< Current year (years) + real :: current_yearday !< Current year-day, 1.00-365.99, (days) + integer :: traj_sample_hrs !< Period between sampling for trajectories (hours) + integer :: traj_write_hrs !< Period between writing of trajectories (hours) + integer :: verbose_hrs !< Period between terminal status reports (hours) + !>@{ + !! Handles for clocks + integer :: clock, clock_mom, clock_the, clock_int, clock_cal, clock_com, clock_ini, clock_ior, clock_iow, clock_dia + integer :: clock_trw, clock_trp + !>@} + logical :: restarted=.false. !< Indicate whether we read state from a restart or not + logical :: Runge_not_Verlet=.True. !< True=Runge-Kutta, False=Verlet. + logical :: ignore_missing_restart_parts=.False. !< True allows the model to ignore particles missing in the restart. + logical :: halo_debugging=.False. !< Use for debugging halos (remove when its working) + logical :: save_short_traj=.false. !< True saves only lon,lat,time,id in particle_trajectory.nc + logical :: ignore_traj=.False. !< If true, then model does not write trajectory data at all + logical :: use_new_predictive_corrective =.False. !< Flag to use Bob's predictive corrective particle scheme + !Added by Alon + integer(kind=int64) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id + type(buffer), pointer :: obuffer_n=>null() !< Buffer for outgoing parts to the north + type(buffer), pointer :: ibuffer_n=>null() !< Buffer for incoming parts from the north + type(buffer), pointer :: obuffer_s=>null() !< Buffer for outgoing parts to the south + type(buffer), pointer :: ibuffer_s=>null() !< Buffer for incoming parts from the south + type(buffer), pointer :: obuffer_e=>null() !< Buffer for outgoing parts to the east + type(buffer), pointer :: ibuffer_e=>null() !< Buffer for incoming parts from the east + type(buffer), pointer :: obuffer_w=>null() !< Buffer for outgoing parts to the west + type(buffer), pointer :: ibuffer_w=>null() !< Buffer for incoming parts from the west + type(buffer), pointer :: obuffer_io=>null() !< Buffer for outgoing parts during i/o + type(buffer), pointer :: ibuffer_io=>null() !< Buffer for incoming parts during i/o +end type particles + + +end module particles_types_mod diff --git a/config_src/external/stochastic_physics/get_stochy_pattern.F90 b/config_src/external/stochastic_physics/get_stochy_pattern.F90 new file mode 100644 index 0000000000..c3e23cd1a4 --- /dev/null +++ b/config_src/external/stochastic_physics/get_stochy_pattern.F90 @@ -0,0 +1,22 @@ +! The are stubs for ocean stochastic physics +! the fully functional code is available at +! http://github.com/noaa-psd/stochastic_physics +module get_stochy_pattern_mod + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public :: write_stoch_restart_ocn + +contains + +!> Write the restart file for the stochastic physics perturbations. +subroutine write_stoch_restart_ocn(sfile) + character(len=*) :: sfile !< name of restart file + + ! This stub function does not actually do anything. + return +end subroutine write_stoch_restart_ocn + +end module get_stochy_pattern_mod diff --git a/config_src/external/stochastic_physics/stochastic_physics.F90 b/config_src/external/stochastic_physics/stochastic_physics.F90 new file mode 100644 index 0000000000..14fa1bf289 --- /dev/null +++ b/config_src/external/stochastic_physics/stochastic_physics.F90 @@ -0,0 +1,58 @@ +! The are stubs for ocean stochastic physics +! the fully functional code is available at +! http://github.com/noaa-psd/stochastic_physics +module stochastic_physics + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, WARNING + +implicit none ; private + +public :: init_stochastic_physics_ocn +public :: run_stochastic_physics_ocn + +contains + +!> Initializes the stochastic physics perturbations. +subroutine init_stochastic_physics_ocn(delt, geoLonT, geoLatT, nx, ny, nz, pert_epbl_in, do_sppt_in, & + mpiroot, mpicomm, iret) + real, intent(in) :: delt !< timestep in seconds between calls to run_stochastic_physics_ocn [s] + integer, intent(in) :: nx !< number of gridpoints in the x-direction of the compute grid + integer, intent(in) :: ny !< number of gridpoints in the y-direction of the compute grid + integer, intent(in) :: nz !< number of gridpoints in the z-direction of the compute grid + real, intent(in) :: geoLonT(nx,ny) !< Longitude in degrees + real, intent(in) :: geoLatT(nx,ny) !< Latitude in degrees + logical, intent(in) :: pert_epbl_in !< logical flag, if true generate random pattern for ePBL perturbations + logical, intent(in) :: do_sppt_in !< logical flag, if true generate random pattern for SPPT perturbations + integer, intent(in) :: mpiroot !< root processor + integer, intent(in) :: mpicomm !< mpi communicator + integer, intent(out) :: iret !< return code + + iret=0 + if (pert_epbl_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: pert_epbl needs to be false if using the stub') + iret=-1 + endif + if (do_sppt_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: do_sppt needs to be false if using the stub') + iret=-1 + endif + + ! This stub function does not actually do anything. + return +end subroutine init_stochastic_physics_ocn + +!> Determines the stochastic physics perturbations. +subroutine run_stochastic_physics_ocn(sppt_wts, t_rp1, t_rp2) + real, intent(inout) :: sppt_wts(:,:) !< array containing random weights for SPPT range [0,2] + real, intent(inout) :: t_rp1(:,:) !< array containing random weights for ePBL + !! perturbations (KE generation) range [0,2] + real, intent(inout) :: t_rp2(:,:) !< array containing random weights for ePBL + !! perturbations (KE dissipation) range [0,2] + + ! This stub function does not actually do anything. + return +end subroutine run_stochastic_physics_ocn + +end module stochastic_physics diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 deleted file mode 100644 index efacc07dc5..0000000000 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ /dev/null @@ -1,1178 +0,0 @@ -module MOM_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, November 1998 - May 2002 * -!* Edited by Stephen Griffies June 2014 * -!* * -!* This program contains the subroutines that calculate the * -!* surface wind stresses and fluxes of buoyancy or temperature and * -!* fresh water. These subroutines will be called every time step, * -!* even if the wind stresses or buoyancy fluxes are constant in time * -!* - in that case these routines return quickly without doing * -!* anything. In addition, any I/O of forcing fields is controlled * -!* by surface_forcing_init, located in this file. * -!* * -!* set_forcing is a small entry subroutine for the subroutines in * -!* this file. It provides the external access to these subroutines. * -!* * -!* wind_forcing determines the wind stresses and places them into * -!* taux[][] and tauy[][]. Often wind_forcing must be tailored for * -!* a particular application - either by specifying file and variable * -!* names or by providing appropriate internal expressions for the * -!* stresses. * -!* * -!* buoyancy_forcing determines the surface fluxes of buoyancy, * -!* temperature, and fresh water, as is appropriate. A restoring * -!* boundary condition is implemented, but the code for any other * -!* boundary condition will usually be modified - either to specify * -!* file and variable names and which time level to read, or to set * -!* an internal expression for the variables. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_string_functions, only : uppercase -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags -use MOM_forcing_type, only : set_net_mass_forcing, copy_common_forcing_fields -use MOM_forcing_type, only : set_derived_forcing_fields -use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type -use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data, MOM_read_vector, slasher -use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS -use MOM_restart, only : restart_init_end, save_restart, restore_state -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, set_time -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing -use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS -use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init -use user_revise_forcing, only : user_revise_forcing_CS - -implicit none ; private - -#include - -public set_forcing -public surface_forcing_init -public forcing_diagnostics -public forcing_save_restart - -! surface_forcing_CS is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive into the ocean. -type, public :: surface_forcing_CS ; private - - logical :: use_temperature ! if true, temp & salinity used as state variables - logical :: restorebuoy ! if true, use restoring surface buoyancy forcing - logical :: adiabatic ! if true, no diapycnal mass fluxes or surface buoyancy forcing - logical :: variable_winds ! if true, wind stresses vary with time - logical :: variable_buoyforce ! if true, buoyancy forcing varies with time. - real :: south_lat ! southern latitude of the domain - real :: len_lat ! domain length in latitude - - real :: Rho0 ! Boussinesq reference density [kg m-3] - real :: G_Earth ! gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const ! piston velocity for surface restoring [m s-1] - - real :: gust_const ! constant unresolved background gustiness for ustar [Pa] - logical :: read_gust_2d ! if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() ! spatially varying unresolved background gustiness [Pa] - ! gust is used when read_gust_2d is true. - - real, pointer :: T_Restore(:,:) => NULL() ! temperature to damp (restore) the SST to [degC] - real, pointer :: S_Restore(:,:) => NULL() ! salinity to damp (restore) the SSS [ppt] - real, pointer :: Dens_Restore(:,:) => NULL() ! density to damp (restore) surface density [kg m-3] - - integer :: wind_last_lev_read = -1 ! The last time level read from the wind input files - integer :: buoy_last_lev_read = -1 ! The last time level read from buoyancy input files - - real :: gyres_taux_const, gyres_taux_sin_amp, gyres_taux_cos_amp, gyres_taux_n_pis - ! if WIND_CONFIG=='gyres' then use - ! = A, B, C and n respectively for - ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) - - real :: T_north, T_south ! target temperatures at north and south used in - ! buoyancy_forcing_linear - real :: S_north, S_south ! target salinity at north and south used in - ! buoyancy_forcing_linear - - logical :: first_call_set_forcing = .true. - real :: wind_scale ! value by which wind-stresses are scaled (nondimensional) - character(len=8) :: wind_stagger - - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(diag_ctrl), pointer :: diag ! structure used to regulate timing of diagnostic output - - character(len=200) :: inputdir ! The directory where NetCDF input files are. - character(len=200) :: wind_config ! Indicator for wind forcing type (2gyre, USER, FILE..) - character(len=200) :: wind_file ! If wind_config is "file", file to use - character(len=200) :: buoy_config ! Indicator for buoyancy forcing type - character(len=200) :: longwavedown_file - character(len=200) :: longwaveup_file - character(len=200) :: evaporation_file - character(len=200) :: sensibleheat_file - character(len=200) :: shortwaveup_file - character(len=200) :: shortwavedown_file - character(len=200) :: snow_file - character(len=200) :: precip_file - character(len=200) :: freshdischarge_file - character(len=200) :: SSTrestore_file - character(len=200) :: salinityrestore_file - character(len=80) :: stress_x_var, stress_y_var - - ! Diagnostics handles - type(forcing_diags), public :: handles - - type(user_revise_forcing_CS), pointer :: urf_CS => NULL() - type(user_surface_forcing_CS), pointer :: user_forcing_CSp => NULL() -! type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() -end type surface_forcing_CS - -integer :: id_clock_forcing - -contains - -!> This subroutine calls other subroutines in this file to get surface forcing fields. -!! It also allocates and initializes the fields in the flux type. -subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day_start !< The start time of the fluxes - type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: dt ! length of time over which fluxes applied [s] - type(time_type) :: day_center ! central time of the fluxes. - integer :: intdt - integer :: isd, ied, jsd, jed - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - call cpu_clock_begin(id_clock_forcing) - - day_center = day_start + day_interval/2 - call get_time(day_interval, intdt) - dt = real(intdt) - - if (CS%first_call_set_forcing) then - ! Allocate memory for the mechanical and thermodyanmic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) - - call allocate_forcing_type(G, fluxes, ustar=.true.) - if (trim(CS%buoy_config) /= "NONE") then - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - call safe_alloc_ptr(CS%S_Restore, isd, ied, jsd, jed) - endif - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore, isd, ied, jsd, jed) - endif ! endif for CS%use_temperature - endif - endif - - ! calls to various wind options - if (CS%variable_winds .or. CS%first_call_set_forcing) then - if (trim(CS%wind_config) == "file") then - call wind_forcing_from_file(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "2gyre") then - call wind_forcing_2gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "1gyre") then - call wind_forcing_1gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "gyres") then - call wind_forcing_gyres(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "zero") then - call wind_forcing_zero(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_wind_forcing(sfc_state, forces, day_center, G, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "USER") then - call USER_wind_forcing(sfc_state, forces, day_center, G, CS%user_forcing_CSp) - elseif (CS%variable_winds .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable winds defined with no wind config") - else - call MOM_error(FATAL, & - "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) - endif - endif - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - if (trim(CS%buoy_config) == "file") then - call buoyancy_forcing_from_files(sfc_state, fluxes, day_center, dt, G, CS) - elseif (trim(CS%buoy_config) == "zero") then - call buoyancy_forcing_zero(sfc_state, fluxes, day_center, dt, G, CS) - elseif (trim(CS%buoy_config) == "linear") then - call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, CS) - elseif (trim(CS%buoy_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "USER") then - call USER_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%user_forcing_CSp) - elseif (trim(CS%buoy_config) == "NONE") then - call MOM_mesg("MOM_surface_forcing: buoyancy forcing has been set to omitted.") - elseif (CS%variable_buoyforce .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable buoy defined with no buoy config.") - else - call MOM_error(FATAL, & - "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) - endif - endif - - if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) - endif - - ! Allow for user-written code to alter the fluxes after all the above - call user_alter_forcing(sfc_state, fluxes, day_center, G, CS%urf_CS) - - ! Fields that exist in both the forcing and mech_forcing types must be copied. - if (CS%variable_winds .or. CS%first_call_set_forcing) then - call copy_common_forcing_fields(forces, fluxes, G) - call set_derived_forcing_fields(forces, fluxes, G, US, CS%Rho0) - endif - - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - call set_net_mass_forcing(fluxes, forces, G) - endif - - CS%first_call_set_forcing = .false. - - call cpu_clock_end(id_clock_forcing) -end subroutine set_forcing - -!> This subroutine allocates arrays for buoyancy forcing. -subroutine buoyancy_forcing_allocate(fluxes, G, CS) - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic - !! forcing fields that will be allocated here - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - integer :: isd, ied, jsd, jed - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - ! surface restoring fields - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(CS%S_Restore,isd,ied,jsd,jed) - endif - - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy,isd,ied,jsd,jed) - - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore,isd,ied,jsd,jed) - - endif ! endif for CS%use_temperature - -end subroutine buoyancy_forcing_allocate - - -! This subroutine sets the surface wind stresses to zero -subroutine wind_forcing_zero(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_zero, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - !set steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - if (CS%read_gust_2d) then - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)/CS%Rho0) - enddo ; enddo ; endif - else - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const/CS%Rho0) - enddo ; enddo ; endif - endif - - call callTree_leave("wind_forcing_zero") -end subroutine wind_forcing_zero - - -!> This subroutine sets the surface wind stresses according to double gyre. -subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_2gyre, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - !set the steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.1*(1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / & - CS%len_lat)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_2gyre") -end subroutine wind_forcing_2gyre - - -!> This subroutine sets the surface wind stresses according to single gyre. -subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_1gyre, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! set the steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) =-0.2*cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_1gyre") -end subroutine wind_forcing_1gyre - - -!> This subroutine sets the surface wind stresses according to gyres. -subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI, y - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_gyres, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! steady surface wind stresses [Pa] - PI = 4.0*atan(1.0) - - do j=jsd,jed ; do I=IsdB,IedB - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - forces%taux(I,j) = CS%gyres_taux_const + & - ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & - + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) ) - enddo ; enddo - - do J=JsdB,JedB ; do i=isd,ied - forces%tauy(i,J) = 0.0 - enddo ; enddo - - ! set the friction velocity - do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & - forces%tauy(i,j)*forces%tauy(i,j) + forces%taux(i-1,j)*forces%taux(i-1,j) + & - forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) - enddo ; enddo - - call callTree_leave("wind_forcing_gyres") -end subroutine wind_forcing_gyres - -!> This subroutine sets the surface wind stresses by reading a file. -subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - integer :: time_lev ! With fields from a file, this must - ! be reset, depending on the time. - character(len=200) :: filename ! The name of the input file. - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. - integer :: days, seconds - - call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - call get_time(day,seconds,days) - time_lev = days - 365*floor(real(days) / 365.0) +1 - - if (time_lev /= CS%wind_last_lev_read) then - filename = trim(CS%inputdir) // trim(CS%wind_file) -! if (is_root_pe()) & -! write(*,'("Wind_forcing Reading time level ",I," last was ",I,".")')& -! time_lev-1,CS%wind_last_lev_read-1 - select case ( uppercase(CS%wind_stagger(1:1)) ) - case ("A") - temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 - call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & - temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & - timelevel=time_lev) - - call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.5 * CS%wind_scale * (temp_x(i,j) + temp_x(i+1,j)) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.5 * CS%wind_scale * (temp_y(i,j) + temp_y(i,j+1)) - enddo ; enddo - - if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) - enddo ; enddo - else - do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) - enddo ; enddo - endif - case ("C") - call MOM_read_vector(filename,CS%stress_x_var, CS%stress_y_var, & - forces%taux(:,:), forces%tauy(:,:), & - G%Domain, timelevel=time_lev) - if (CS%wind_scale /= 1.0) then - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = CS%wind_scale * forces%taux(I,j) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = CS%wind_scale * forces%tauy(i,J) - enddo ; enddo - endif - - call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) - if (CS%read_gust_2d) then - do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & - forces%taux(i,j)**2))) + CS%gust(i,j)) / CS%Rho0 ) - enddo ; enddo - else - do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & - forces%taux(i,j)**2)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) - enddo ; enddo - endif - case default - call MOM_error(FATAL, "wind_forcing_from_file: Unrecognized stagger "//& - trim(CS%wind_stagger)//" is not 'A' or 'C'.") - end select - CS%wind_last_lev_read = time_lev - endif ! time_lev /= CS%wind_last_lev_read - - call callTree_leave("wind_forcing_from_file") -end subroutine wind_forcing_from_file - - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water -!! by reading a file. It may also be modified to add surface fluxes of user provided tracers. -subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - real :: rhoXcp ! mean density times the heat capacity [J m-3 degC-1]. - real :: Irho0 ! inverse Boussinesq reference density [m3 kg-1]. - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - - integer :: time_lev ! With fields from a file, this must - ! be reset, depending on the time. - integer :: time_lev_monthly ! With fields from a file, this must - ! be reset, depending on the time. - integer :: days, seconds - real, dimension(SZI_(G),SZJ_(G)) :: & - temp, & ! A 2-d temporary work array with various units. - SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value [degC]. - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value [ppt]. - SSS_mean ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation - ! anomalies [ppt]. - - call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/CS%Rho0 - - ! Read the file containing the buoyancy forcing. - call get_time(day,seconds,days) - - time_lev = days - 365*floor(real(days) / 365.0) - - if (time_lev < 31) then ; time_lev_monthly = 0 - else if (time_lev < 59) then ; time_lev_monthly = 1 - else if (time_lev < 90) then ; time_lev_monthly = 2 - else if (time_lev < 120) then ; time_lev_monthly = 3 - else if (time_lev < 151) then ; time_lev_monthly = 4 - else if (time_lev < 181) then ; time_lev_monthly = 5 - else if (time_lev < 212) then ; time_lev_monthly = 6 - else if (time_lev < 243) then ; time_lev_monthly = 7 - else if (time_lev < 273) then ; time_lev_monthly = 8 - else if (time_lev < 304) then ; time_lev_monthly = 9 - else if (time_lev < 334) then ; time_lev_monthly = 10 - else ; time_lev_monthly = 11 - endif - - time_lev = time_lev+1 - time_lev_monthly = time_lev_monthly+1 - - if (time_lev /= CS%buoy_last_lev_read) then - -! if (is_root_pe()) & -! write(*,'("buoyancy_forcing : Reading time level ",I3,", last was ",I3,".")')& -! time_lev,CS%buoy_last_lev_read - - - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwavedown_file), "lwdn_sfc", & - fluxes%LW(:,:), G%Domain, timelevel=time_lev) - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwaveup_file), "lwup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev) - do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%evaporation_file), "evap", & - temp(:,:), G%Domain, timelevel=time_lev) - do j=js,je ; do i=is,ie - fluxes%latent(i,j) = -hlv*temp(i,j) - fluxes%evap(i,j) = -temp(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%sensibleheat_file), "shflx", & - temp(:,:), G%Domain, timelevel=time_lev) - do j=js,je ; do i=is,ie ; fluxes%sens(i,j) = -temp(i,j) ; enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwavedown_file), "swdn_sfc", & - fluxes%sw(:,:), G%Domain, timelevel=time_lev) - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwaveup_file), "swup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev) - do j=js,je ; do i=is,ie - fluxes%sw(i,j) = fluxes%sw(i,j) - temp(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%snow_file), "snow", & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev) - call MOM_read_data(trim(CS%inputdir)//trim(CS%precip_file), "precip", & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev) - do j=js,je ; do i=is,ie - fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_w", & - temp(:,:), G%Domain, timelevel=time_lev_monthly) - do j=js,je ; do i=is,ie - fluxes%lrunoff(i,j) = temp(i,j)*G%IareaT(i,j) - enddo ; enddo - call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_s", & - temp(:,:), G%Domain, timelevel=time_lev_monthly) - do j=js,je ; do i=is,ie - fluxes%frunoff(i,j) = temp(i,j)*G%IareaT(i,j) - enddo ; enddo - -! Read the SST and SSS fields for damping. - if (CS%restorebuoy) then - call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "TEMP", & - CS%T_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - call MOM_read_data(trim(CS%inputdir)//trim(CS%salinityrestore_file), "SALT", & - CS%S_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - endif - CS%buoy_last_lev_read = time_lev - - ! mask out land points and compute heat content of water fluxes - ! assume liquid precip enters ocean at SST - ! assume frozen precip enters ocean at 0degC - ! assume liquid runoff enters ocean at SST - ! assume solid runoff (calving) enters ocean at 0degC - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = fluxes%evap(i,j) * G%mask2dT(i,j) - fluxes%lprec(i,j) = fluxes%lprec(i,j) * G%mask2dT(i,j) - fluxes%fprec(i,j) = fluxes%fprec(i,j) * G%mask2dT(i,j) - fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * G%mask2dT(i,j) - fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * G%mask2dT(i,j) - fluxes%LW(i,j) = fluxes%LW(i,j) * G%mask2dT(i,j) - fluxes%sens(i,j) = fluxes%sens(i,j) * G%mask2dT(i,j) - fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) - fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) - - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*fluxes%lrunoff(i,j)*sfc_state%SST(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*hlf - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*hlf - enddo ; enddo - - endif ! time_lev /= CS%buoy_last_lev_read - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then - fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & - ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & - (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & - (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) - else - fluxes%heat_restore(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) - else - fluxes%buoy(i,j) = 0.0 - endif - enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_from_files") -end subroutine buoyancy_forcing_from_files - - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. -!! It may also be modified to add surface fluxes of user provided tracers. -!! This case has zero surface buoyancy forcing. -subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_zero, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - call callTree_leave("buoyancy_forcing_zero") -end subroutine buoyancy_forcing_zero - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. -!! It may also be modified to add surface fluxes of user provided tracers. -subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: y, T_restore, S_restore - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - ! This case has no surface buoyancy forcing. - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - T_restore = CS%T_south + (CS%T_north-CS%T_south)*y - S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then - fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & - (S_Restore - sfc_state%SSS(i,j)) / & - (0.5*(sfc_state%SSS(i,j) + S_Restore)) - else - fluxes%heat_restore(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "RESTOREBUOY to linear not written yet.") - !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) - ! else - ! fluxes%buoy(i,j) = 0.0 - ! endif - !enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_linear") -end subroutine buoyancy_forcing_linear - -!> Save any restart files associated with the surface forcing. -subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & - filename_suffix) - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to surface_forcing_init - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time !< The current model time - character(len=*), intent(in) :: directory !< The directory into which to write the - !! restart files - logical, optional, intent(in) :: time_stamped !< If true, the restart file names include - !! a unique time stamp. The default is false. - character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time- - !! stamp) to append to the restart file names. - - if (.not.associated(CS)) return - if (.not.associated(CS%restart_CSp)) return - - call save_restart(directory, Time, 1, G, CS%restart_CSp, time_stamped) - -end subroutine forcing_save_restart - -!> Initialize the surface forcing, including setting parameters and allocating permanent memory. -subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_CSp) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure - !! for this module - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure of - !! the tracer flow control module. - - ! Local variables - type(directories) :: dirs - logical :: new_sim - type(time_type) :: Time_frc -! 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=60) :: axis_units - character(len=200) :: filename, gust_file ! The name of the gustiness input file. - - if (associated(CS)) then - call MOM_error(WARNING, "surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - id_clock_forcing=cpu_clock_id('(Ocean surface forcing)', grain=CLOCK_MODULE) - call cpu_clock_begin(id_clock_forcing) - - CS%diag => diag - if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & - "The directory in which all input files are found.", & - default=".") - CS%inputdir = slasher(CS%inputdir) - - call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is "//& - "true. This assumes that KD = KDML = 0.0 and that "//& - "there is no buoyancy forcing, but makes the model "//& - "faster by eliminating subroutine calls.", default=.false.) - call get_param(param_file, mdl, "VARIABLE_WINDS", CS%variable_winds, & - "If true, the winds vary in time after the initialization.", & - default=.true.) - call get_param(param_file, mdl, "VARIABLE_BUOYFORCE", CS%variable_buoyforce, & - "If true, the buoyancy forcing varies in time after the "//& - "initialization of the model.", default=.true.) - - call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & - "The character string that indicates how buoyancy forcing "//& - "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), and (NONE).", fail_if_missing=.true.) - if (trim(CS%buoy_config) == "file") then - call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwavedown_file, & - "The file with the downward longwave heat flux, in "//& - "variable lwdn_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "LONGWAVEUP_FILE", CS%longwaveup_file, & - "The file with the upward longwave heat flux, in "//& - "variable lwup_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in "//& - "variable evap.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in "//& - "variable shflx.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEUP_FILE", CS%shortwaveup_file, & - "The file with the upward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEDOWN_FILE", CS%shortwavedown_file, & - "The file with the downward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the downward frozen precip flux, in "//& - "variable snow.", fail_if_missing=.true.) - call get_param(param_file, mdl, "PRECIP_FILE", CS%precip_file, & - "The file with the downward total precip flux, in "//& - "variable precip.", fail_if_missing=.true.) - call get_param(param_file, mdl, "FRESHDISCHARGE_FILE", CS%freshdischarge_file, & - "The file with the fresh and frozen runoff/calving fluxes, "//& - "invariables disch_w and disch_s.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in "//& - "variable TEMP.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to "//& - "restore in variable SALT.", fail_if_missing=.true.) - endif - call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing "//& - "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", fail_if_missing=.true.) - if (trim(CS%wind_config) == "file") then - call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & - "The file in which the wind stresses are found in "//& - "variables STRESS_X and STRESS_Y.", fail_if_missing=.true.) - call get_param(param_file, mdl, "WINDSTRESS_X_VAR",CS%stress_x_var, & - "The name of the x-wind stress variable in WIND_FILE.", & - default="STRESS_X") - call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & - "The name of the y-wind stress variable in WIND_FILE.", & - default="STRESS_Y") - call get_param(param_file, mdl, "WINDSTRESS_STAGGER",CS%wind_stagger, & - "A character indicating how the wind stress components "//& - "are staggered in WIND_FILE. This may be A or C for now.", & - default="A") - call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & - "A value by which the wind stresses in WIND_FILE are rescaled.", & - default=1.0, units="nondim") - endif - if (trim(CS%wind_config) == "gyres") then - call get_param(param_file, mdl, "TAUX_CONST", CS%gyres_taux_const, & - "With the gyres wind_config, the constant offset in the "//& - "zonal wind stress profile: "//& - " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_SIN_AMP",CS%gyres_taux_sin_amp, & - "With the gyres wind_config, the sine amplitude in the "//& - "zonal wind stress profile: "//& - " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_COS_AMP",CS%gyres_taux_cos_amp, & - "With the gyres wind_config, the cosine amplitude in "//& - "the zonal wind stress profile: "//& - " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & - "With the gyres wind_config, the number of gyres in "//& - "the zonal wind stress profile: "//& - " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="nondim", default=0.0) - endif - call get_param(param_file, mdl, "SOUTHLAT", CS%south_lat, & - "The southern latitude of the domain or the equivalent "//& - "starting value for the y-axis.", units=axis_units, default=0.) - call get_param(param_file, mdl, "LENLAT", CS%len_lat, & - "The latitudinal or y-direction length of the domain.", & - units=axis_units, fail_if_missing=.true.) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 - if (trim(CS%buoy_config) == "linear") then - call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & - "With buoy_config linear, the sea surface temperature "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & - "With buoy_config linear, the sea surface temperature "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & - "With buoy_config linear, the sea surface salinity "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & - "With buoy_config linear, the sea surface salinity "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - endif - endif - call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) - call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from "//& - "an input file", default=.false.) - if (CS%read_gust_2d) then - call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in "//& - "variable gustiness.", fail_if_missing=.true.) - call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) ; CS%gust(:,:) = 0.0 - filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, & - timelevel=1) ! units should be Pa - endif - call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") - -! All parameter settings are now known. - - if (trim(CS%wind_config) == "USER" .or. trim(CS%buoy_config) == "USER" ) then - call USER_surface_forcing_init(Time, G, param_file, diag, CS%user_forcing_CSp) - elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") - endif - - call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) - - ! Set up any restart fields associated with the forcing. - call restart_init(G, param_file, CS%restart_CSp, "MOM_forcing.res") - call restart_init_end(CS%restart_CSp) - - if (associated(CS%restart_CSp)) then - call Get_MOM_Input(dirs=dirs) - - new_sim = .false. - if ((dirs%input_filename(1:1) == 'n') .and. & - (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. - if (.not.new_sim) then - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) - endif - endif - - call user_revise_forcing_init(param_file, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) -end subroutine surface_forcing_init - -!> Clean up and deallocate any memory associated with this module and its children. -subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous surface_forcing_init call - !! that will be deallocated here. - type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to any possible - !! forcing fields that will be deallocated here. - - if (present(fluxes)) call deallocate_forcing_type(fluxes) - - if (associated(CS)) deallocate(CS) - CS => NULL() - -end subroutine surface_forcing_end - -end module MOM_surface_forcing diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 deleted file mode 100644 index 828dbf301c..0000000000 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ /dev/null @@ -1,412 +0,0 @@ -program SHELF_main - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Daniel Goldberg, Olga Sergienko, and Robert Hallberg * -!* * -!* This file is the driver for the stand-alone ice-sheet model that * -!* is under development at GFDL. When used in a mode that is coupled * -!* with an ocean model or a full coupled model, a different driver * -!* will be used. This file orchestrates the calls to the appropriate * -!* initialization routines, to the subroutine that steps the model, * -!* and coordinates the saving and reading of restarts. * -!* A description of all of the files that constitute this ice shelf * -!* component is found in the comments at the beginning of * -!* MOM_ice_shelf.F90. The arguments of each subroutine are * -!* described where the subroutine is defined. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h * -!* * -!********+*********+*********+*********+*********+*********+*********+** - - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end - use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end - use MOM_domains, only : MOM_infra_init, MOM_infra_end - use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe - use MOM_file_parser, only : get_param, log_param, log_version, param_file_type - use MOM_file_parser, only : close_param_file -! use MOM_grid, only : ocean_grid_type - use MOM_get_input, only : Get_MOM_Input, directories - use MOM_io, only : file_exists, open_file, close_file - use MOM_io, only : check_nml_error, io_infra_init, io_infra_end - use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_restart, only : save_restart -! use MOM_sum_output, only : write_energy, accumulate_net_input -! use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS - use MOM_string_functions, only : uppercase -! use MOM_surface_forcing, only : set_forcing, average_forcing -! use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS - use MOM_time_manager, only : time_type, set_date, set_time, get_date, time_type_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 - use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS - use MOM_time_manager, only : NO_CALENDAR - 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_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS - use MOM_ice_shelf, only : ice_shelf_save_restart, solo_time_step -! , add_shelf_flux_forcing, add_shelf_flux_IOB - implicit none - -#include - - -! type(forcing) :: fluxes ! A structure that will be uninitialized till i figure out - ! whether i can make the argument optional - -! type(ocean_grid_type), pointer :: grid ! A pointer to a structure containing - ! metrics and related information. - logical :: use_ice_shelf = .false. ! If .true., use the ice shelf model for - ! part of the domain. - logical :: permit_restart = .true. ! This is .true. if incremental restart - ! files may be saved. - integer :: m, n - - integer :: nmax=2000000000; ! nmax is the number of iterations - ! after which to stop so that the - ! simulation does not exceed its CPU - ! time limit. nmax is determined by - ! evaluating the CPU time used between - ! successive calls to write_energy. - ! Initially it is set to be very large. - type(directories) :: dirs ! A structure containing several relevant directory paths. - - type(time_type), target :: Time ! A copy of the model's time. - ! Other modules can set pointers to this and - ! change it to manage diagnostics. - - type(time_type) :: Master_Time ! The ocean model's master clock. No other - ! modules are ever given access to this. - - type(time_type) :: Time1 ! The value of the ocean model's time at the - ! start of a call to step_MOM. - - type(time_type) :: Start_time ! The start time of the simulation. - - type(time_type) :: segment_start_time ! The start time of this run segment. - - type(time_type) :: Time_end ! End time for the segment or experiment. - - type(time_type) :: restart_time ! The next time to write restart files. - - type(time_type) :: Time_step_shelf ! A time_type version of time_step. - - real :: elapsed_time = 0.0 ! Elapsed time in this run in seconds. (years?) - - logical :: elapsed_time_master ! If true, elapsed time is used to set the - ! model's master clock (Time). This is needed - ! if Time_step_shelf is not an exact - ! representation of time_step. - - real :: time_step ! The time step (in years??? seconds???) - - - - integer :: Restart_control ! An integer that is bit-tested to determine whether - ! incremental restart files are saved and whether they - ! have a time stamped name. +1 (bit 0) for generic - ! files and +2 (bit 1) for time-stamped files. A - ! restart file is saved at the end of a run segment - ! unless Restart_control is negative. - real :: Time_unit ! The time unit in seconds for the following input fields. - type(time_type) :: restint ! The time between saves of the restart file. - type(time_type) :: daymax ! The final day of the simulation. - - integer :: date_init(6)=0 ! The start date of the whole simulation. - integer :: date(6)=-1 ! Possibly the start date of this run segment. - integer :: years=0, months=0, days=0 ! These may determine the segment run - integer :: hours=0, minutes=0, seconds=0 ! length, if read from a namelist. - integer :: yr, mon, day, hr, min, sec ! Temp variables for writing the date. - type(param_file_type) :: param_file ! The structure indicating the file(s) - ! containing all run-time parameters. - character(len=9) :: month - character(len=16) :: calendar = 'julian' - integer :: calendar_type=-1 - - integer :: unit, io_status, ierr - logical :: unit_in_use - - integer :: initClock, mainClock, termClock - -! type(ice_shelf_CS), pointer :: MOM_CSp => NULL() -! type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() -! type(sum_output_CS), pointer :: sum_output_CSp => NULL() - type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() - type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() - !----------------------------------------------------------------------- - - character(len=4), parameter :: vers_num = 'v2.0' -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "SHELF_main (ice_shelf_driver)" ! This module's name. - - namelist /ice_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds - - !======================================================================= - - call write_cputime_start_clock(write_CPU_CSp) - - call MOM_infra_init() ; call io_infra_init() - - ! These clocks are on the global pelist. - initClock = cpu_clock_id( 'Initialization' ) - mainClock = cpu_clock_id( 'Main loop' ) - termClock = cpu_clock_id( 'Termination' ) - call cpu_clock_begin(initClock) - - call MOM_mesg('======== Model being driven by ice_shelf_driver ========') - - if (file_exists('input.nml')) then - ! Provide for namelist specification of the run length and calendar data. - call open_file(unit, 'input.nml', form=ASCII_FILE, action=READONLY_FILE) - read(unit, ice_solo_nml, iostat=io_status) - call close_file(unit) - if (years+months+days+hours+minutes+seconds > 0) then - ierr = check_nml_error(io_status,'ice_solo_nml') - if (is_root_pe()) write(*,ice_solo_nml) - endif - endif - - ! 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_file(unit,trim(dirs%restart_input_dir)//'ice_solo.res', & - form=ASCII_FILE,action=READONLY_FILE) - read(unit,*) calendar_type - read(unit,*) date_init - read(unit,*) date - call close_file(unit) - else - calendar = uppercase(calendar) - if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - else if (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - else if (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - else if (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - else if (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR - else if (calendar(1:1) /= ' ') then - call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') - else - call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') - endif - endif - call set_calendar_type(calendar_type) - - 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)) - else - Start_time = set_time(0,0) - endif - - call Get_MOM_Input(param_file, dirs) - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - - call get_param(param_file, mdl, "ICE_SHELF", use_ice_shelf, & - "If true, call the code to apply an ice shelf model over "//& - "some of the domain.", default=.false.) - - if (.not.use_ice_shelf) call MOM_error(FATAL, & - "shelf_driver: ICE_SHELF must be defined.") - - call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", time_step, & - "The time step for changing forcing, coupling with other "//& - "components, or potentially writing certain diagnostics.", & - units="s", fail_if_missing=.true.) - - if (sum(date) >= 0) then - ! In this case, the segment starts at a time fixed by ocean_solo.res - segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) - Time = segment_start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) - else - ! In this case, the segment starts at a time read from the MOM restart file - ! or left as Start_time by MOM_initialize. - Time = Start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) - endif - Master_Time = Time -! grid => ice_shelf_CSp%grid - - segment_start_time = Time - elapsed_time = 0.0 - - Time_step_shelf = set_time(int(floor(time_step+0.5))) - elapsed_time_master = (abs(time_step - time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step) - if (elapsed_time_master) & - call MOM_mesg("Using real elapsed time for the master clock.") - - ! Determine the segment end time, either from the namelist file or parsed input file. - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & - "The time unit for DAYMAX and RESTINT.", & - units="s", default=86400.0) - if (years+months+days+hours+minutes+seconds > 0) then - Time_end = increment_date(Time, years, months, days, hours, minutes, seconds) - call MOM_mesg('Segment run length determied from ice_solo_nml.', 2) - call get_param(param_file, mdl, "DAYMAX", daymax, & - "The final time of the whole simulation, in units of "//& - "TIMEUNIT seconds. This also sets the potential end "//& - "time of the present run segment if the end time is "//& - "not set (as it was here) via ocean_solo_nml in input.nml.", & - timeunit=Time_unit, default=Time_end) - else - call get_param(param_file, mdl, "DAYMAX", daymax, & - "The final time of the whole simulation, in units of "//& - "TIMEUNIT seconds. This also sets the potential end "//& - "time of the present run segment if the end time is "//& - "not set via ocean_solo_nml in input.nml.", & - timeunit=Time_unit, fail_if_missing=.true.) - Time_end = daymax - endif - - if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), & - "TIme_end", time_type_to_real(Time_end) - if (Time >= Time_end) call MOM_error(FATAL, & - "MOM_driver: The run has been started at or after the end time of the run.") - - call get_param(param_file, mdl, "RESTART_CONTROL", Restart_control, & - "An integer whose bits encode which restart files are "//& - "written. Add 2 (bit 1) for a time-stamped file, and odd "//& - "(bit 0) for a non-time-stamped file. A non-time-stamped "//& - "restart file is saved at the end of the run segment "//& - "for any non-negative value.", default=1) - call get_param(param_file, mdl, "RESTINT", restint, & - "The interval between saves of the restart file in units "//& - "of TIMEUNIT. Use 0 (the default) to not save "//& - "incremental restart files at all.", default=set_time(0), & - timeunit=Time_unit) - call log_param(param_file, mdl, "ELAPSED TIME AS MASTER", elapsed_time_master) - -! i don't think we'll use this... - call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & - write_CPU_CSp) - call MOM_mesg("Done MOM_write_cputime_init.", 5) - - - ! Close the param_file. No further parsing of input is possible after this. - call close_param_file(param_file) -! call diag_mediator_close_registration(diag) - - ! Write out a time stamp file. - call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & - threading=SINGLE_FILE) - call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call close_file(unit) - - call write_cputime(Time, 0, nmax, write_CPU_CSp) - - if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & - .or. (Restart_control < 0)) permit_restart = .false. - - if (restint > set_time(0)) then - ! restart_time is the next integral multiple of restint. - restart_time = Start_time + restint * & - (1 + ((Time + Time_step_ocean) - Start_time) / restint) - else - ! Set the time so late that there is no intermediate restart. - restart_time = Time_end + Time_step_ocean - permit_restart = .false. - endif - - call cpu_clock_end(initClock) !end initialization - - call cpu_clock_begin(mainClock) !begin main loop - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MAIN LOOP !!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - n = 1 ; m = 1 - do while ((n < nmax) .and. (Time < Time_end)) - - ! This call steps the model over a time time_step. - Time1 = Master_Time ; Time = Master_Time - call solo_time_step (ice_shelf_CSp, time_step, m, Time) - -! Time = Time + Time_step_ocean -! This is here to enable fractional-second time steps. - elapsed_time = elapsed_time + time_step - if (elapsed_time > 2e9) then - ! This is here to ensure that the conversion from a real to an integer - ! can be accurately represented in long runs (longer than ~63 years). - ! It will also ensure that elapsed time does not loose 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. - segment_start_time = segment_start_time + set_time(int(floor(elapsed_time))) - elapsed_time = elapsed_time - floor(elapsed_time) - endif - if (elapsed_time_master) then - Master_Time = segment_start_time + set_time(int(floor(elapsed_time+0.5))) - else - Master_Time = Master_Time + Time_step_shelf - endif - Time = Master_Time - -! See if it is time to write out a restart file - timestamped or not. - if (permit_restart) then - if (Time + (Time_step_shelf/2) > restart_time) then - if (BTEST(Restart_control,1)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) - endif - if (BTEST(Restart_control,0)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) - endif - restart_time = restart_time + restint - endif - endif - - enddo !!!!!!! end loop - - call cpu_clock_end(mainClock) - call cpu_clock_begin(termClock) - if (Restart_control>=0) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, & - dirs%restart_output_dir) - ! Write ocean solo restart file. - call open_file(unit, trim(dirs%restart_output_dir)//'shelf.res', nohdrs=.true.) - if (is_root_pe())then - write(unit, '(i6,8x,a)') calendar_type, & - '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' - - call get_date(Start_time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & - 'Model start time: year, month, day, hour, minute, second' - call get_date(Time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & - 'Current model time: year, month, day, hour, minute, second' - end if - call close_file(unit) - endif - - if (is_root_pe()) then - do unit=10,1967 - INQUIRE(unit,OPENED=unit_in_use) - if (.not.unit_in_use) exit - enddo - open(unit,FILE="exitcode",FORM="FORMATTED",STATUS="REPLACE",action="WRITE") - if (Time < daymax) then - write(unit,*) 9 - else - write(unit,*) 0 - endif - close(unit) - endif - - call diag_mediator_end(Time, ice_shelf_CSp%diag, end_diag_manager=.true.) - call cpu_clock_end(termClock) - - call io_infra_end ; call MOM_infra_end - - call ice_shelf_end(ice_shelf_CSp) - -end program SHELF_main diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 deleted file mode 100644 index 1652db2ceb..0000000000 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ /dev/null @@ -1,343 +0,0 @@ -module user_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Rewritten by Robert Hallberg, June 2009 * -!* * -!* This file contains the subroutines that a user should modify to * -!* to set the surface wind stresses and fluxes of buoyancy or * -!* temperature and fresh water. They are called when the run-time * -!* parameters WIND_CONFIG or BUOY_CONFIG are set to "USER". The * -!* standard version has simple examples, along with run-time error * -!* messages that will cause the model to abort if this code has not * -!* been modified. This code is intended for use with relatively * -!* simple specifications of the forcing. For more complicated forms, * -!* it is probably a good idea to read the forcing from input files * -!* using "file" for WIND_CONFIG and BUOY_CONFIG. * -!* * -!* USER_wind_forcing should set the surface wind stresses (taux and * -!* tauy) perhaps along with the surface friction velocity (ustar). * -!* * -!* USER_buoyancy forcing is used to set the surface buoyancy * -!* forcing, which may include a number of fresh water flux fields * -!* (evap, lprec, fprec, lrunoff, frunoff, and * -!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * -!* if temperature and salinity are state variables, or it may simply * -!* be the buoyancy flux if it is not. This routine also has coded a * -!* restoring to surface values of temperature and salinity. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, param_file_type, log_version -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface - -implicit none ; private - -public USER_wind_forcing, USER_buoyancy_forcing, USER_surface_forcing_init - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -type, public :: user_surface_forcing_CS ; private - ! This control structure should be used to store any run-time variables - ! associated with the user-specified forcing. It can be readily modified - ! for a specific case, and because it is private there will be no changes - ! needed in other code (although they will have to be recompiled). - ! The variables in the cannonical example are used for some common - ! cases, but do not need to be used. - - logical :: use_temperature ! If true, temperature and salinity are used as - ! state variables. - logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. - real :: Rho0 ! The density used in the Boussinesq - ! approximation [kg m-3]. - real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: Flux_const ! The restoring rate at the surface [m s-1]. - real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar [Pa]. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. -end type user_surface_forcing_CS - -contains - -!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [Pa]. -!! These are the stresses in the direction of the model grid (i.e. the same -!! direction as the u- and v- velocities). -subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< The time of the fluxes - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to user_surface_forcing_init - -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy [Pa]. -! In addition, this subroutine can be used to set the surface friction velocity, -! forces%ustar [Z T-1 ~> m s-1], which is needed with a bulk mixed layer. - - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_wind_surface_forcing: " // & - "User forcing routine called without modification." ) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - - ! Set the surface wind stresses [Pa]. A positive taux - ! accelerates the ocean to the (pseudo-)east. - - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 ! Change this to the desired expression. - enddo ; enddo - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity [Z s-1 ~> m s-1]. ustar is always positive. - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) - enddo ; enddo ; endif - -end subroutine USER_wind_forcing - -!> This subroutine specifies the current surface fluxes of buoyancy or -!! temperature and fresh water. It may also be modified to add -!! surface fluxes of user provided tracers. -subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day !< The time of the fluxes - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to user_surface_forcing_init - -! This subroutine specifies the current surface fluxes of buoyancy or -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. - -! When temperature is used, there are long list of fluxes that need to be -! set - essentially the same as for a full coupled model, but most of these -! can be simply set to zero. The net fresh water flux should probably be -! set in fluxes%evap and fluxes%lprec, with any salinity restoring -! appearing in fluxes%vprec, and the other water flux components -! (fprec, lrunoff and frunoff) left as arrays full of zeros. -! Evap is usually negative and precip is usually positive. All heat fluxes -! are in W m-2 and positive for heat going into the ocean. All fresh water -! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. - - real :: Temp_restore ! The temperature that is being restored toward [C]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] - real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. - real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. - - integer :: i, j, is, ie, js, je - integer :: isd, ied, jsd, jed - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "User forcing routine called without modification." ) - - ! Allocate and zero out the forcing arrays, as necessary. This portion is - ! usually not changed. - if (CS%use_temperature) then - call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) - - call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) - else ! This is the buoyancy only mode. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - endif - - - ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. - - if ( CS%use_temperature ) then - ! Set whichever fluxes are to be used here. Any fluxes that - ! are always zero do not need to be changed here. - do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] - ! and are positive downward - i.e. evaporation should be negative. - fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) - fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) - - ! vprec will be set later, if it is needed for salinity restoring. - fluxes%vprec(i,j) = 0.0 - - ! Heat fluxes are in units of [W m-2] and are positive into the ocean. - fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sw(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - else ! This is the buoyancy only mode. - do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean [L2 T-3 ~> m2 s-3]. A positive - ! buoyancy flux is of the same sign as heating the ocean. - fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "Temperature and salinity restoring used without modification." ) - - rhoXcp = CS%Rho0 * fluxes%C_p - do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in degC) and - ! salinity (in ppt or PSU) that are being restored toward. - Temp_restore = 0.0 - Salin_restore = 0.0 - - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & - (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((Salin_restore - sfc_state%SSS(i,j)) / & - (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) - enddo ; enddo - else - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "Buoyancy restoring used without modification." ) - - ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 - do j=js,je ; do i=is,ie - ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 - - fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) - enddo ; enddo - endif - endif ! end RESTOREBUOY - -end subroutine USER_buoyancy_forcing - -!> This subroutine initializes the USER_surface_forcing module -subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to - !! the control structure for this module - - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "user_surface_forcing" ! This module's name. - - if (associated(CS)) then - call MOM_error(WARNING, "USER_surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - CS%diag => diag - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - - call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) - - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 - endif - -end subroutine USER_surface_forcing_init - -end module user_surface_forcing diff --git a/config_src/infra/FMS1/MOM_coms_infra.F90 b/config_src/infra/FMS1/MOM_coms_infra.F90 new file mode 100644 index 0000000000..13f8006184 --- /dev/null +++ b/config_src/infra/FMS1/MOM_coms_infra.F90 @@ -0,0 +1,515 @@ +!> Thin interfaces to non-domain-oriented mpp communication subroutines +module MOM_coms_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use iso_fortran_env, only : int32, int64 + +use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe +use mpp_mod, only : mpp_set_current_pelist, mpp_get_current_pelist +use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, mpp_chksum +use mpp_mod, only : mpp_sum, mpp_max, mpp_min +use memutils_mod, only : print_memuse_stats +use fms_mod, only : fms_end, fms_init + +implicit none ; private + +public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist, sync_PEs +public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: any_across_PEs, all_across_PEs +public :: field_chksum, MOM_infra_init, MOM_infra_end + +! This module provides interfaces to the non-domain-oriented communication +! subroutines. + +!> Communicate an array, string or scalar from one PE to others +interface broadcast + module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D, broadcast_real3D +end interface broadcast + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +interface field_chksum + module procedure field_chksum_real_0d + module procedure field_chksum_real_1d + module procedure field_chksum_real_2d + module procedure field_chksum_real_3d + module procedure field_chksum_real_4d +end interface field_chksum + +!> Find the sum of field across PEs, and update PEs with the sums. +interface sum_across_PEs + module procedure sum_across_PEs_int4_0d + module procedure sum_across_PEs_int4_1d + module procedure sum_across_PEs_int8_0d + module procedure sum_across_PEs_int8_1d + module procedure sum_across_PEs_int8_2d + module procedure sum_across_PEs_real_0d + module procedure sum_across_PEs_real_1d + module procedure sum_across_PEs_real_2d +end interface sum_across_PEs + +!> Find the maximum value of field across PEs, and update PEs with the values. +interface max_across_PEs + module procedure max_across_PEs_int_0d + module procedure max_across_PEs_real_0d + module procedure max_across_PEs_real_1d +end interface max_across_PEs + +!> Find the minimum value of field across PEs, and update PEs with the values. +interface min_across_PEs + module procedure min_across_PEs_int_0d + module procedure min_across_PEs_real_0d + module procedure min_across_PEs_real_1d +end interface min_across_PEs + +contains + +!> Return the ID of the PE for the current process. +function PE_here() result(pe) + integer :: pe !< PE ID of the current process + pe = mpp_pe() +end function PE_here + +!> Return the ID of the root PE for the PE list of the current procss. +function root_PE() result(pe) + integer :: pe !< root PE ID + pe = mpp_root_pe() +end function root_PE + +!> Return the number of PEs for the current PE list. +function num_PEs() result(npes) + integer :: npes !< Number of PEs + npes = mpp_npes() +end function num_PEs + +!> Designate a PE as the root PE +subroutine set_rootPE(pe) + integer, intent(in) :: pe !< ID of the PE to be assigned as root + call mpp_set_root_pe(pe) +end subroutine + +!> Set the current PE list. If no list is provided, then the current PE list +!! is set to the list of all available PEs on the communicator. Setting the +!! list will trigger a rank synchronization unless the `no_sync` flag is set. +subroutine Set_PEList(pelist, no_sync) + integer, optional, intent(in) :: pelist(:) !< List of PEs to set for communication + logical, optional, intent(in) :: no_sync !< Do not sync after list update. + call mpp_set_current_pelist(pelist, no_sync) +end subroutine Set_PEList + +!> Retrieve the current PE list and any metadata if requested. +subroutine Get_PEList(pelist, name, commID) + integer, intent(out) :: pelist(:) !< List of PE IDs of the current PE list + character(len=*), optional, intent(out) :: name !< Name of PE list + integer, optional, intent(out) :: commID !< Communicator ID of PE list + + call mpp_get_current_pelist(pelist, name, commiD) +end subroutine Get_PEList + +!> Sync the PEs at a defined point in the model +subroutine sync_PEs(pelist) + integer, optional, intent(in) :: pelist(:) !< The list of PEs to be synced + + call mpp_sync(pelist) +end subroutine sync_PEs + +!> Communicate a 1-D array of character strings from one PE to others +subroutine broadcast_char(dat, length, from_PE, PElist, blocking) + character(len=*), intent(inout) :: dat(:) !< The data to communicate and destination + integer, intent(in) :: length !< The length of each string + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_char + +!> Communicate an integer from one PE to others +subroutine broadcast_int64_0D(dat, from_PE, PElist, blocking) + integer(kind=int64), intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int64_0D + + +!> Communicate an integer from one PE to others +subroutine broadcast_int32_0D(dat, from_PE, PElist, blocking) + integer(kind=int32), intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int32_0D + +!> Communicate a 1-D array of integers from one PE to others +subroutine broadcast_int1D(dat, length, from_PE, PElist, blocking) + integer, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int1D + +!> Communicate a real number from one PE to others +subroutine broadcast_real0D(dat, from_PE, PElist, blocking) + real, intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real0D + +!> Communicate a 1-D array of reals from one PE to others +subroutine broadcast_real1D(dat, length, from_PE, PElist, blocking) + real, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real1D + +!> Communicate a 2-D array of reals from one PE to others +subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real2D + + +!> Communicate a 3-D array of reals from one PE to others +subroutine broadcast_real3D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real3D + +! field_chksum wrappers + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_0d(field, pelist, mask_val) result(chksum) + real, intent(in) :: field !< Input scalar + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_0d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_1d(field, pelist, mask_val) result(chksum) + real, dimension(:), intent(in) :: field !< Input array + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_1d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_2d(field, pelist, mask_val) result(chksum) + real, dimension(:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_2d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_3d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_3d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_4d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_4d + +! sum_across_PEs wrappers + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_int4_0d(field, pelist) + integer(kind=int32), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int4_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int4_1d(field, length, pelist) + integer(kind=int32), dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int4_1d + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_int8_0d(field, pelist) + integer(kind=int64), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int8_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int8_1d(field, length, pelist) + integer(kind=int64), dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int8_2d(field, length, pelist) + integer(kind=int64), & + dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_2d + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_real_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_real_2d(field, length, pelist) + real, dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_2d + +! max_across_PEs wrappers + +!> Find the maximum value of field across PEs, and store this maximum in field. +subroutine max_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, pelist) +end subroutine max_across_PEs_int_0d + +!> Find the maximum value of field across PEs, and store this maximum in field. +subroutine max_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, pelist) +end subroutine max_across_PEs_real_0d + +!> Find the maximum values in each position of field across PEs, and store these minima in field. +subroutine max_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! maxima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, length, pelist) +end subroutine max_across_PEs_real_1d + +! min_across_PEs wrappers + +!> Find the minimum value of field across PEs, and store this minimum in field. +subroutine min_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_min(field, pelist) +end subroutine min_across_PEs_int_0d + +!> Find the minimum value of field across PEs, and store this minimum in field. +subroutine min_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + call mpp_min(field, pelist) +end subroutine min_across_PEs_real_0d + +!> Find the minimum values in each position of field across PEs, and store these minima in field. +subroutine min_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! minima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_min(field, length, pelist) +end subroutine min_across_PEs_real_1d + +!> Implementation of any() intrinsic across PEs +function any_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: any_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call max_across_PEs(field_flag, pelist) + any_across_PEs = (field_flag > 0) +end function any_across_PEs + +!> Implementation of all() intrinsic across PEs +function all_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: all_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call min_across_PEs(field_flag, pelist) + all_across_PEs = (field_flag > 0) +end function all_across_PEs + +!> Initialize the model framework, including PE communication over a designated communicator. +!! If no communicator ID is provided, the framework's default communicator is used. +subroutine MOM_infra_init(localcomm) + integer, optional, intent(in) :: localcomm !< Communicator ID to initialize + call fms_init(localcomm) +end subroutine + +!> This subroutine carries out all of the calls required to close out the infrastructure cleanly. +!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. +subroutine MOM_infra_end + call print_memuse_stats( 'Memory HiWaterMark', always=.TRUE. ) + call fms_end() +end subroutine MOM_infra_end + +end module MOM_coms_infra diff --git a/src/framework/MOM_constants.F90 b/config_src/infra/FMS1/MOM_constants.F90 similarity index 100% rename from src/framework/MOM_constants.F90 rename to config_src/infra/FMS1/MOM_constants.F90 diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90 new file mode 100644 index 0000000000..637f2b5ebf --- /dev/null +++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90 @@ -0,0 +1,501 @@ +!> This module wraps the FMS coupler types module +module MOM_couplertype_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data +use coupler_types_mod, only : coupler_type_increment_data, coupler_type_rescale_data +use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data +use coupler_types_mod, only : coupler_type_data_override +use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux +use MOM_domain_infra, only : domain2D +use MOM_time_manager, only : time_type + +implicit none ; private + +public :: CT_spawn, CT_initialized, CT_destructor +public :: CT_set_diags, CT_send_data, CT_data_override, CT_write_chksums +public :: CT_set_data, CT_increment_data, CT_rescale_data +public :: CT_copy_data, CT_extract_data, CT_redistribute_data +public :: atmos_ocn_coupler_flux +public :: ind_flux, ind_alpha, ind_csurf +public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type + +!> This is the interface to spawn one coupler_bc_type into another. +interface CT_spawn + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d +end interface CT_spawn + +!> This function interface indicates whether a coupler_bc_type has been initialized. +interface CT_initialized + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d +end interface CT_initialized + +!> This is the interface to deallocate any data associated with a coupler_bc_type. +interface CT_destructor + module procedure CT_destructor_1d, CT_destructor_2d +end interface CT_destructor + +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. +interface CT_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface CT_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface CT_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface CT_increment_data + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface CT_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface CT_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface CT_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface CT_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface CT_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface CT_write_chksums + +contains + +!> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux +!! and retuns an integer index for that flux. +function atmos_ocn_coupler_flux(name, flux_type, implementation, param, mol_wt, & + ice_restart_file, ocean_restart_file, units, caller, verbosity) & + result (coupler_index) + + character(len=*), intent(in) :: name !< A name to use for the flux + character(len=*), intent(in) :: flux_type !< A string describing the type of this flux, + !! perhaps 'air_sea_gas_flux'. + character(len=*), intent(in) :: implementation !< A name describing the specific + !! implementation of this flux, such as 'ocmip2'. + real, dimension(:), optional, intent(in) :: param !< An array of parameters used for the fluxes + real, optional, intent(in) :: mol_wt !< The molecular weight of this tracer + character(len=*), optional, intent(in) :: ice_restart_file !< A sea-ice restart file to use with this flux. + character(len=*), optional, intent(in) :: ocean_restart_file !< An ocean restart file to use with this flux. + character(len=*), optional, intent(in) :: units !< The units of the flux + character(len=*), optional, intent(in) :: caller !< The name of the calling routine + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + integer :: coupler_index !< The resulting integer handle to use for this flux in subsequent calls. + + coupler_index = aof_set_coupler_flux(name, flux_type, implementation, & + param=param, mol_wt=mol_wt, ice_restart_file=ice_restart_file, & + ocean_restart_file=ocean_restart_file, & + units=units, caller=caller, verbosity=verbosity) + +end function atmos_ocn_coupler_flux + +!> Generate a 2-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_2d + +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + +!> Generate one 2-D coupler type using another 2-D coupler type as a template. +subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_2d + +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d + +!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) + type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev) + +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call coupler_type_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d + +!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. +subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & + scale_factor, halo_size, idim, jdim) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the boundary + !! condition that is being copied, or the + !! surface flux by default. + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + call coupler_type_extract_data(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim) + +end subroutine CT_extract_data + +!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. +subroutine CT_set_data(array_in, bc_index, field_index, var, & + scale_factor, halo_size, idim, jdim) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being set. The + !! surface concentration is set by default. + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + + call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) + +end subroutine CT_set_data + +!> Potentially override the values in a coupler_2d_bc_type +subroutine CT_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_data_override(gridname, var, time) +end subroutine CT_data_override + +!> Register the diagnostics of a coupler_2d_bc_type +subroutine CT_set_diags(var, diag_name, axes, time) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics + character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields + integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration + type(time_type), intent(in) :: time !< model time variable for registering diagnostic field + + call coupler_type_set_diags(var, diag_name, axes, time) + +end subroutine CT_set_diags + +!> Write out all diagnostics of elements of a coupler_2d_bc_type +subroutine CT_send_data(var, Time) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_send_data(var, Time) +end subroutine CT_send_data + +!> Write out checksums for the elements of a coupler_2d_bc_type +subroutine CT_write_chksums_2d(var, outunit, name_lead) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d + +!> Indicate whether a coupler_1d_bc_type has been initialized. +logical function CT_initialized_1d(var) + type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_1d = coupler_type_initialized(var) +end function CT_initialized_1d + +!> Indicate whether a coupler_2d_bc_type has been initialized. +logical function CT_initialized_2d(var) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_2d = coupler_type_initialized(var) +end function CT_initialized_2d + +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = coupler_type_initialized(var) +end function CT_initialized_3d + +!> Deallocate all data associated with a coupler_1d_bc_type +subroutine CT_destructor_1d(var) + type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_1d + +!> Deallocate all data associated with a coupler_2d_bc_type +subroutine CT_destructor_2d(var) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_2d + +end module MOM_couplertype_infra diff --git a/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 new file mode 100644 index 0000000000..0c42c577b4 --- /dev/null +++ b/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 @@ -0,0 +1,99 @@ +!> Wraps the MPP cpu clock functions +!! +!! The functions and constants should be accessed via mom_cpu_clock +module MOM_cpu_clock_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module +use fms_mod, only : clock_flag_default +use mpp_mod, only : mpp_clock_begin +use mpp_mod, only : mpp_clock_end, mpp_clock_id +use mpp_mod, only : MPP_CLOCK_COMPONENT => CLOCK_COMPONENT +use mpp_mod, only : MPP_CLOCK_SUBCOMPONENT => CLOCK_SUBCOMPONENT +use mpp_mod, only : MPP_CLOCK_MODULE_DRIVER => CLOCK_MODULE_DRIVER +use mpp_mod, only : MPP_CLOCK_MODULE => CLOCK_MODULE +use mpp_mod, only : MPP_CLOCK_ROUTINE => CLOCK_ROUTINE +use mpp_mod, only : MPP_CLOCK_LOOP => CLOCK_LOOP +use mpp_mod, only : MPP_CLOCK_INFRA => CLOCK_INFRA + +implicit none ; private + +! Public entities +public :: cpu_clock_id, cpu_clock_begin, cpu_clock_end +public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE +public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! component, e.g. the entire MOM6 model +integer, parameter :: CLOCK_COMPONENT = MPP_CLOCK_COMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! sub-component, e.g. dynamics or thermodynamics +integer, parameter :: CLOCK_SUBCOMPONENT = MPP_CLOCK_SUBCOMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module driver, e.g. a routine that calls multiple other routines +integer, parameter :: CLOCK_MODULE_DRIVER = MPP_CLOCK_MODULE_DRIVER + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module, e.g. the main entry routine for a module +integer, parameter :: CLOCK_MODULE = MPP_CLOCK_MODULE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! subroutine or function +integer, parameter :: CLOCK_ROUTINE = MPP_CLOCK_ROUTINE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! section with in a routine, e.g. around a loop +integer, parameter :: CLOCK_LOOP = MPP_CLOCK_LOOP + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for an +!! infrastructure operation, e.g. a halo update +integer, parameter :: CLOCK_INFRA = MPP_CLOCK_INFRA + +contains + +!> Turns on clock with handle "id" +subroutine cpu_clock_begin(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_begin(id) + +end subroutine cpu_clock_begin + +!> Turns off clock with handle "id" +subroutine cpu_clock_end(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_end(id) + +end subroutine cpu_clock_end + +!> Returns the integer handle for a named CPU clock. +integer function cpu_clock_id(name, sync, grain) + character(len=*), intent(in) :: name !< The unique name of the CPU clock + logical, optional, intent(in) :: sync !< A flag that controls whether the + !! PEs are synchronized before the cpu clocks start counting. + !! Synchronization occurs before the start of a clock if this + !! is enabled, while additional (expensive) statistics can + !! set for other values. + !! If absent, the default is taken from the settings for FMS. + integer, optional, intent(in) :: grain !< The timing granularity for this clock, usually set to + !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. + + integer :: clock_flags + + clock_flags = clock_flag_default + if (present(sync)) then + if (sync) then + clock_flags = ibset(clock_flags, 0) + else + clock_flags = ibclr(clock_flags, 0) + endif + endif + + cpu_clock_id = mpp_clock_id(name, flags=clock_flags, grain=grain) +end function cpu_clock_id + +end module MOM_cpu_clock_infra diff --git a/config_src/infra/FMS1/MOM_data_override_infra.F90 b/config_src/infra/FMS1/MOM_data_override_infra.F90 new file mode 100644 index 0000000000..1484f0c128 --- /dev/null +++ b/config_src/infra/FMS1/MOM_data_override_infra.F90 @@ -0,0 +1,105 @@ +!> These interfaces allow for ocean or sea-ice variables to be replaced with data. +module MOM_data_override_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_time_manager, only : time_type +use data_override_mod, only : data_override_init +use data_override_mod, only : data_override +use data_override_mod, only : data_override_unset_domains + +implicit none ; private + +public :: impose_data_init, impose_data, impose_data_unset_domains + +!> Potentially override the values of a field in the model with values from a dataset. +interface impose_data + module procedure data_override_MD, data_override_2d +end interface + +contains + +!> Initialize the data override capability and set the domains for the ocean and ice components. +!> There should be a call to impose_data_init before impose_data is called. +subroutine impose_data_init(MOM_domain_in, Ocean_domain_in, Ice_domain_in) + type (MOM_domain_type), intent(in), optional :: MOM_domain_in + type (domain2d), intent(in), optional :: Ocean_domain_in + type (domain2d), intent(in), optional :: Ice_domain_in + + if (present(MOM_domain_in)) then + call data_override_init(Ocean_domain_in=MOM_domain_in%mpp_domain, Ice_domain_in=Ice_domain_in) + else + call data_override_init(Ocean_domain_in=Ocean_domain_in, Ice_domain_in=Ice_domain_in) + endif +end subroutine impose_data_init + + +!> Potentially override a 2-d field on a MOM6 domain with values from a dataset. +subroutine data_override_MD(domain, fieldname, data_2D, time, scale, override, is_ice) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call. + type(time_type), intent(in) :: time !< The model time, and the time for the data + real, optional, intent(in) :: scale !< A scaling factor that an overridden field is + !! multiplied by before it is returned. However, + !! if there is no override, there is no rescaling. + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + logical, optional, intent(in) :: is_ice !< If present and true, use the ice domain. + + logical :: overridden, is_ocean + integer :: i, j, is, ie, js, je + + overridden = .false. + is_ocean = .true. ; if (present(is_ice)) is_ocean = .not.is_ice + if (is_ocean) then + call data_override('OCN', fieldname, data_2D, time, override=overridden) + else + call data_override('ICE', fieldname, data_2D, time, override=overridden) + endif + + if (overridden .and. present(scale)) then ; if (scale /= 1.0) then + ! Rescale data in the computational domain if the data override has occurred. + call get_simple_array_i_ind(domain, size(data_2D,1), is, ie) + call get_simple_array_j_ind(domain, size(data_2D,2), js, je) + do j=js,je ; do i=is,ie + data_2D(i,j) = scale*data_2D(i,j) + enddo ; enddo + endif ; endif + + if (present(override)) override = overridden + +end subroutine data_override_MD + + +!> Potentially override a 2-d field with values from a dataset. +subroutine data_override_2d(gridname, fieldname, data_2D, time, override) + character(len=3), intent(in) :: gridname !< String identifying the model component, in MOM6 + !! and SIS this may be either 'OCN' or 'ICE' + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call + type(time_type), intent(in) :: time !< The model time, and the time for the data + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + + call data_override(gridname, fieldname, data_2D, time, override) + +end subroutine data_override_2d + +!> Unset domains that had previously been set for use by data_override. +subroutine impose_data_unset_domains(unset_Ocean, unset_Ice, must_be_set) + logical, intent(in), optional :: unset_Ocean !< If present and true, unset the ocean domain for overrides + logical, intent(in), optional :: unset_Ice !< If present and true, unset the sea-ice domain for overrides + logical, intent(in), optional :: must_be_set !< If present and true, it is a fatal error to unset + !! a domain that is not set. + + call data_override_unset_domains(unset_Ocean=unset_Ocean, unset_Ice=unset_Ice, & + must_be_set=must_be_set) +end subroutine impose_data_unset_domains + +end module MOM_data_override_infra + +!> \namespace MOM_data_override_infra +!! +!! The routines here wrap routines from the FMS module data_override_mod, which potentially replace +!! model values with values read from a data file. diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 new file mode 100644 index 0000000000..d9be18d33f --- /dev/null +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -0,0 +1,466 @@ +!> A wrapper for the FMS diag_manager routines. This module should be the +!! only MOM6 module which imports the FMS shared infrastructure for +!! diagnostics. Pass through interfaces are being documented +!! here and renamed in order to clearly identify these APIs as being +!! consistent with the FMS infrastructure (Any future updates to +!! those APIs would be applied here). +module MOM_diag_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use, intrinsic :: iso_fortran_env, only : real64 +use diag_axis_mod, only : fms_axis_init=>diag_axis_init +use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name +use diag_axis_mod, only : EAST, NORTH +use diag_data_mod, only : null_axis_id +use diag_manager_mod, only : fms_diag_manager_init => diag_manager_init +use diag_manager_mod, only : fms_diag_manager_end => diag_manager_end +use diag_manager_mod, only : send_data_fms => send_data +use diag_manager_mod, only : fms_diag_field_add_attribute => diag_field_add_attribute +use diag_manager_mod, only : DIAG_FIELD_NOT_FOUND +use diag_manager_mod, only : register_diag_field_fms => register_diag_field +use diag_manager_mod, only : register_static_field_fms => register_static_field +use diag_manager_mod, only : get_diag_field_id_fms => get_diag_field_id +use MOM_time_manager, only : time_type +use MOM_domain_infra, only : MOM_domain_type +use MOM_error_infra, only : MOM_error => MOM_err, FATAL, WARNING + +implicit none ; private + +!> transmit data for diagnostic output +interface register_diag_field_infra + module procedure register_diag_field_infra_scalar + module procedure register_diag_field_infra_array +end interface register_diag_field_infra + +!> transmit data for diagnostic output +interface send_data_infra + module procedure send_data_infra_0d, send_data_infra_1d + module procedure send_data_infra_2d, send_data_infra_3d +#ifdef OVERLOAD_R8 + module procedure send_data_infra_2d_r8, send_data_infra_3d_r8 +#endif +end interface send_data_infra + +!> Add an attribute to a diagnostic field +interface MOM_diag_field_add_attribute + module procedure MOM_diag_field_add_attribute_scalar_r + module procedure MOM_diag_field_add_attribute_scalar_i + module procedure MOM_diag_field_add_attribute_scalar_c + module procedure MOM_diag_field_add_attribute_r1d + module procedure MOM_diag_field_add_attribute_i1d +end interface MOM_diag_field_add_attribute + + +! Public interfaces +public MOM_diag_axis_init +public get_MOM_diag_axis_name +public MOM_diag_manager_init +public MOM_diag_manager_end +public send_data_infra +public diag_send_complete_infra +public diag_manager_set_time_end_infra +public MOM_diag_field_add_attribute +public register_diag_field_infra +public register_static_field_infra +public get_MOM_diag_field_id +! Public data +public null_axis_id +public DIAG_FIELD_NOT_FOUND +public EAST, NORTH + + +contains + +!> Initialize a diagnostic axis +integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & + & direction, edges, set_name, coarsen, null_axis) + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif + + if (present(MOM_domain)) then + coarsening = 1 ; if (present(coarsen)) coarsening = coarsen + if (coarsening == 1) 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 + 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.") + endif + else + if (present(coarsen)) then ; if (coarsen /= 1) then + call MOM_error(FATAL, "diag_axis_init does not support grid coarsening without a MOM_domain.") + endif ; endif + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges) + endif + +end function MOM_diag_axis_init + +!> Returns the short name of the axis +subroutine get_MOM_diag_axis_name(id, name) + integer, intent(in) :: id !< The axis numeric id + character(len=*), intent(out) :: name !< The short name of the axis + + call fms_get_diag_axis_name(id, name) + +end subroutine get_MOM_diag_axis_name + +!> Return a unique numeric ID field a module/field name combination. +integer function get_MOM_diag_field_id(module_name, field_name) + character(len=*), intent(in) :: module_name !< A module name string to query. + character(len=*), intent(in) :: field_name !< A field name string to query. + + + get_MOM_diag_field_id = -1 + get_MOM_diag_field_id = get_diag_field_id_fms(module_name, field_name) + +end function get_MOM_diag_field_id + +!> Initializes the diagnostic manager +subroutine MOM_diag_manager_init(diag_model_subset, time_init, err_msg) + integer, optional, intent(in) :: diag_model_subset !< An optional diagnostic subset + integer, dimension(6), optional, intent(in) :: time_init !< An optional reference time for diagnostics + !! The default uses the value contained in the + !! diag_table. Format is Y-M-D-H-M-S + character(len=*), optional, intent(out) :: err_msg !< Error message. + call FMS_diag_manager_init(diag_model_subset, time_init, err_msg) + +end subroutine MOM_diag_manager_init + +!> Close the diagnostic manager +subroutine MOM_diag_manager_end(time) + type(time_type), intent(in) :: time !< Model time at call to close. + + call FMS_diag_manager_end(time) + +end subroutine MOM_diag_manager_end + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_infra_scalar(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, & + err_msg, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Field units + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_scalar = register_diag_field_fms(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume) + +end function register_diag_field_infra_scalar + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_infra_array(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, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: verbose !< If true, provide additional log information + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + 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 !< The tile number for the current PE + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_array = register_diag_field_fms(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, area, volume) + +end function register_diag_field_infra_array + + +integer function register_static_field_infra(module_name, field_name, axes, long_name, units, & + missing_value, range, mask_variant, standard_name, do_not_log, interp_method, & + tile_count, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + 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 !< The tile number for the current PE + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + if(present(missing_value) .or. present(range)) then + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant=mask_variant, standard_name=standard_name, dynamic=.false.,& + do_not_log=do_not_log, interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) + else + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & mask_variant=mask_variant, standard_name=standard_name, dynamic=.false.,do_not_log=do_not_log, & + interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) + endif +end function register_static_field_infra + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_0d(diag_field_id, field, time, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, intent(in) :: field !< The value being recorded + TYPE(time_type), optional, intent(in) :: time !< The time for the current record + CHARACTER(len=*), optional, intent(out) :: err_msg !< An optional error message + + send_data_infra_0d = send_data_fms(diag_field_id, field, time, err_msg) +end function send_data_infra_0d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_1d(diag_field_id, field, is_in, ie_in, time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:), intent(in) :: field !< A 1-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:), optional, intent(in) :: mask !< An optional rank 1 logical mask + real, dimension(:), optional, intent(in) :: rmask !< An optional rank 1 mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + if(present(rmask) .or. present(weight)) then + if(present(rmask) .and. present(weight)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, mask=mask, rmask=rmask, ie_in=ie_in,& + weight=weight, err_msg=err_msg) + elseif(present(rmask)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, mask=mask, rmask=rmask, ie_in=ie_in,& + err_msg=err_msg) + elseif(present(weight)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, ie_in=ie_in, weight=weight,& + err_msg=err_msg) + endif + else + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, ie_in=ie_in, err_msg=err_msg) + endif + +end function send_data_infra_1d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_2d(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + if(present(rmask) .or. present(weight)) then + if(present(rmask) .and. present(weight)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + rmask=rmask, ie_in=ie_in, je_in=je_in, weight=weight, err_msg=err_msg) + elseif(present(rmask)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + rmask=rmask, ie_in=ie_in, je_in=je_in, err_msg=err_msg) + elseif(present(weight)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + ie_in=ie_in, je_in=je_in, weight=weight, err_msg=err_msg) + endif + else + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + ie_in=ie_in, je_in=je_in, err_msg=err_msg) + endif +end function send_data_infra_2d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_3d(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, & + rmask, ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d + + +#ifdef OVERLOAD_R8 +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_2d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) + +end function send_data_infra_2d_r8 + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & + ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d_r8 +#endif + +!> Add a real scalar attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, intent(in) :: att_value !< A real scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_r + +!> Add an integer attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, intent(in) :: att_value !< An integer scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_i + +!> Add a character string attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + character(len=*), intent(in) :: att_value !< A character string value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_c + +!> Add a real list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, dimension(:), intent(in) :: att_value !< An array of real values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_r1d + +!> Add a integer list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, dimension(:), intent(in) :: att_value !< An array of integer values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_i1d + +!> Needed for backwards compatibility, does nothing +subroutine diag_send_complete_infra () +end subroutine diag_send_complete_infra + +!> Needed for backwards compatibility, does nothing +subroutine diag_manager_set_time_end_infra(time) + type(time_type), intent(in) :: time !< The model time that simulation ends +end subroutine diag_manager_set_time_end_infra + +end module MOM_diag_manager_infra diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 new file mode 100644 index 0000000000..da977aa492 --- /dev/null +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -0,0 +1,2050 @@ +!> Describes the decomposed MOM domain and has routines for communications across PEs +module MOM_domain_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms_infra, only : PE_here, root_PE, num_PEs +use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL + +use mpp_domains_mod, only : domain2D, domain1D +use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain +use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents, mpp_get_layout +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain +use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains +use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains +use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update +use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized +use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update +use mpp_domains_mod, only : mpp_compute_block_extent, mpp_compute_extent +use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field +use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN +use mpp_domains_mod, only : FOLD_NORTH_EDGE, FOLD_SOUTH_EDGE, FOLD_EAST_EDGE, FOLD_WEST_EDGE +use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE +use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST +use fms_io_mod, only : file_exist, parse_mask_table +use fms_io_mod, only : fms_set_domain => set_domain +use fms_io_mod, only : fms_nullify_domain => nullify_domain +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get + +! This subroutine is not in MOM6/src but may be required by legacy drivers +! use mpp_domains_mod, only : global_field_sum => mpp_global_sum + +! The `group_pass_type` fields are never accessed, so we keep it as an FMS type +use mpp_domains_mod, only : group_pass_type => mpp_group_update_type + +implicit none ; private + +! These types are inherited from mpp, but are treated as opaque here. +public :: domain2D, domain1D, group_pass_type +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent +public :: deallocate_MOM_domain, get_global_shape, compute_block_extent, compute_extent +public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data +public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete +public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass +public :: redistribute_array, broadcast_domain, same_domain, global_field +public :: get_simple_array_i_ind, get_simple_array_j_ind +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! These are encoding constant parmeters with self-explanatory names. +public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +public :: set_domain, nullify_domain +! These are no longer used by MOM6 because the reproducing sum works so well, but they are +! still referenced by some of the non-GFDL couplers. +! public :: global_field_sum, BITWISE_EXACT_SUM + +!> Do a halo update on an array +interface pass_var + module procedure pass_var_3d, pass_var_2d +end interface pass_var + +!> Do a halo update on a pair of arrays representing the two components of a vector +interface pass_vector + module procedure pass_vector_3d, pass_vector_2d +end interface pass_vector + +!> Initiate a non-blocking halo update on an array +interface pass_var_start + module procedure pass_var_start_3d, pass_var_start_2d +end interface pass_var_start + +!> Complete a non-blocking halo update on an array +interface pass_var_complete + module procedure pass_var_complete_3d, pass_var_complete_2d +end interface pass_var_complete + +!> Initiate a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_start + module procedure pass_vector_start_3d, pass_vector_start_2d +end interface pass_vector_start + +!> Complete a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_complete + module procedure pass_vector_complete_3d, pass_vector_complete_2d +end interface pass_vector_complete + +!> Set up a group of halo updates +interface create_group_pass + module procedure create_var_group_pass_2d + module procedure create_var_group_pass_3d + module procedure create_vector_group_pass_2d + module procedure create_vector_group_pass_3d +end interface create_group_pass + +!> Do a set of halo updates that fill in the values at the duplicated edges +!! of a staggered symmetric memory domain +interface fill_symmetric_edges + module procedure fill_vector_symmetric_edges_2d !, fill_vector_symmetric_edges_3d +! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d +end interface fill_symmetric_edges + +!> Rescale the values of an array in its computational domain by a constant factor +interface rescale_comp_data + module procedure rescale_comp_data_4d, rescale_comp_data_3d, rescale_comp_data_2d +end interface rescale_comp_data + +!> Pass an array from one MOM domain to another +interface redistribute_array + module procedure redistribute_array_2d, redistribute_array_3d, redistribute_array_4d +end interface redistribute_array + +!> Copy one MOM_domain_type into another +interface clone_MOM_domain + module procedure clone_MD_to_MD, clone_MD_to_d2D +end interface clone_MOM_domain + +!> Extract the 1-d domain components from a MOM_domain or domain2d +interface get_domain_components + module procedure get_domain_components_MD, get_domain_components_d2D +end interface get_domain_components + +!> Returns the index ranges that have been stored in a MOM_domain_type +interface get_domain_extent + module procedure get_domain_extent_MD, get_domain_extent_d2D +end interface get_domain_extent + + +!> The MOM_domain_type contains information about the domain decomposition. +type, public :: MOM_domain_type + 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 + !! on this processor, centered at h points. + integer :: niglobal !< The total horizontal i-domain size. + integer :: njglobal !< The total horizontal j-domain size. + integer :: nihalo !< The i-halo size in memory. + integer :: njhalo !< The j-halo size in memory. + logical :: symmetric !< True if symmetric memory is used with this domain. + logical :: nonblocking_updates !< If true, non-blocking halo updates are + !! allowed. The default is .false. (for now). + logical :: thin_halo_updates !< If true, optional arguments may be used to + !! specify the width of the halos that are + !! updated with each call. + integer :: layout(2) !< This domain's processor layout. This is + !! saved to enable the construction of related + !! new domains with different resolutions or + !! other properties. + integer :: io_layout(2) !< The IO-layout used with this domain. + integer :: X_FLAGS !< Flag that specifies the properties of the + !! domain in the i-direction in a define_domain call. + integer :: Y_FLAGS !< Flag that specifies the properties of the + !! domain in the j-direction in a define_domain call. + logical, pointer :: maskmap(:,:) => NULL() !< A pointer to an array indicating + !! which logical processors are actually used for + !! the ocean code. The other logical processors + !! would be contain only land points and are not + !! assigned to actual processors. This need not be + !! assigned if all logical processors are used. + integer :: turns !< Number of quarter-turns from input to this grid. + type(MOM_domain_type), pointer :: domain_in => NULL() + !< Reference to unrotated domain (if turned) +end type MOM_domain_type + +integer, parameter :: To_All = To_East + To_West + To_North + To_South !< A flag for passing in all directions + +contains + +!> pass_var_3d does a halo update for a three-dimensional array. +subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! sothe halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_3d + +!> pass_var_2d does a halo update for a two-dimensional array. +subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo + !! by default. + integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, + !! or 0 to avoid updating symmetric memory + !! computational domain points. Setting this >=0 + !! also enforces that complete=.true. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + real, allocatable, dimension(:,:) :: tmp + integer :: pos, i_halo, j_halo + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + integer :: i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. ; if (present(complete)) block_til_complete = complete + pos = CENTER ; if (present(position)) pos = position + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + ! Store the original values. + allocate(tmp(size(array,1), size(array,2))) + tmp(:,:) = array(:,:) + block_til_complete = .true. + endif ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + ! Convert to local indices for arrays starting at 1. + isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1 + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1 + i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1) + + ! Figure out the array index extents of the eastern, western, northern and southern regions to copy. + if (pos == CENTER) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif + elseif (pos == CORNER) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + elseif (pos == NORTH_FACE) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif + elseif (pos == EAST_FACE) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif + else + call MOM_error(FATAL, "pass_var_2d: Unrecognized position") + endif + + ! Copy back the stored inner halo points + do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + + deallocate(tmp) + endif ; endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_2d + +!> pass_var_start_2d starts a halo update for a two-dimensional array. +function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_2d !0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_2d + +!> pass_var_start_3d starts a halo update for a three-dimensional array. +function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_3d !< The integer index for this update. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_3d + +!> pass_var_complete_2d completes a halo update for a two-dimensional array. +subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_2d + +!> pass_var_complete_3d completes a halo update for a three-dimensional array. +subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_3d + +!> pass_vector_2d does a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_2d + +!> fill_vector_symmetric_edges_2d does an usual set of halo updates that only +!! fill in the values at the edge of a pair of symmetric memory two-dimensional +!! arrays representing the components of a two-dimensional horizontal vector. +!! If symmetric memory is not being used, this subroutine does nothing except to +!! possibly turn optional cpu clocks on or off. +subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scalar, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: scalar !< An optional argument indicating whether. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y + + if (.not. MOM_dom%symmetric) then + return + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + if (.not.(stagger_local == CGRID_NE .or. stagger_local == BGRID_NE)) return + + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + + ! Adjust isc, etc., to account for the fact that the input arrays indices all + ! start at 1 (and are effectively on a SW grid!). + isc = isc - (isd-1) ; iec = iec - (isd-1) + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) + IscB = isc ; IecB = iec+1 ; JscB = jsc ; JecB = jec+1 + + dirflag = To_All ! 60 + if (present(scalar)) then ; if (scalar) dirflag = To_All+SCALAR_PAIR ; endif + + if (stagger_local == CGRID_NE) then + allocate(wbuff_x(jsc:jec)) ; allocate(sbuff_y(isc:iec)) + wbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbuffery=sbuff_y, & + gridtype=CGRID_NE) + do i=isc,iec + v_cmpt(i,JscB) = sbuff_y(i) + enddo + do j=jsc,jec + u_cmpt(IscB,j) = wbuff_x(j) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_y) + elseif (stagger_local == BGRID_NE) then + allocate(wbuff_x(JscB:JecB)) ; allocate(sbuff_x(IscB:IecB)) + allocate(wbuff_y(JscB:JecB)) ; allocate(sbuff_y(IscB:IecB)) + wbuff_x(:) = 0.0 ; wbuff_y(:) = 0.0 ; sbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbufferx=sbuff_x, & + wbuffery=wbuff_y, sbuffery=sbuff_y, & + gridtype=BGRID_NE) + do I=IscB,IecB + u_cmpt(I,JscB) = sbuff_x(I) ; v_cmpt(I,JscB) = sbuff_y(I) + enddo + do J=JscB,JecB + u_cmpt(IscB,J) = wbuff_x(J) ; v_cmpt(IscB,J) = wbuff_y(J) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_x) + deallocate(wbuff_y) ; deallocate(sbuff_y) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine fill_vector_symmetric_edges_2d + +!> pass_vector_3d does a halo update for a pair of three-dimensional arrays +!! representing the components of a three-dimensional horizontal vector. +subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_3d + +!> pass_vector_start_2d starts a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_2d !< The integer index for this + !! update. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_2d + +!> pass_vector_start_3d starts a halo update for a pair of three-dimensional arrays +!! representing the components of a three-dimensional horizontal vector. +function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_3d !< The integer index for this + !! update. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_3d + +!> pass_vector_complete_2d completes a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_2d + +!> pass_vector_complete_3d completes a halo update for a pair of three-dimensional +!! arrays representing the components of a three-dimensional horizontal vector. +subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_3d + +!> create_var_group_pass_2d sets up a group of two-dimensional array halo updates. +subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & + halo, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_2d + +!> create_var_group_pass_3d sets up a group of three-dimensional array halo updates. +subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_3d + +!> create_vector_group_pass_2d sets up a group of two-dimensional vector halo updates. +subroutine create_vector_group_pass_2d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_2d + +!> create_vector_group_pass_3d sets up a group of three-dimensional vector halo updates. +subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_3d + +!> do_group_pass carries out a group halo update. +subroutine do_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine do_group_pass + +!> start_group_pass starts out a group halo update. +subroutine start_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_start_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine start_group_pass + +!> complete_group_pass completes a group halo update. +subroutine complete_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_complete_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine complete_group_pass + + +!> Pass a 2-D array from one MOM domain to another +subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_2d + +!> Pass a 3-D array from one MOM domain to another +subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_3d + +!> Pass a 4-D array from one MOM domain to another +subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_4d + + +!> Rescale the values of a 4-D array in its computational domain by a constant factor +subroutine rescale_comp_data_4d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + +end subroutine rescale_comp_data_4d + +!> Rescale the values of a 3-D array in its computational domain by a constant factor +subroutine rescale_comp_data_3d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + +end subroutine rescale_comp_data_3d + +!> Rescale the values of a 2-D array in its computational domain by a constant factor +subroutine rescale_comp_data_2d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je) = scale*array(is:ie,js:je) + +end subroutine rescale_comp_data_2d + +!> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information +!! provided in arguments. +subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, io_layout, & + domain_name, mask_table, symmetric, thin_halos, nonblocking) + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here. + integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in + !! the i- and j-directions + integer, dimension(2), intent(in) :: n_halo !< The number of halo points on each processor + logical, dimension(2), intent(in) :: reentrant !< If true the grid is periodic in the i- and j- directions + logical, intent(in) :: tripolar_N !< If true the grid uses northern tripolar connectivity + integer, dimension(2), intent(in) :: layout !< The layout of logical PEs in the i- and j-directions. + integer, dimension(2), optional, intent(in) :: io_layout !< The layout for parallel input and output. + character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" if missing. + character(len=*), optional, intent(in) :: mask_table !< The full relative or absolute path to the mask table. + logical, optional, intent(in) :: symmetric !< If present, this specifies whether this domain + !! uses symmetric memory, or true if missing. + logical, optional, intent(in) :: thin_halos !< If present, this specifies whether to permit the use of + !! thin halo updates, or true if missing. + logical, optional, intent(in) :: nonblocking !< If present, this specifies whether to permit the use of + !! nonblocking halo updates, or false if missing. + + ! local variables + 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. + 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) + + X_FLAGS = 0 ; Y_FLAGS = 0 + if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (reentrant(2)) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (tripolar_N) then + Y_FLAGS = FOLD_NORTH_EDGE + if (reentrant(2)) call MOM_error(FATAL,"MOM_domains: "// & + "TRIPOLAR_N and REENTRANT_Y may not be used together.") + endif + + MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = thin_halos + MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric + MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) + MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) + + ! Save the extra data for creating other domains of different resolution that overlay this domain. + MOM_dom%X_FLAGS = X_FLAGS + MOM_dom%Y_FLAGS = Y_FLAGS + MOM_dom%layout(:) = layout(:) + + ! Set up the io_layout, with error handling. + MOM_dom%io_layout(:) = (/ 1, 1 /) + if (present(io_layout)) then + if (io_layout(1) == 0) then + MOM_dom%io_layout(1) = layout(1) + elseif (io_layout(1) > 1) then + MOM_dom%io_layout(1) = io_layout(1) + if (modulo(layout(1), io_layout(1)) /= 0) then + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1) + call MOM_error(FATAL, mesg) + endif + endif + + if (io_layout(2) == 0) then + MOM_dom%io_layout(2) = layout(2) + elseif (io_layout(2) > 1) then + MOM_dom%io_layout(2) = io_layout(2) + if (modulo(layout(2), io_layout(2)) /= 0) then + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2) + call MOM_error(FATAL, mesg) + endif + endif + endif + + if (present(mask_table)) then + mask_table_exists = file_exist(mask_table) + if (mask_table_exists) then + allocate(MOM_dom%maskmap(layout(1), layout(2))) + call parse_mask_table(mask_table, MOM_dom%maskmap, MOM_dom%name) + endif + else + mask_table_exists = .false. + endif + + ! Initialize as an unrotated domain + MOM_dom%turns = 0 + + 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 +!! and potentially all of its contents +subroutine deallocate_MOM_domain(MOM_domain, cursory) + type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated + 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 + + invasive = .true. ; if (present(cursory)) invasive = .not.cursory + + if (associated(MOM_domain)) then + if (associated(MOM_domain%mpp_domain)) then + 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) + endif + if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) + deallocate(MOM_domain) + endif + +end subroutine deallocate_MOM_domain + +!> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. +function MOM_thread_affinity_set() + ! Local variables + !$ integer :: ocean_nthreads ! Number of openMP threads + !$ integer :: omp_get_num_threads ! An openMP function that returns the number of threads + logical :: MOM_thread_affinity_set + + MOM_thread_affinity_set = .false. + !$ call fms_affinity_init() + !$OMP PARALLEL + !$OMP MASTER + !$ ocean_nthreads = omp_get_num_threads() + !$OMP END MASTER + !$OMP END PARALLEL + !$ MOM_thread_affinity_set = (ocean_nthreads > 1 ) +end function MOM_thread_affinity_set + +!> set_MOM_thread_affinity sets the number of openMP threads to use with the ocean. +subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) + integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model + logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading + + ! Local variables + !$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions + + !$ call fms_affinity_init() ! fms_affinity_init can be safely called more than once. + !$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads) + !$ call omp_set_num_threads(ocean_nthreads) + !$OMP PARALLEL + !$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() + !$ flush(6) + !$OMP END PARALLEL +end subroutine set_MOM_thread_affinity + +!> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain +subroutine get_domain_components_MD(MOM_dom, x_domain, y_domain) + type(MOM_domain_type), intent(in) :: MOM_dom !< The MOM_domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(MOM_dom%mpp_domain, x_domain, y_domain) +end subroutine get_domain_components_MD + +!> This subroutine retrieves the 1-d domains that make up a 2d-domain +subroutine get_domain_components_d2D(domain, x_domain, y_domain) + type(domain2D), intent(in) :: domain !< The 2D domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(domain, x_domain, y_domain) +end subroutine get_domain_components_d2D + +!> clone_MD_to_MD copies one MOM_domain_type into another, while allowing +!! some properties of the new type to differ from the original one. +subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & + turns, refine, extra_halo, io_layout) + type(MOM_domain_type), target, intent(in) :: MD_in !< An existing MOM_domain + type(MOM_domain_type), pointer :: MOM_dom + !< A pointer to a MOM_domain that will be + !! allocated if it is unassociated, and will have data + !! copied from MD_in + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, copied + !! from MD_in if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns + integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution. + integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos + !! compared with MD_in + integer, optional, intent(in) :: io_layout(2) + !< A user-defined IO layout to replace the domain's IO layout + + logical :: mask_table_exists + integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer, dimension(:), allocatable :: exnj ! The extents of the grid for each j-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. + integer :: i, j, nl1, nl2 + integer :: io_layout_in(2) + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (present(io_layout)) then + io_layout_in(:) = io_layout(:) + else + io_layout_in(:) = MD_in%io_layout(:) + endif + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + +! Save the extra data for creating other domains of different resolution that overlay this domain + MOM_dom%symmetric = MD_in%symmetric + MOM_dom%nonblocking_updates = MD_in%nonblocking_updates + MOM_dom%thin_halo_updates = MD_in%thin_halo_updates + + if (modulo(qturns, 2) /= 0) then + MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal + MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo + call get_layout_extents(MD_in, exnj, exni) + + MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (qturns == 1) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + elseif (qturns == 3) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + endif + + MOM_dom%layout(:) = MD_in%layout(2:1:-1) + MOM_dom%io_layout(:) = io_layout_in(2:1:-1) + else + MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal + MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo + call get_layout_extents(MD_in, exni, exnj) + + MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (qturns == 2) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + endif + + MOM_dom%layout(:) = MD_in%layout(:) + MOM_dom%io_layout(:) = io_layout_in(:) + endif + + ! Ensure that the points per processor are the same on the source and destination grids. + select case (qturns) + case (1) ; call invert(exni) + case (2) ; call invert(exni) ; call invert(exnj) + case (3) ; call invert(exnj) + end select + + if (associated(MD_in%maskmap)) then + mask_table_exists = .true. + allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) + + nl1 = MOM_dom%layout(1) ; nl2 = MOM_dom%layout(2) + select case (qturns) + case (0) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(i, j) + enddo ; enddo + case (1) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(j, nl1+1-i) + enddo ; enddo + case (2) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl1+1-i, nl2+1-j) + enddo ; enddo + case (3) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl2+1-j, i) + enddo ; enddo + end select + else + mask_table_exists = .false. + endif + + ! Optionally enhance the grid resolution. + if (present(refine)) then ; if (refine > 1) then + MOM_dom%niglobal = refine*MOM_dom%niglobal ; MOM_dom%njglobal = refine*MOM_dom%njglobal + MOM_dom%nihalo = refine*MOM_dom%nihalo ; MOM_dom%njhalo = refine*MOM_dom%njhalo + do i=1,MOM_dom%layout(1) ; exni(i) = refine*exni(i) ; enddo + do j=1,MOM_dom%layout(2) ; exnj(j) = refine*exnj(j) ; enddo + endif ; endif + + ! Optionally enhance the grid resolution. + if (present(extra_halo)) then ; if (extra_halo > 0) then + MOM_dom%nihalo = MOM_dom%nihalo + extra_halo ; MOM_dom%njhalo = MOM_dom%njhalo + extra_halo + endif ; endif + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + if (present(min_halo)) then + MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) + min_halo(1) = MOM_dom%nihalo + MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) + min_halo(2) = MOM_dom%njhalo + endif + + if (present(halo_size)) then + MOM_dom%nihalo = halo_size ; MOM_dom%njhalo = halo_size + endif + + if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif + + if (present(domain_name)) then + MOM_dom%name = trim(domain_name) + else + MOM_dom%name = MD_in%name + endif + + MOM_dom%turns = qturns + if (qturns /= 0) then + MOM_dom%domain_in => MD_in + 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 + + +!> clone_MD_to_d2D uses information from a MOM_domain_type to create a new +!! domain2d type, while allowing some properties of the new type to differ from +!! the original one. +subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & + domain_name, turns, xextent, yextent, coarsen) + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned + type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined or + !! whether MD_in is symmetric. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns - not implemented here. + integer, optional, intent(in) :: coarsen !< A factor by which to coarsen this grid. + !! The default of 1 is for no coarsening. + integer, dimension(:), optional, intent(in) :: xextent !< The number of grid points in the + !! tracer computational domain for division of the x-layout. + integer, dimension(:), optional, intent(in) :: yextent !< The number of grid points in the + !! tracer computational domain for division of the y-layout. + + integer :: global_indices(4) + integer :: nihalo, njhalo + logical :: symmetric_dom, do_coarsen + character(len=64) :: dom_name + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + do_coarsen = .false. ; if (present(coarsen)) then ; do_coarsen = (coarsen > 1) ; endif + + nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo + if (do_coarsen) then + nihalo = int(MD_in%nihalo / coarsen) ; njhalo = int(MD_in%njhalo / coarsen) + endif + + if (present(min_halo)) then + nihalo = max(nihalo, min_halo(1)) + njhalo = max(njhalo, min_halo(2)) + min_halo(1) = nihalo ; min_halo(2) = njhalo + endif + if (present(halo_size)) then + nihalo = halo_size ; njhalo = halo_size + endif + + symmetric_dom = MD_in%symmetric + if (present(symmetric)) then ; symmetric_dom = symmetric ; endif + + dom_name = MD_in%name + if (do_coarsen) dom_name = trim(MD_in%name)//"c" + if (present(domain_name)) dom_name = trim(domain_name) + + global_indices(1:4) = (/ 1, MD_in%niglobal, 1, MD_in%njglobal /) + if (do_coarsen) then + global_indices(1:4) = (/ 1, (MD_in%niglobal/coarsen), 1, (MD_in%njglobal/coarsen) /) + endif + + if (associated(MD_in%maskmap)) then + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + xextent=xextent, yextent=yextent, symmetry=symmetric_dom, name=dom_name, & + maskmap=MD_in%maskmap ) + else + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + symmetry=symmetric_dom, xextent=xextent, yextent=yextent, name=dom_name) + endif + + if (MD_in%layout(1) * MD_in%layout(2) > 1) then + if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0)) then + call mpp_define_io_domain(mpp_domain, MD_in%io_layout) + else + call mpp_define_io_domain(mpp_domain, [1, 1] ) + endif + endif +end subroutine clone_MD_to_d2D + +!> Returns the index ranges that have been stored in a MOM_domain_type +subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & + isg, ieg, jsg, jeg, idg_offset, jdg_offset, & + symmetric, local_indexing, index_offset, coarsen) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, intent(out) :: isd !< The start i-index of the data domain + integer, intent(out) :: ied !< The end i-index of the data domain + integer, intent(out) :: jsd !< The start j-index of the data domain + integer, intent(out) :: jed !< The end j-index of the data domain + integer, optional, intent(out) :: isg !< The start i-index of the global domain + integer, optional, intent(out) :: ieg !< The end i-index of the global domain + integer, optional, intent(out) :: jsg !< The start j-index of the global domain + integer, optional, intent(out) :: jeg !< The end j-index of the global domain + integer, optional, intent(out) :: idg_offset !< The offset between the corresponding global and + !! data i-index spaces. + integer, optional, intent(out) :: jdg_offset !< The offset between the corresponding global and + !! data j-index spaces. + logical, optional, intent(out) :: symmetric !< True if symmetric memory is used. + logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, + !! as in most MOM6 code. The default is true. + 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. + + ! Local variables + integer :: isg_, ieg_, jsg_, jeg_ + integer :: ind_off, idg_off, jdg_off, coarsen_lev + logical :: local + + 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 + + if (coarsen_lev == 1) 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.") + endif + + if (local) then + ! This code institutes the MOM convention that local array indices start at 1. + idg_off = isd - 1 ; jdg_off = jsd - 1 + isc = isc - isd + 1 ; iec = iec - isd + 1 ; jsc = jsc - jsd + 1 ; jec = jec - jsd + 1 + ied = ied - isd + 1 ; jed = jed - jsd + 1 + isd = 1 ; jsd = 1 + else + idg_off = 0 ; jdg_off = 0 + endif + if (ind_off /= 0) then + idg_off = idg_off + ind_off ; jdg_off = jdg_off + ind_off + isc = isc + ind_off ; iec = iec + ind_off + jsc = jsc + ind_off ; jec = jec + ind_off + isd = isd + ind_off ; ied = ied + ind_off + jsd = jsd + ind_off ; jed = jed + ind_off + endif + if (present(isg)) isg = isg_ + if (present(ieg)) ieg = ieg_ + if (present(jsg)) jsg = jsg_ + if (present(jeg)) jeg = jeg_ + if (present(idg_offset)) idg_offset = idg_off + if (present(jdg_offset)) jdg_offset = jdg_off + if (present(symmetric)) symmetric = Domain%symmetric + +end subroutine get_domain_extent_MD + +!> Returns the index ranges that have been stored in a domain2D type +subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) + type(domain2d), intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, optional, intent(out) :: isd !< The start i-index of the data domain + integer, optional, intent(out) :: ied !< The end i-index of the data domain + integer, optional, intent(out) :: jsd !< The start j-index of the data domain + integer, optional, intent(out) :: jed !< The end j-index of the data domain + + ! Local variables + integer :: isd_, ied_, jsd_, jed_ + + call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_) + + if (present(isd)) isd = isd_ + if (present(ied)) ied = ied_ + if (present(jsd)) jsd = jsd_ + if (present(jed)) jed = jed_ + +end subroutine get_domain_extent_d2D + +!> Return the (potentially symmetric) computational domain i-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The i-array size + integer, intent(out) :: is !< The computational domain starting i-index. + integer, intent(out) :: ie !< The computational domain ending i-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + isc = isc-isd+1 ; iec = iec-isd+1 ; ied = ied-isd+1 ; isd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == ied) then ; is = isc ; ie = iec + elseif (size == 1+iec-isc) then ; is = 1 ; ie = size + elseif (sym .and. (size == 1+ied)) then ; is = isc ; ie = iec+1 + elseif (sym .and. (size == 2+iec-isc)) then ; is = 1 ; ie = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_i_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') ied, 1+iec-isc + else + write(mesg2,'("Valid sizes are : ", 4i7)') ied, 1+iec-isc, 1+ied, 2+iec-isc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_i_ind + + +!> Return the (potentially symmetric) computational domain j-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_j_ind(domain, size, js, je, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The j-array size + integer, intent(out) :: js !< The computational domain starting j-index. + integer, intent(out) :: je !< The computational domain ending j-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + jsc = jsc-jsd+1 ; jec = jec-jsd+1 ; jed = jed-jsd+1 ; jsd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == jed) then ; js = jsc ; je = jec + elseif (size == 1+jec-jsc) then ; js = 1 ; je = size + elseif (sym .and. (size == 1+jed)) then ; js = jsc ; je = jec+1 + elseif (sym .and. (size == 2+jec-jsc)) then ; js = 1 ; je = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_j_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') jed, 1+jec-jsc + else + write(mesg2,'("Valid sizes are : ", 4i7)') jed, 1+jec-jsc, 1+jed, 2+jec-jsc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_j_ind + +!> Invert the contents of a 1-d array +subroutine invert(array) + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo +end subroutine invert + +!> Returns the global shape of h-point arrays +subroutine get_global_shape(domain, niglobal, njglobal) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(out) :: niglobal !< i-index global size of h-point arrays + integer, intent(out) :: njglobal !< j-index global size of h-point arrays + + niglobal = domain%niglobal + njglobal = domain%njglobal +end subroutine get_global_shape + +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_block_extent + +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_extent + +!> Broadcast a 2-d domain from the root PE to the other PEs +subroutine broadcast_domain(domain) + type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs. + + call mpp_broadcast_domain(domain) +end subroutine broadcast_domain + +!> Broadcast an entire 2-d array from the root processor to all others. +subroutine global_field(domain, local, global) + type(domain2d), intent(inout) :: domain !< The domain2d type that describes the decomposition + real, dimension(:,:), intent(in) :: local !< The portion of the array on the local PE + real, dimension(:,:), intent(out) :: global !< The whole global array + + call mpp_global_field(domain, local, global) +end subroutine global_field + +!> same_domain returns true if two domains use the same list of PEs and layouts and have the same +!! size computational domains, and false if the domains do not conform with each other. +!! Different halo sizes or indexing conventions do not alter the results. +logical function same_domain(domain_a, domain_b) + type(domain2D), intent(in) :: domain_a !< The first domain in the comparison + type(domain2D), intent(in) :: domain_b !< The second domain in the comparison + + ! Local variables + integer :: isc_a, iec_a, jsc_a, jec_a, isc_b, iec_b, jsc_b, jec_b + integer :: layout_a(2), layout_b(2) + + ! This routine currently does a few checks for consistent domains; more could be added. + call mpp_get_layout(domain_a, layout_a) + call mpp_get_layout(domain_b, layout_b) + + call get_domain_extent(domain_a, isc_a, iec_a, jsc_a, jec_a) + call get_domain_extent(domain_b, isc_b, iec_b, jsc_b, jec_b) + + same_domain = (layout_a(1) == layout_b(1)) .and. (layout_a(2) == layout_b(2)) .and. & + (iec_a - isc_a == iec_b - isc_b) .and. (jec_a - jsc_a == jec_b - jsc_b) + +end function same_domain + +!> Returns arrays of the i- and j- sizes of the h-point computational domains for each +!! element of the grid layout. Any input values in the extent arrays are discarded, so +!! they are effectively intent out despite their declared intent of inout. +subroutine get_layout_extents(Domain, extent_i, extent_j) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, dimension(:), allocatable, intent(inout) :: extent_i !< The number of points in the + !! i-direction in each i-row of the layout + integer, dimension(:), allocatable, intent(inout) :: extent_j !< The number of points in the + !! j-direction in each j-row of the layout + + if (allocated(extent_i)) deallocate(extent_i) + if (allocated(extent_j)) deallocate(extent_j) + allocate(extent_i(domain%layout(1))) ; extent_i(:) = 0 + allocate(extent_j(domain%layout(2))) ; extent_j(:) = 0 + call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) +end subroutine get_layout_extents + +!> Set the associated domain for internal FMS I/O operations. +subroutine set_domain(Domain) + type(MOM_domain_type), intent(in) :: Domain + !< MOM domain to be designated as the internal FMS I/O domain + + call fms_set_domain(Domain%mpp_domain) +end subroutine set_domain + +!> Free the associated domain for internal FMS I/O operations. +subroutine nullify_domain + call fms_nullify_domain +end subroutine nullify_domain + +end module MOM_domain_infra diff --git a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 new file mode 100644 index 0000000000..c91097b686 --- /dev/null +++ b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 @@ -0,0 +1,104 @@ +!> A simple (very thin) wrapper for managing ensemble member layout information +module MOM_ensemble_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init +use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup +use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id +use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size +use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist +use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist +use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix + +implicit none ; private + +public :: ensemble_manager_init, ensemble_pelist_setup +public :: get_ensemble_id, get_ensemble_size +public :: get_ensemble_pelist, get_ensemble_filter_pelist + +contains + +!> Initializes the ensemble manager which divides available resources +!! in order to concurrently execute an ensemble of model realizations. +subroutine ensemble_manager_init(ensemble_suffix) + character(len=*), optional, intent(in) :: ensemble_suffix !> Ensemble suffix provided by the cap. This may be + !! provided to bypass FMS ensemble manager. + + if (present(ensemble_suffix)) then + call fms_io_set_filename_appendix(trim(ensemble_suffix)) + else + call FMS_ensemble_manager_init() + endif + +end subroutine ensemble_manager_init + +!> Create a list of processing elements (PEs) across components +!! associated with the current ensemble member. +subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, waves_npes,, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist, Wave_pelist) + logical, intent(in) :: concurrent !< A logical flag, if True, then ocean fast + !! PEs are run concurrently with + !! slow PEs within the coupler. + integer, intent(in) :: atmos_npes !< The number of atmospheric (fast) PEs + integer, intent(in) :: ocean_npes !< The number of ocean (slow) PEs + integer, intent(in) :: land_npes !< The number of land PEs (fast) + integer, intent(in) :: ice_npes !< The number of ice (fast) PEs + integer, intent(in) :: waves_npes !< The number of wave PEs + integer, dimension(:), intent(inout) :: Atm_pelist !< A list of Atm PEs + integer, dimension(:), intent(inout) :: Ocean_pelist !< A list of Ocean PEs + integer, dimension(:), intent(inout) :: Land_pelist !< A list of Land PEs + integer, dimension(:), intent(inout) :: Ice_pelist !< A list of Ice PEs + integer, dimension(:), intent(inout) :: Wave_pelist !< A list of Wave PEs + + + call FMS_ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, waves_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist, Wave_pelist) + +end subroutine ensemble_pelist_setup + +!> Returns the numeric id for the current ensemble member +function get_ensemble_id() + integer :: get_ensemble_id + + get_ensemble_id = FMS_get_ensemble_id() + +end function get_ensemble_id + +!> Returns ensemble information as follows, +!! index (1) :: ensemble size +!! index (2) :: Number of PEs per ensemble member +!! index (3) :: Number of ocean PEs per ensemble member +!! index (4) :: Number of atmos PEs per ensemble member +!! index (5) :: Number of land PEs per ensemble member +!! index (6) :: Number of ice PEs per ensemble member +function get_ensemble_size() + integer, dimension(7) :: get_ensemble_size + + get_ensemble_size = FMS_get_ensemble_size() + +end function get_ensemble_size + +!> Returns the list of PEs associated with all ensemble members +!! Results are stored in the argument array which must be large +!! enough to contain the list. If the optional name argument is present, +!! the returned processor list are for a particular component (atmos, ocean ,land, ice) +subroutine get_ensemble_pelist(pelist, name) + integer, intent(inout) :: pelist(:,:) !< A processor list for all ensemble members + character(len=*), optional, intent(in) :: name !< An optional component name (atmos, ocean, land, ice) + + call FMS_get_ensemble_pelist(pelist, name) + +end subroutine get_ensemble_pelist + +!> Returns the list of PEs associated with the named ensemble filter application. +!! Valid component names include ('atmos', 'ocean', 'land', and 'ice') +subroutine get_ensemble_filter_pelist(pelist, name) + integer, intent(inout) :: pelist(:) !< A processor list for the ensemble filter + character(len=*), intent(in) :: name !< The component name (atmos, ocean, land, ice) + + call FMS_get_Ensemble_filter_pelist(pelist, name) + +end subroutine get_ensemble_filter_pelist + +end module MOM_ensemble_manager_infra diff --git a/config_src/infra/FMS1/MOM_error_infra.F90 b/config_src/infra/FMS1/MOM_error_infra.F90 new file mode 100644 index 0000000000..e5a8b8dc68 --- /dev/null +++ b/config_src/infra/FMS1/MOM_error_infra.F90 @@ -0,0 +1,42 @@ +!> Routines for error handling and I/O management +module MOM_error_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout +use mpp_mod, only : NOTE, WARNING, FATAL + +implicit none ; private + +public :: MOM_err, is_root_pe, stdlog, stdout +!> Integer parameters encoding the severity of an error message +public :: NOTE, WARNING, FATAL + +contains + +!> MOM_err writes an error message, and may cause the run to stop depending on the +!! severity of the error. +subroutine MOM_err(severity, message) + integer, intent(in) :: severity !< The severity level of this error + character(len=*), intent(in) :: message !< A message to write out + + call mpp_error(severity, message) +end subroutine MOM_err + +!> stdout returns the standard Fortran unit number for output +integer function stdout() + stdout = mpp_stdout() +end function stdout + +!> stdlog returns the standard Fortran unit number to use to log messages +integer function stdlog() + stdlog = mpp_stdlog() +end function stdlog + +!> is_root_pe returns .true. if the current PE is the root PE. +logical function is_root_pe() + is_root_pe = .false. + if (mpp_pe() == mpp_root_pe()) is_root_pe = .true. +end function is_root_pe + +end module MOM_error_infra diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 new file mode 100644 index 0000000000..70bc99827e --- /dev/null +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -0,0 +1,309 @@ +!> This module wraps the FMS temporal and spatial interpolation routines +module MOM_interp_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_io, 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 + +implicit none ; private + +public :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init +public :: get_external_field_info, axistype, get_axis_data +public :: run_horiz_interp, build_horiz_interp_weights +public :: external_field + +!< Handle of an external field for interpolation +type :: external_field + private + integer :: id + !< FMS ID for the interpolated field + character(len=:), allocatable :: filename + !< Filename containing the field values + character(len=:), allocatable :: label + !< Field name in the file +end type external_field + +!> Read a field based on model time, and rotate to the model domain. +interface time_interp_extern + module procedure time_interp_extern_0d + module procedure time_interp_extern_2d + module procedure time_interp_extern_3d +end interface time_interp_extern + +!> perform horizontal interpolation of field +interface run_horiz_interp + module procedure horiz_interp_from_weights_field2d + module procedure horiz_interp_from_weights_field3d +end interface + +!> build weights for horizontal interpolation of field +interface build_horiz_interp_weights + module procedure build_horiz_interp_weights_2d_to_2d +end interface build_horiz_interp_weights + +contains + +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + +!> perform horizontal interpolation of a 2d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: data_in !< input data + real, dimension(:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit, & + err_msg, new_missing_handle=.true. ) + +end subroutine horiz_interp_from_weights_field2d + + +!> perform horizontal interpolation of a 3d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:,:), intent(in) :: data_in !< input data + real, dimension(:,:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + +end subroutine horiz_interp_from_weights_field3d + + +!> build horizontal interpolation weights from source grid defined by 2d lon/lat to destination grid +!! defined by 2d lon/lat +subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + + type(horiz_interp_type), intent(inout) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: lon_in !< input longitude 2d + real, dimension(:,:), intent(in) :: lat_in !< input latitude 2d + real, dimension(:,:), intent(in) :: lon_out !< output longitude 2d + real, dimension(:,:), intent(in) :: lat_out !< output latitude 2d + integer, optional, intent(in) :: verbose !< verbosity level + character(len=*), optional, intent(in) :: interp_method !< interpolation method + integer, optional, intent(in) :: num_nbrs !< number of nearest neighbors + real, optional, intent(in) :: max_dist !< maximum region of influence + logical, optional, intent(in) :: src_modulo !< periodicity of E-W boundary + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(inout) :: mask_out !< mask for output data + logical, optional, intent(in) :: is_latlon_in !< input grid is regular lat/lon grid + logical, optional, intent(in) :: is_latlon_out !< output grid is regular lat/lon grid + + call horiz_interp_new(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + +end subroutine build_horiz_interp_weights_2d_to_2d + + +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data( axis, dat ) + type(axistype), intent(in) :: axis !< An axis type + real, dimension(:), intent(out) :: dat !< The data in the axis variable + + call mpp_get_axis_data( axis, dat ) +end subroutine get_axis_data + + +!> get size of an external field from field index +function get_extern_field_size(index) + + integer, intent(in) :: index !< field index + integer :: get_extern_field_size(4) !< field size + + get_extern_field_size = get_external_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) + + allocate(points(length)) + call mpp_get_axis_data(fms_axes(i), points) + call set_axis_info(axes(i), name=name, ax_data=points) + + deallocate(points) + enddo +end function get_extern_field_axes + + +!> get missing value of an external field from field index +function get_extern_field_missing(index) + + integer, intent(in) :: index !< field index + real :: get_extern_field_missing !< field missing value + + get_extern_field_missing = get_external_field_missing(index) + +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 + + if (present(size)) then + size(1:4) = get_extern_field_size(field%id) + endif + + if (present(axes)) then + axes(1:4) = 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 + + +!> Read a scalar field based on model time. +subroutine time_interp_extern_0d(field, time, data_in, verbose) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, intent(inout) :: data_in !< The interpolated value + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + + call time_interp_external(field%id, time, data_in, verbose=verbose) +end subroutine time_interp_extern_0d + + +!> Read a 2d field from an external based on model time, potentially including horizontal +!! interpolation and rotation of the data +subroutine time_interp_extern_2d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_2d + + +!> Read a 3d field based on model time, and rotate to the model grid +subroutine time_interp_extern_3d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_3d + + +!> initialize an external field +function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency) & + result(field) + + character(len=*), intent(in) :: file !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the field in the file + integer, optional, intent(in) :: threading !< A flag specifying whether the root PE reads + !! the data and broadcasts it (SINGLE_FILE) or all + !! processors read (MULTIPLE, the default). + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(out) :: ierr !< Returns a non-zero error code in case of failure + logical, optional, intent(in) :: ignore_axis_atts !< If present and true, do not issue a + !! fatal error if the axis Cartesian attribute is + !! not set to a recognized value. + logical, optional, intent(in) :: correct_leap_year_inconsistency !< If present and true, + !! then if, (1) a calendar containing leap years + !! is in use, and (2) the modulo time period of the + !! data is an integer number of years, then map + !! a model date of Feb 29. onto a common year on Feb. 28. + type(external_field) :: field !< Handle to external field + + if (present(MOM_Domain)) then + field%id = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & + verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & + correct_leap_year_inconsistency=correct_leap_year_inconsistency) + else + field%id = init_external_field(file, fieldname, domain=domain, & + verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & + correct_leap_year_inconsistency=correct_leap_year_inconsistency) + endif +end function init_extern_field + +end module MOM_interp_infra diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 new file mode 100644 index 0000000000..e37e5db3cb --- /dev/null +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -0,0 +1,1027 @@ +!> This module contains a thin inteface to mpp and fms I/O code +module MOM_io_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE +use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING + +use fms_mod, only : write_version_number, open_namelist_file, check_nml_error +use fms_io_mod, only : file_exist, field_exist, field_size, read_data +use fms_io_mod, only : fms_io_exit, get_filename_appendix +use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush +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_fields, fieldtype +use mpp_io_mod, only : mpp_get_info, mpp_get_times +use mpp_io_mod, only : mpp_io_init +use mpp_mod, only : stdout_if_root=>stdout +! These are encoding constants. +use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, WRITEONLY_FILE=>MPP_WRONLY +use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY +use mpp_io_mod, only : NETCDF_FILE=>MPP_NETCDF, ASCII_FILE=>MPP_ASCII +use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, SINGLE_FILE=>MPP_SINGLE +use mpp_mod, only : lowercase +use iso_fortran_env, only : int64 + +implicit none ; private + +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists +public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix +public :: read_field, read_vector, write_metadata, write_field +public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: 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 +! information about fields and axes, respectively, and are opaque to this module. +public :: fieldtype, axistype +! These are encoding constant parmeters. +public :: ASCII_FILE, NETCDF_FILE, SINGLE_FILE, MULTIPLE +public :: APPEND_FILE, READONLY_FILE, OVERWRITE_FILE, WRITEONLY_FILE +public :: CENTER, CORNER, NORTH_FACE, EAST_FACE + +!> Indicate whether a file exists, perhaps with domain decomposition +interface file_exists + module procedure FMS_file_exists + module procedure MOM_file_exists +end interface + +!> Open a file (or fileset) for parallel or single-file I/). +interface open_file + module procedure open_file_type, open_file_unit +end interface open_file + +!> Read a data field from a file +interface read_field + module procedure read_field_4d + module procedure read_field_3d, read_field_3d_region + module procedure read_field_2d, read_field_2d_region + module procedure read_field_1d, read_field_1d_int + module procedure read_field_0d, read_field_0d_int +end interface read_field + +!> Write a registered field to an output file +interface write_field + module procedure write_field_4d + module procedure write_field_3d + module procedure write_field_2d + module procedure write_field_1d + module procedure write_field_0d + module procedure MOM_write_axis +end interface write_field + +!> Read a pair of data fields representing the two components of a vector from a file +interface read_vector + module procedure MOM_read_vector_3d + module procedure MOM_read_vector_2d +end interface read_vector + +!> Write metadata about a variable or axis to a file and store it for later reuse +interface write_metadata + module procedure write_metadata_axis, write_metadata_field, write_metadata_global +end interface write_metadata + +!> Close a file (or fileset). If the file handle does not point to an open file, +!! close_file simply returns without doing anything. +interface close_file + module procedure close_file_type, close_file_unit +end interface close_file + +!> Ensure that the output stream associated with a file handle is fully sent to disk +interface flush_file + module procedure flush_file_type, flush_file_unit +end interface flush_file + +!> Type for holding a handle to an open file and related information +type, public :: file_type ; private + integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file + character(len=:), allocatable :: filename !< The path to this file, if it is open + logical :: open_to_read = .false. !< If true, this file or fileset can be read + logical :: open_to_write = .false. !< If true, this file or fileset can be written to +end type file_type + +contains + +!> Reads the checksum value for a field that was recorded in a file, along with a flag indicating +!! whether the file contained a valid checksum for this field. +subroutine read_field_chksum(field, chksum, valid_chksum) + type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. + integer(kind=int64), intent(out) :: chksum !< The checksum for the field. + logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. + ! Local variables + integer(kind=int64), dimension(3) :: checksum_file + + checksum_file(:) = -1 + valid_chksum = mpp_attribute_exist(field, "checksum") + if (valid_chksum) then + call get_field_atts(field, checksum=checksum_file) + chksum = checksum_file(1) + else + chksum = -1 + endif +end subroutine read_field_chksum + +!> Returns true if the named file or its domain-decomposed variant exists. +logical function MOM_file_exists(filename, MOM_Domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + +! This function uses the fms_io function file_exist to determine whether +! a named file (or its decomposed variant) exists. + + MOM_file_exists = file_exist(filename, MOM_Domain%mpp_domain) + +end function MOM_file_exists + +!> Returns true if the named file or its domain-decomposed variant exists. +logical function FMS_file_exists(filename) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + ! This function uses the fms_io function file_exist to determine whether + ! a named file (or its decomposed variant) exists. + + FMS_file_exists = file_exist(filename) +end function FMS_file_exists + +!> indicates whether an I/O handle is attached to an open file +logical function file_is_open(IO_handle) + type(file_type), intent(in) :: IO_handle !< Handle to a file to inquire about + + file_is_open = (IO_handle%unit >= 0) +end function file_is_open + +!> closes a file (or fileset). If the file handle does not point to an open file, +!! close_file_type simply returns without doing anything. +subroutine close_file_type(IO_handle) + type(file_type), intent(inout) :: IO_handle !< The I/O handle for the file to be closed + + call mpp_close(IO_handle%unit) + if (allocated(IO_handle%filename)) deallocate(IO_handle%filename) + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .false. +end subroutine close_file_type + +!> closes a file. If the unit does not point to an open file, +!! close_file_unit simply returns without doing anything. +subroutine close_file_unit(unit) + integer, intent(inout) :: unit !< The I/O unit for the file to be closed + + call mpp_close(unit) +end subroutine close_file_unit + +!> Ensure that the output stream associated with a file handle is fully sent to disk. +subroutine flush_file_type(file) + type(file_type), intent(in) :: file !< The I/O handle for the file to flush + + call mpp_flush(file%unit) +end subroutine flush_file_type + +!> Ensure that the output stream associated with a unit is fully sent to disk. +subroutine flush_file_unit(unit) + integer, intent(in) :: unit !< The I/O unit for the file to flush + + call mpp_flush(unit) +end subroutine flush_file_unit + +!> Initialize the underlying I/O infrastructure +subroutine io_infra_init(maxunits) + integer, optional, intent(in) :: maxunits !< An optional maximum number of file + !! unit numbers that can be used. + call mpp_io_init(maxunit=maxunits) +end subroutine io_infra_init + +!> Gracefully close out and terminate the underlying I/O infrastructure +subroutine io_infra_end() + call fms_io_exit() +end subroutine io_infra_end + +!> Open a single namelist file that is potentially readable by all PEs. +function MOM_namelist_file(file) result(unit) + character(len=*), optional, intent(in) :: file !< The file to open, by default "input.nml". + integer :: unit !< The opened unit number of the namelist file + unit = open_namelist_file(file) +end function MOM_namelist_file + +!> Checks the iostat argument that is returned after reading a namelist variable and writes a +!! message if there is an error. +subroutine check_namelist_error(IOstat, nml_name) + integer, intent(in) :: IOstat !< An I/O status field from a namelist read call + character(len=*), intent(in) :: nml_name !< The name of the namelist + integer :: ierr + ierr = check_nml_error(IOstat, nml_name) +end subroutine check_namelist_error + +!> Write a file version number to the log file or other output file +subroutine write_version(version, tag, unit) + character(len=*), intent(in) :: version !< A string that contains the routine name and version + character(len=*), optional, intent(in) :: tag !< A tag name to add to the message + integer, optional, intent(in) :: unit !< An alternate unit number for output + + call write_version_number(version, tag, unit) +end subroutine write_version + +!> open_file opens a file for parallel or single-file I/O. +subroutine open_file_unit(unit, filename, action, form, threading, fileset, nohdrs, domain, MOM_domain) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: filename !< The name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + integer, optional, intent(in) :: form !< A flag indicating the format of a new file. The + !! default is ASCII_FILE, but NETCDF_FILE is also common. + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + logical, optional, intent(in) :: nohdrs !< If nohdrs is .TRUE., headers are not written to + !! ASCII files. The default is .false. + type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + + if (present(MOM_Domain)) then + call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & + nohdrs=nohdrs, domain=MOM_Domain%mpp_domain) + else + call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & + nohdrs=nohdrs, domain=domain) + endif +end subroutine open_file_unit + +!> open_file opens a file for parallel or single-file I/O. +subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fileset) + type(file_type), intent(inout) :: IO_handle !< The handle for the opened file + character(len=*), intent(in) :: filename !< The path name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + !! The default is WRITE_ONLY. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + + if (present(MOM_Domain)) then + call mpp_open(IO_handle%unit, filename, action=action, form=NETCDF_FILE, threading=threading, & + fileset=fileset, domain=MOM_Domain%mpp_domain) + else + call mpp_open(IO_handle%unit, filename, action=action, form=NETCDF_FILE, threading=threading, & + fileset=fileset) + endif + IO_handle%filename = trim(filename) + if (present(action)) then + if (action == READONLY_FILE) then + IO_handle%open_to_read = .true. ; IO_handle%open_to_write = .false. + else + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. + endif + else + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. + endif + +end subroutine open_file_type + +!> open_file opens an ascii file for parallel or single-file I/O using Fortran read and write calls. +subroutine open_ASCII_file(unit, file, action, threading, fileset) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: file !< The name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + + call mpp_open(unit, file, action=action, form=ASCII_FILE, threading=threading, fileset=fileset, & + nohdrs=.true.) + +end subroutine open_ASCII_file + + +!> Provide a string to append to filenames, to differentiate ensemble members, for example. +subroutine get_filename_suffix(suffix) + character(len=*), intent(out) :: suffix !< A string to append to filenames + + call get_filename_appendix(suffix) +end subroutine get_filename_suffix + + +!> Get information about the number of dimensions, variables and time levels +!! in the file associated with an open file unit +subroutine get_file_info(IO_handle, ndim, nvar, ntime) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim !< The number of dimensions in the file + integer, optional, intent(out) :: nvar !< The number of variables in the file + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + ! Local variables + integer :: ndims, nvars, natts, ntimes + + call mpp_get_info(IO_handle%unit, ndims, nvars, natts, ntimes ) + + if (present(ndim)) ndim = ndims + if (present(nvar)) nvar = nvars + if (present(ntime)) ntime = ntimes + +end subroutine get_file_info + + +!> Get the times of records from a file + !### Modify this to also convert to time_type, using information about the dimensions? +subroutine get_file_times(IO_handle, time_values, ntime) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + real, allocatable, dimension(:), intent(inout) :: time_values !< The real times for the records in file. + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + integer :: ntimes + + if (allocated(time_values)) deallocate(time_values) + call get_file_info(IO_handle, ntime=ntimes) + if (present(ntime)) ntime = ntimes + if (ntimes > 0) then + allocate(time_values(ntimes)) + call mpp_get_times(IO_handle%unit, time_values) + endif +end subroutine get_file_times + +!> Set up the field information (e.g., names and metadata) for all of the variables in a file. The +!! argument fields must be allocated with a size that matches the number of variables in a file. +subroutine get_file_fields(IO_handle, fields) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of + !! the variables in a file. + call mpp_get_fields(IO_handle%unit, fields) +end subroutine get_file_fields + +!> Extract information from a field type, as stored or as found in a file +subroutine get_field_atts(field, name, units, longname, checksum) + type(fieldtype), intent(in) :: field !< The field to extract information from + character(len=*), optional, intent(out) :: name !< The variable name + character(len=*), optional, intent(out) :: units !< The units of the variable + character(len=*), optional, intent(out) :: longname !< The long name of the variable + integer(kind=int64), dimension(:), & + optional, intent(out) :: checksum !< The checksums of the variable in a file + call mpp_get_atts(field, name=name, units=units, longname=longname, checksum=checksum) +end subroutine get_field_atts + +!> Field_exists returns true if the field indicated by field_name is present in the +!! file file_name. If file_name does not exist, it returns false. +function field_exists(filename, field_name, domain, no_domain, MOM_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + character(len=*), intent(in) :: field_name !< The name of the field being sought + type(domain2d), target, optional, intent(in) :: domain !< A domain2d type that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + logical :: field_exists !< True if filename exists and field_name is in filename + + if (present(MOM_domain)) then + field_exists = field_exist(filename, field_name, domain=MOM_domain%mpp_domain, no_domain=no_domain) + else + field_exists = field_exist(filename, field_name, domain=domain, no_domain=no_domain) + endif + +end function field_exists + +!> Given filename and fieldname, this subroutine returns the size of the field in the file +subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned + integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension + logical, optional, intent(out) :: field_found !< This indicates whether the field was found in + !! the input file. Without this argument, there + !! is a fatal error if the field is not found. + logical, optional, intent(in) :: no_domain !< If present and true, do not check for file + !! names with an appended tile number + + call field_size(filename, fieldname, sizes, field_found=field_found, no_domain=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 ) +end subroutine get_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, & + global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. + + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (.not.use_fms_read_data) then + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), data, timelevel) + exit + endif + enddo + + deallocate(fields) + call mpp_close(unit) + elseif (present(MOM_Domain)) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + data = scale*data + endif ; endif +end subroutine read_field_0d + +!> This routine uses the fms_io subroutine read_data to read a 1-D data field named +!! "fieldname" from a single or domain-decomposed file "filename". +subroutine read_field_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. + + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (.not.use_fms_read_data) then + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 1-d variable "//trim(fieldname)//" from file "//trim(filename)) + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), data, timelevel) + exit + endif + enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "read_field apparently did not find 1-d variable "//trim(fieldname)//" in file "//trim(filename)) + + deallocate(fields) + call mpp_close(unit) + elseif (present(MOM_Domain)) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) + else + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + data(:) = scale*data(:) + endif ; endif +end subroutine read_field_1d + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 2-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine read_field_2d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. + + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (use_fms_read_data) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + else + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 2-d variable "//trim(fieldname)//" from file "//trim(filename)) + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "read_field apparently did not find 2-d variable "//trim(fieldname)//" in file "//trim(filename)) + + deallocate(fields) + call mpp_close(unit) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif +end subroutine read_field_2d + +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 2-D data field named "fieldname" from file "filename". +subroutine read_field_2d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + if (present(MOM_Domain)) then + call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & + no_domain=no_domain) + else + call read_data(filename, fieldname, data, start, nread, no_domain=no_domain) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:) = scale*data(:,:) + endif + endif ; endif +end subroutine read_field_2d_region + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 3-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, + !! in which case a more elaborate set of calls + !! is needed to read it due to FMS limitations. + + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: use_fms_read_data, file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + use_fms_read_data = .true. ; if (present(file_may_be_4d)) use_fms_read_data = .not.file_may_be_4d + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (use_fms_read_data) then + call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=position) + else + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 3-d variable "//trim(fieldname)//" from file "//trim(filename)) + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "read_field apparently did not find 3-d variable "//trim(fieldname)//" in file "//trim(filename)) + + deallocate(fields) + call mpp_close(unit) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif +end subroutine read_field_3d + +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 3-D data field named "fieldname" from file "filename". +subroutine read_field_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + if (present(MOM_Domain)) then + call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & + no_domain=no_domain) + else + call read_data(filename, fieldname, data, start, nread, no_domain=no_domain) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:,:) = scale*data(:,:,:) + endif + endif ; endif +end subroutine read_field_3d_region + + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 4-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine read_field_4d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:,:), intent(inout) :: data !< The 4-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + + ! Local variables + character(len=80) :: varname ! The name of a variable in the file + type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file + logical :: file_is_global + integer :: n, unit, ndim, nvar, natt, ntime + + ! This single call does not work for a 4-d array due to FMS limitations, so multiple calls are + ! needed. + ! call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & + ! timelevel=timelevel, position=position) + + file_is_global = .true. ; if (present(global_file)) file_is_global = global_file + + if (file_is_global) then + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=SINGLE_FILE) !, domain=MOM_Domain%mpp_domain ) + else + call mpp_open(unit, trim(filename), form=NETCDF_FILE, action=READONLY_FILE, & + threading=MULTIPLE, fileset=MULTIPLE, domain=MOM_Domain%mpp_domain ) + endif + call mpp_get_info(unit, ndim, nvar, natt, ntime) + allocate(fields(nvar)) + call mpp_get_fields(unit, fields(1:nvar)) + do n=1, nvar + call mpp_get_atts(fields(n), name=varname) + if (lowercase(trim(varname)) == lowercase(trim(fieldname))) then + call MOM_error(NOTE, "Reading 4-d variable "//trim(fieldname)//" from file "//trim(filename)) + ! Maybe something should be done depending on the value of ntime. + call mpp_read(unit, fields(n), MOM_Domain%mpp_domain, data, timelevel) + exit + endif + enddo + if ((n == nvar+1) .or. (nvar < 1)) call MOM_error(WARNING, & + "read_field apparently did not find 4-d variable "//trim(fieldname)//" in file "//trim(filename)) + + deallocate(fields) + call mpp_close(unit) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif +end subroutine read_field_4d + +!> This routine uses the fms_io subroutine read_data to read a scalar integer +!! data field named "fieldname" from file "filename". +subroutine read_field_0d_int(filename, fieldname, data, timelevel) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + integer, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) +end subroutine read_field_0d_int + +!> This routine uses the fms_io subroutine read_data to read a 1-D integer +!! data field named "fieldname" from file "filename". +subroutine read_field_1d_int(filename, fieldname, data, timelevel) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + integer, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) +end subroutine read_field_1d_int + + +!> This routine uses the fms_io subroutine read_data to read a pair of distributed +!! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:), intent(inout) :: u_data !< The 2 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:), intent(inout) :: v_data !< The 2 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + integer :: u_pos, v_pos + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=u_pos) + call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=v_pos) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + +end subroutine MOM_read_vector_2d + +!> This routine uses the fms_io subroutine read_data to read a pair of distributed +!! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:,:), intent(inout) :: u_data !< The 3 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:,:), intent(inout) :: v_data !< The 3 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + + integer :: u_pos, v_pos + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=u_pos) + call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & + timelevel=timelevel, position=v_pos) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + +end subroutine MOM_read_vector_3d + + +!> Write a 4d field to an output file. +subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_4d + +!> Write a 3d field to an output file. +subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_3d + +!> Write a 2d field to an output file. +subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + call mpp_write(IO_handle%unit, field_md, MOM_domain%mpp_domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=fill_value) +end subroutine write_field_2d + +!> Write a 1d field to an output file. +subroutine write_field_1d(IO_handle, field_md, field, tstamp) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + + call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) +end subroutine write_field_1d + +!> Write a 0d field to an output file. +subroutine write_field_0d(IO_handle, field_md, field, tstamp) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + + call mpp_write(IO_handle%unit, field_md, field, tstamp=tstamp) +end subroutine write_field_0d + +!> Write the data for an axis +subroutine MOM_write_axis(IO_handle, axis) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(in) :: axis !< An axis type variable with information to write + + call mpp_write(IO_handle%unit, axis) + +end subroutine MOM_write_axis + +!> Store information about an axis in a previously defined axistype and write this +!! information to the file indicated by unit. +subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, & + data, edge_axis, calendar) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(inout) :: axis !< The axistype where this information is stored. + character(len=*), intent(in) :: name !< The name in the file of this axis + character(len=*), intent(in) :: units !< The units of this axis + character(len=*), intent(in) :: longname !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense !< This is 1 for axes whose values increase upward, or + !! -1 if they increase downward. + type(domain1D), optional, intent(in) :: domain !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis + + call mpp_write_meta(IO_handle%unit, axis, name, units, longname, cartesian=cartesian, sense=sense, & + domain=domain, data=data, calendar=calendar) +end subroutine write_metadata_axis + +!> Store information about an output variable in a previously defined fieldtype and write this +!! information to the file indicated by unit. +subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & + pack, standard_name, checksum) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored + type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable + character(len=*), intent(in) :: name !< The name in the file of this variable + character(len=*), intent(in) :: units !< The units of this variable + character(len=*), intent(in) :: longname !< The long description of this variable + integer, optional, intent(in) :: pack !< A precision reduction factor with which the + !! variable. The default, 1, has no reduction, + !! but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), & + optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. + + + call mpp_write_meta(IO_handle%unit, field, axes, name, units, longname, & + pack=pack, standard_name=standard_name, checksum=checksum) + ! unused opt. args: min=min, max=max, fill=fill, scale=scale, add=add, & + +end subroutine write_metadata_field + +!> Write a global text attribute to a file. +subroutine write_metadata_global(IO_handle, name, attribute) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + character(len=*), intent(in) :: name !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute !< The value of this attribute + + call mpp_write_meta(IO_handle%unit, name, cval=attribute) +end subroutine write_metadata_global + +end module MOM_io_infra diff --git a/src/framework/MOM_time_manager.F90 b/config_src/infra/FMS1/MOM_time_manager.F90 similarity index 62% rename from src/framework/MOM_time_manager.F90 rename to config_src/infra/FMS1/MOM_time_manager.F90 index 229c3ded3a..5f3279b713 100644 --- a/src/framework/MOM_time_manager.F90 +++ b/config_src/infra/FMS1/MOM_time_manager.F90 @@ -14,9 +14,6 @@ module MOM_time_manager use time_manager_mod, only : set_calendar_type, get_calendar_type use time_manager_mod, only : JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN use time_manager_mod, only : NO_CALENDAR -use time_interp_external_mod, only : init_external_field, time_interp_external, 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 implicit none ; private @@ -29,24 +26,18 @@ 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 -public :: init_external_field -public :: time_interp_external -public :: time_interp_external_init -public :: get_external_field_size -public :: get_external_field_axes -public :: get_external_field_missing contains -!> This is an alternate implementation of the FMS function real_to_time_type that is accurate over -!! a larger range of input values. With 32 bit 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. -function real_to_time(x, err_msg) - type(time_type) :: real_to_time !< The output time as a time_type - real, intent(in) :: x !< The input time in real seconds. - character(len=*), intent(out), optional :: err_msg !< An optional returned error message. +!> Returns a time_type version of a real time in seconds, using an alternate implementation to the +!! FMS function real_to_time_type that is accurate over a larger range of input values. With 32 bit +!! 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) :: real_to_time !< The output time as a time_type + real, intent(in) :: x !< The input time in real seconds. + character(len=*), optional, intent(out) :: err_msg !< An optional returned error message. ! Local variables integer :: seconds, days, ticks @@ -60,5 +51,4 @@ function real_to_time(x, err_msg) real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg) end function real_to_time - end module MOM_time_manager diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 new file mode 100644 index 0000000000..06a9b9f343 --- /dev/null +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -0,0 +1,524 @@ +!> Thin interfaces to non-domain-oriented mpp communication subroutines +module MOM_coms_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use iso_fortran_env, only : int32, int64 + +use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe +use mpp_mod, only : mpp_set_current_pelist, mpp_get_current_pelist +use mpp_mod, only : mpp_broadcast, mpp_sync, mpp_sync_self, mpp_chksum +use mpp_mod, only : mpp_sum, mpp_max, mpp_min +use memutils_mod, only : print_memuse_stats +use fms_mod, only : fms_end, fms_init + +implicit none ; private + +public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist, sync_PEs +public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: any_across_PEs, all_across_PEs +public :: field_chksum, MOM_infra_init, MOM_infra_end + +! This module provides interfaces to the non-domain-oriented communication +! subroutines. + +!> Communicate an array, string or scalar from one PE to others +interface broadcast + module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D, broadcast_real3D +end interface broadcast + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +interface field_chksum + module procedure field_chksum_real_0d + module procedure field_chksum_real_1d + module procedure field_chksum_real_2d + module procedure field_chksum_real_3d + module procedure field_chksum_real_4d +end interface field_chksum + +!> Find the sum of field across PEs, and update PEs with the sums. +interface sum_across_PEs + module procedure sum_across_PEs_int4_0d + module procedure sum_across_PEs_int4_1d + module procedure sum_across_PEs_int4_2d + module procedure sum_across_PEs_int8_0d + module procedure sum_across_PEs_int8_1d + module procedure sum_across_PEs_int8_2d + module procedure sum_across_PEs_real_0d + module procedure sum_across_PEs_real_1d + module procedure sum_across_PEs_real_2d +end interface sum_across_PEs + +!> Find the maximum value of field across PEs, and update PEs with the values. +interface max_across_PEs + module procedure max_across_PEs_int_0d + module procedure max_across_PEs_real_0d + module procedure max_across_PEs_real_1d +end interface max_across_PEs + +!> Find the minimum value of field across PEs, and update PEs with the values. +interface min_across_PEs + module procedure min_across_PEs_int_0d + module procedure min_across_PEs_real_0d + module procedure min_across_PEs_real_1d +end interface min_across_PEs + +contains + +!> Return the ID of the PE for the current process. +function PE_here() result(pe) + integer :: pe !< PE ID of the current process + pe = mpp_pe() +end function PE_here + +!> Return the ID of the root PE for the PE list of the current procss. +function root_PE() result(pe) + integer :: pe !< root PE ID + pe = mpp_root_pe() +end function root_PE + +!> Return the number of PEs for the current PE list. +function num_PEs() result(npes) + integer :: npes !< Number of PEs + npes = mpp_npes() +end function num_PEs + +!> Designate a PE as the root PE +subroutine set_rootPE(pe) + integer, intent(in) :: pe !< ID of the PE to be assigned as root + call mpp_set_root_pe(pe) +end subroutine + +!> Set the current PE list. If no list is provided, then the current PE list +!! is set to the list of all available PEs on the communicator. Setting the +!! list will trigger a rank synchronization unless the `no_sync` flag is set. +subroutine Set_PEList(pelist, no_sync) + integer, optional, intent(in) :: pelist(:) !< List of PEs to set for communication + logical, optional, intent(in) :: no_sync !< Do not sync after list update. + call mpp_set_current_pelist(pelist, no_sync) +end subroutine Set_PEList + +!> Retrieve the current PE list and any metadata if requested. +subroutine Get_PEList(pelist, name, commID) + integer, intent(out) :: pelist(:) !< List of PE IDs of the current PE list + character(len=*), optional, intent(out) :: name !< Name of PE list + integer, optional, intent(out) :: commID !< Communicator ID of PE list + + call mpp_get_current_pelist(pelist, name, commiD) +end subroutine Get_PEList + +!> Sync the PEs at a defined point in the model +subroutine sync_PEs(pelist) + integer, optional, intent(in) :: pelist(:) !< The list of PEs to be synced + + call mpp_sync(pelist) +end subroutine sync_PEs + +!> Communicate a 1-D array of character strings from one PE to others +subroutine broadcast_char(dat, length, from_PE, PElist, blocking) + character(len=*), intent(inout) :: dat(:) !< The data to communicate and destination + integer, intent(in) :: length !< The length of each string + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_char + +!> Communicate an integer from one PE to others +subroutine broadcast_int64_0D(dat, from_PE, PElist, blocking) + integer(kind=int64), intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int64_0D + + +!> Communicate an integer from one PE to others +subroutine broadcast_int32_0D(dat, from_PE, PElist, blocking) + integer(kind=int32), intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int32_0D + +!> Communicate a 1-D array of integers from one PE to others +subroutine broadcast_int1D(dat, length, from_PE, PElist, blocking) + integer, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_int1D + +!> Communicate a real number from one PE to others +subroutine broadcast_real0D(dat, from_PE, PElist, blocking) + real, intent(inout) :: dat !< The data to communicate and destination + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real0D + +!> Communicate a 1-D array of reals from one PE to others +subroutine broadcast_real1D(dat, length, from_PE, PElist, blocking) + real, dimension(:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real1D + +!> Communicate a 2-D array of reals from one PE to others +subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real2D + +!> Communicate a 3-D array of reals from one PE to others +subroutine broadcast_real3D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real3D + +! field_chksum wrappers + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_0d(field, pelist, mask_val) result(chksum) + real, intent(in) :: field !< Input scalar + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_0d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_1d(field, pelist, mask_val) result(chksum) + real, dimension(:), intent(in) :: field !< Input array + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_1d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_2d(field, pelist, mask_val) result(chksum) + real, dimension(:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_2d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_3d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_3d + +!> Compute a checksum for a field distributed over a PE list. If no PE list is +!! provided, then the current active PE list is used. +function field_chksum_real_4d(field, pelist, mask_val) result(chksum) + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field + integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum + real, optional, intent(in) :: mask_val !< FMS mask value + integer(kind=int64) :: chksum !< checksum of array + + chksum = mpp_chksum(field, pelist, mask_val) +end function field_chksum_real_4d + +! sum_across_PEs wrappers + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_int4_0d(field, pelist) + integer(kind=int32), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int4_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int4_1d(field, length, pelist) + integer(kind=int32), dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int4_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int4_2d(field, length, pelist) + integer(kind=int32), dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int4_2d + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_int8_0d(field, pelist) + integer(kind=int64), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_int8_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int8_1d(field, length, pelist) + integer(kind=int64), dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int8_2d(field, length, pelist) + integer(kind=int64), & + dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int8_2d + +!> Find the sum of field across PEs, and return this sum in field. +subroutine sum_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< Value on this PE, and the sum across PEs upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, pelist) +end subroutine sum_across_PEs_real_0d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_1d + +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_real_2d(field, length, pelist) + real, dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< The total number of positions to sum, usually + !! the product of the array sizes. + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_real_2d + +! max_across_PEs wrappers + +!> Find the maximum value of field across PEs, and store this maximum in field. +subroutine max_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, pelist) +end subroutine max_across_PEs_int_0d + +!> Find the maximum value of field across PEs, and store this maximum in field. +subroutine max_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< The values to compare, the maximum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, pelist) +end subroutine max_across_PEs_real_0d + +!> Find the maximum values in each position of field across PEs, and store these minima in field. +subroutine max_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! maxima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_max(field, length, pelist) +end subroutine max_across_PEs_real_1d + +! min_across_PEs wrappers + +!> Find the minimum value of field across PEs, and store this minimum in field. +subroutine min_across_PEs_int_0d(field, pelist) + integer, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_min(field, pelist) +end subroutine min_across_PEs_int_0d + +!> Find the minimum value of field across PEs, and store this minimum in field. +subroutine min_across_PEs_real_0d(field, pelist) + real, intent(inout) :: field !< The values to compare, the minimum upon return + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + call mpp_min(field, pelist) +end subroutine min_across_PEs_real_0d + +!> Find the minimum values in each position of field across PEs, and store these minima in field. +subroutine min_across_PEs_real_1d(field, length, pelist) + real, dimension(:), intent(inout) :: field !< The list of values being compared, with the + !! minima in each position upon return + integer, intent(in) :: length !< Number of elements in field to compare + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_min(field, length, pelist) +end subroutine min_across_PEs_real_1d + +!> Implementation of any() intrinsic across PEs +function any_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: any_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call max_across_PEs(field_flag, pelist) + any_across_PEs = (field_flag > 0) +end function any_across_PEs + +!> Implementation of all() intrinsic across PEs +function all_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: all_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call min_across_PEs(field_flag, pelist) + all_across_PEs = (field_flag > 0) +end function all_across_PEs + +!> Initialize the model framework, including PE communication over a designated communicator. +!! If no communicator ID is provided, the framework's default communicator is used. +subroutine MOM_infra_init(localcomm) + integer, optional, intent(in) :: localcomm !< Communicator ID to initialize + call fms_init(localcomm) +end subroutine + +!> This subroutine carries out all of the calls required to close out the infrastructure cleanly. +!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. +subroutine MOM_infra_end + call print_memuse_stats( 'Memory HiWaterMark', always=.TRUE. ) + call fms_end() +end subroutine MOM_infra_end + +end module MOM_coms_infra diff --git a/config_src/infra/FMS2/MOM_constants.F90 b/config_src/infra/FMS2/MOM_constants.F90 new file mode 100644 index 0000000000..2db177e08c --- /dev/null +++ b/config_src/infra/FMS2/MOM_constants.F90 @@ -0,0 +1,14 @@ +!> Provides a few physical constants +module MOM_constants + +! This file is part of MOM6. See LICENSE.md for the license. + +use constants_mod, only : HLV, HLF + +implicit none ; private + +!> The constant offset for converting temperatures in Kelvin to Celsius +real, public, parameter :: CELSIUS_KELVIN_OFFSET = 273.15 +public :: HLV, HLF + +end module MOM_constants diff --git a/config_src/infra/FMS2/MOM_couplertype_infra.F90 b/config_src/infra/FMS2/MOM_couplertype_infra.F90 new file mode 100644 index 0000000000..3bcccc1dc7 --- /dev/null +++ b/config_src/infra/FMS2/MOM_couplertype_infra.F90 @@ -0,0 +1,503 @@ +!> This module wraps the FMS coupler types module +module MOM_couplertype_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data +use coupler_types_mod, only : coupler_type_increment_data, coupler_type_rescale_data +use coupler_types_mod, only : coupler_type_extract_data, coupler_type_set_data +use coupler_types_mod, only : coupler_type_data_override +use coupler_types_mod, only : ind_flux, ind_alpha, ind_csurf +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux +use MOM_domain_infra, only : domain2D +use MOM_time_manager, only : time_type + +implicit none ; private + +public :: CT_spawn, CT_initialized, CT_destructor +public :: CT_set_diags, CT_send_data, CT_data_override, CT_write_chksums +public :: CT_set_data, CT_increment_data, CT_rescale_data +public :: CT_copy_data, CT_extract_data, CT_redistribute_data +public :: atmos_ocn_coupler_flux +public :: ind_flux, ind_alpha, ind_csurf +public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type + +!> This is the interface to spawn one coupler_bc_type into another. +interface CT_spawn + module procedure CT_spawn_1d_2d, CT_spawn_1d_3d, CT_spawn_2d_2d, CT_spawn_2d_3d + module procedure CT_spawn_3d_2d, CT_spawn_3d_3d +end interface CT_spawn + +!> This function interface indicates whether a coupler_bc_type has been initialized. +interface CT_initialized + module procedure CT_initialized_1d, CT_initialized_2d, CT_initialized_3d +end interface CT_initialized + +!> This is the interface to deallocate any data associated with a coupler_bc_type. +interface CT_destructor + module procedure CT_destructor_1d, CT_destructor_2d +end interface CT_destructor + +!> Copy all elements of the data in either a coupler_2d_bc_type or a coupler_3d_bc_type into +!! another structure of the same or the other type. Both must have the same array sizes in common +!! dimensions, while the details of any expansion from 2d to 3d are controlled by arguments. +interface CT_copy_data + module procedure CT_copy_data_2d, CT_copy_data_3d, CT_copy_data_2d_3d +end interface CT_copy_data + +!> Increment data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type with +!! the data from another. Both must have the same array sizes and rank. +interface CT_increment_data + module procedure CT_increment_data_2d, CT_increment_data_3d, CT_increment_data_2d_3d +end interface CT_increment_data + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +interface CT_rescale_data + module procedure CT_rescale_data_2d, CT_rescale_data_3d +end interface CT_rescale_data + +!> Redistribute the data in all elements of one coupler_2d_bc_type or coupler_3d_bc_type into +!! another, which may be on different processors with a different decomposition. +interface CT_redistribute_data + module procedure CT_redistribute_data_2d, CT_redistribute_data_3d +end interface CT_redistribute_data + +!> Write out checksums for the elements of a coupler_2d_bc_type or coupler_3d_bc_type +interface CT_write_chksums + module procedure CT_write_chksums_2d, CT_write_chksums_3d +end interface CT_write_chksums + +contains + +!> This subroutine sets many of the parameters for calculating an atmosphere-ocean tracer flux +!! and retuns an integer index for that flux. +function atmos_ocn_coupler_flux(name, flux_type, implementation, param, mol_wt, & + ice_restart_file, ocean_restart_file, units, caller, verbosity) & + result (coupler_index) + + character(len=*), intent(in) :: name !< A name to use for the flux + character(len=*), intent(in) :: flux_type !< A string describing the type of this flux, + !! perhaps 'air_sea_gas_flux'. + character(len=*), intent(in) :: implementation !< A name describing the specific + !! implementation of this flux, such as 'ocmip2'. + real, dimension(:), optional, intent(in) :: param !< An array of parameters used for the fluxes + real, optional, intent(in) :: mol_wt !< The molecular weight of this tracer + character(len=*), optional, intent(in) :: ice_restart_file !< A sea-ice restart file to use with this flux. + character(len=*), optional, intent(in) :: ocean_restart_file !< An ocean restart file to use with this flux. + character(len=*), optional, intent(in) :: units !< The units of the flux + character(len=*), optional, intent(in) :: caller !< The name of the calling routine + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + integer :: coupler_index !< The resulting integer handle to use for this flux in subsequent calls. + + coupler_index = aof_set_coupler_flux(name, flux_type, implementation, & + param=param, mol_wt=mol_wt, ice_restart_file=ice_restart_file, & + ocean_restart_file=ocean_restart_file, & + units=units, caller=caller, verbosity=verbosity) + +end function atmos_ocn_coupler_flux + +!> Generate a 2-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_2d + +!> Generate a 3-D coupler type using a 1-D coupler type as a template. +subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_1d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_1d_3d + +!> Generate one 2-D coupler type using another 2-D coupler type as a template. +subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_2d + +!> Generate a 3-D coupler type using a 2-D coupler type as a template. +subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_2d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_2d_3d + +!> Generate a 2-D coupler type using a 3-D coupler type as a template. +subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_2d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_2d + +!> Generate a 3-D coupler type using another 3-D coupler type as a template. +subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed) + type(coupler_3d_bc_type), intent(in) :: var_in !< structure from which to copy information + type(coupler_3d_bc_type), intent(inout) :: var !< structure into which to copy information + integer, dimension(4), intent(in) :: idim !< The data and computational domain extents of + !! the first dimension in a non-decreasing list + integer, dimension(4), intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension in a non-decreasing list + integer, dimension(2), intent(in) :: kdim !< The array extents of the third dimension in + !! a non-decreasing list + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique + logical, optional, intent(in) :: as_needed !< Only do the spawn if the target type (var) + !! is not set and the parent type (var_in) is set. + + call coupler_type_spawn(var_in, var, idim, jdim, kdim, suffix=suffix, as_needed=as_needed) + +end subroutine CT_spawn_3d_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_2d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_2d + +!> Copy all elements of the data in a coupler_3d_bc_type into another. Both must have the same array sizes. +subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice) +end subroutine CT_copy_data_3d + +!> Copy all elements of the data in a coupler_2d_bc_type into a coupler_3d_bc_type. +!! Both must have the same array sizes for the first two dimensions, while the extent +!! of the 3rd dimension that is being filled may be specified via optional arguments. +subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(coupler_3d_bc_type), intent(inout) :: var !< The recipient BC_type structure + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, optional, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, optional, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being copied + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes + !! to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes + !! to include from this copy. + logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose + !! value of pass_through ice matches this + integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd + !! index of the 3d type to fill in. + integer, optional, intent(in) :: ind3_end !< The ending value of the 3rd + !! index of the 3d type to fill in. + + call coupler_type_copy_data(var_in, var, halo_size, bc_index, field_index, & + exclude_flux_type, only_flux_type, pass_through_ice, ind3_start, ind3_end) +end subroutine CT_copy_data_2d_3d + +!> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) + type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev) + +end subroutine CT_increment_data_2d + +!> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both +!! must have the same array sizes. +subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. + + call coupler_type_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & + scale_prev=scale_prev, exclude_flux_type=exclude_flux_type, & + only_flux_type=only_flux_type) + +end subroutine CT_increment_data_3d + +!> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_2d(var, scale) + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_2d + +!> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. +!! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. +subroutine CT_rescale_data_3d(var, scale) + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled + real, intent(in) :: scale !< A scaling factor to multiply fields by + + call coupler_type_rescale_data(var, scale) + +end subroutine CT_rescale_data_3d + +!> Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a +!! coupler_3d_bc_type +subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) + type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type + real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to + !! increment the 2d-data. There is no renormalization, + !! so if the weights do not sum to 1 in the 3rd dimension + !! there may be adverse consequences! + type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default + + call coupler_type_increment_data(var_in, weights, var, halo_size=halo_size) + +end subroutine CT_increment_data_2d_3d + + +!> Redistribute the data in all elements of one coupler_2d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_2d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_2d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_2d + +!> Redistribute the data in all elements of one coupler_3d_bc_type into another, which may be on +!! different processors with a different decomposition. +subroutine CT_redistribute_data_3d(var_in, domain_in, var_out, domain_out, complete) + type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to copy + type(domain2D), intent(in) :: domain_in !< The FMS domain for the input structure + type(coupler_3d_bc_type), intent(inout) :: var_out !< The recipient BC_type structure (data intent out) + type(domain2D), intent(in) :: domain_out !< The FMS domain for the output structure + logical, optional, intent(in) :: complete !< If true, complete the updates + + call coupler_type_redistribute_data(var_in, domain_in, var_out, domain_out, complete) +end subroutine CT_redistribute_data_3d + +!> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array. +subroutine CT_extract_data(var_in, bc_index, field_index, array_out, & + scale_factor, halo_size, idim, jdim) + type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the boundary + !! condition that is being copied, or the + !! surface flux by default. + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + call coupler_type_extract_data(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim) + +end subroutine CT_extract_data + +!> Set single 2d field in coupler_2d_bc_type from a two-dimensional array. +subroutine CT_set_data(array_in, bc_index, field_index, var, & + scale_factor, halo_size, idim, jdim) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + !! must match the size of the data being copied + !! unless idim and jdim are supplied. + integer, intent(in) :: bc_index !< The index of the boundary condition + !! that is being copied + integer, intent(in) :: field_index !< The index of the field in the + !! boundary condition that is being set. The + !! surface concentration is set by default. + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default + integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of + !! the first dimension of the output array + !! in a non-decreasing list + integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of + !! the second dimension of the output array + !! in a non-decreasing list + + integer :: subfield ! An integer indicating which field to set. + + call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) + +end subroutine CT_set_data + +!> Potentially override the values in a coupler_2d_bc_type +subroutine CT_data_override(gridname, var, time) + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_data_override(gridname, var, time) +end subroutine CT_data_override + +!> Register the diagnostics of a coupler_2d_bc_type +subroutine CT_set_diags(var, diag_name, axes, time) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics + character(len=*), intent(in) :: diag_name !< name for diagnostic file, or blank not to register the fields + integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration + type(time_type), intent(in) :: time !< model time variable for registering diagnostic field + + call coupler_type_set_diags(var, diag_name, axes, time) + +end subroutine CT_set_diags + +!> Write out all diagnostics of elements of a coupler_2d_bc_type +subroutine CT_send_data(var, Time) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure with the diagnostics to write + type(time_type), intent(in) :: time !< The current model time + + call coupler_type_send_data(var, Time) +end subroutine CT_send_data + +!> Write out checksums for the elements of a coupler_2d_bc_type +subroutine CT_write_chksums_2d(var, outunit, name_lead) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_2d + +!> Write out checksums for the elements of a coupler_3d_bc_type +subroutine CT_write_chksums_3d(var, outunit, name_lead) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure for which to register diagnostics + integer, intent(in) :: outunit !< The index of a open output file + character(len=*), optional, intent(in) :: name_lead !< An optional prefix for the variable names + + call coupler_type_write_chksums(var, outunit, name_lead) + +end subroutine CT_write_chksums_3d + +!> Indicate whether a coupler_1d_bc_type has been initialized. +logical function CT_initialized_1d(var) + type(coupler_1d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_1d = coupler_type_initialized(var) +end function CT_initialized_1d + +!> Indicate whether a coupler_2d_bc_type has been initialized. +logical function CT_initialized_2d(var) + type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_2d = coupler_type_initialized(var) +end function CT_initialized_2d + +!> Indicate whether a coupler_3d_bc_type has been initialized. +logical function CT_initialized_3d(var) + type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to be deconstructed + + CT_initialized_3d = coupler_type_initialized(var) +end function CT_initialized_3d + +!> Deallocate all data associated with a coupler_1d_bc_type +subroutine CT_destructor_1d(var) + type(coupler_1d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_1d + +!> Deallocate all data associated with a coupler_2d_bc_type +subroutine CT_destructor_2d(var) + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be deconstructed + + call coupler_type_destructor(var) + +end subroutine CT_destructor_2d + +end module MOM_couplertype_infra diff --git a/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 new file mode 100644 index 0000000000..0c42c577b4 --- /dev/null +++ b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 @@ -0,0 +1,99 @@ +!> Wraps the MPP cpu clock functions +!! +!! The functions and constants should be accessed via mom_cpu_clock +module MOM_cpu_clock_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module +use fms_mod, only : clock_flag_default +use mpp_mod, only : mpp_clock_begin +use mpp_mod, only : mpp_clock_end, mpp_clock_id +use mpp_mod, only : MPP_CLOCK_COMPONENT => CLOCK_COMPONENT +use mpp_mod, only : MPP_CLOCK_SUBCOMPONENT => CLOCK_SUBCOMPONENT +use mpp_mod, only : MPP_CLOCK_MODULE_DRIVER => CLOCK_MODULE_DRIVER +use mpp_mod, only : MPP_CLOCK_MODULE => CLOCK_MODULE +use mpp_mod, only : MPP_CLOCK_ROUTINE => CLOCK_ROUTINE +use mpp_mod, only : MPP_CLOCK_LOOP => CLOCK_LOOP +use mpp_mod, only : MPP_CLOCK_INFRA => CLOCK_INFRA + +implicit none ; private + +! Public entities +public :: cpu_clock_id, cpu_clock_begin, cpu_clock_end +public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE +public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! component, e.g. the entire MOM6 model +integer, parameter :: CLOCK_COMPONENT = MPP_CLOCK_COMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! sub-component, e.g. dynamics or thermodynamics +integer, parameter :: CLOCK_SUBCOMPONENT = MPP_CLOCK_SUBCOMPONENT + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module driver, e.g. a routine that calls multiple other routines +integer, parameter :: CLOCK_MODULE_DRIVER = MPP_CLOCK_MODULE_DRIVER + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! module, e.g. the main entry routine for a module +integer, parameter :: CLOCK_MODULE = MPP_CLOCK_MODULE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! subroutine or function +integer, parameter :: CLOCK_ROUTINE = MPP_CLOCK_ROUTINE + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for a +!! section with in a routine, e.g. around a loop +integer, parameter :: CLOCK_LOOP = MPP_CLOCK_LOOP + +!> A granularity value to passed to cpu_clock_id() to indicate the clock is for an +!! infrastructure operation, e.g. a halo update +integer, parameter :: CLOCK_INFRA = MPP_CLOCK_INFRA + +contains + +!> Turns on clock with handle "id" +subroutine cpu_clock_begin(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_begin(id) + +end subroutine cpu_clock_begin + +!> Turns off clock with handle "id" +subroutine cpu_clock_end(id) + integer, intent(in) :: id !< Handle for clock + + call mpp_clock_end(id) + +end subroutine cpu_clock_end + +!> Returns the integer handle for a named CPU clock. +integer function cpu_clock_id(name, sync, grain) + character(len=*), intent(in) :: name !< The unique name of the CPU clock + logical, optional, intent(in) :: sync !< A flag that controls whether the + !! PEs are synchronized before the cpu clocks start counting. + !! Synchronization occurs before the start of a clock if this + !! is enabled, while additional (expensive) statistics can + !! set for other values. + !! If absent, the default is taken from the settings for FMS. + integer, optional, intent(in) :: grain !< The timing granularity for this clock, usually set to + !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. + + integer :: clock_flags + + clock_flags = clock_flag_default + if (present(sync)) then + if (sync) then + clock_flags = ibset(clock_flags, 0) + else + clock_flags = ibclr(clock_flags, 0) + endif + endif + + cpu_clock_id = mpp_clock_id(name, flags=clock_flags, grain=grain) +end function cpu_clock_id + +end module MOM_cpu_clock_infra diff --git a/config_src/infra/FMS2/MOM_data_override_infra.F90 b/config_src/infra/FMS2/MOM_data_override_infra.F90 new file mode 100644 index 0000000000..1484f0c128 --- /dev/null +++ b/config_src/infra/FMS2/MOM_data_override_infra.F90 @@ -0,0 +1,105 @@ +!> These interfaces allow for ocean or sea-ice variables to be replaced with data. +module MOM_data_override_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind +use MOM_time_manager, only : time_type +use data_override_mod, only : data_override_init +use data_override_mod, only : data_override +use data_override_mod, only : data_override_unset_domains + +implicit none ; private + +public :: impose_data_init, impose_data, impose_data_unset_domains + +!> Potentially override the values of a field in the model with values from a dataset. +interface impose_data + module procedure data_override_MD, data_override_2d +end interface + +contains + +!> Initialize the data override capability and set the domains for the ocean and ice components. +!> There should be a call to impose_data_init before impose_data is called. +subroutine impose_data_init(MOM_domain_in, Ocean_domain_in, Ice_domain_in) + type (MOM_domain_type), intent(in), optional :: MOM_domain_in + type (domain2d), intent(in), optional :: Ocean_domain_in + type (domain2d), intent(in), optional :: Ice_domain_in + + if (present(MOM_domain_in)) then + call data_override_init(Ocean_domain_in=MOM_domain_in%mpp_domain, Ice_domain_in=Ice_domain_in) + else + call data_override_init(Ocean_domain_in=Ocean_domain_in, Ice_domain_in=Ice_domain_in) + endif +end subroutine impose_data_init + + +!> Potentially override a 2-d field on a MOM6 domain with values from a dataset. +subroutine data_override_MD(domain, fieldname, data_2D, time, scale, override, is_ice) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call. + type(time_type), intent(in) :: time !< The model time, and the time for the data + real, optional, intent(in) :: scale !< A scaling factor that an overridden field is + !! multiplied by before it is returned. However, + !! if there is no override, there is no rescaling. + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + logical, optional, intent(in) :: is_ice !< If present and true, use the ice domain. + + logical :: overridden, is_ocean + integer :: i, j, is, ie, js, je + + overridden = .false. + is_ocean = .true. ; if (present(is_ice)) is_ocean = .not.is_ice + if (is_ocean) then + call data_override('OCN', fieldname, data_2D, time, override=overridden) + else + call data_override('ICE', fieldname, data_2D, time, override=overridden) + endif + + if (overridden .and. present(scale)) then ; if (scale /= 1.0) then + ! Rescale data in the computational domain if the data override has occurred. + call get_simple_array_i_ind(domain, size(data_2D,1), is, ie) + call get_simple_array_j_ind(domain, size(data_2D,2), js, je) + do j=js,je ; do i=is,ie + data_2D(i,j) = scale*data_2D(i,j) + enddo ; enddo + endif ; endif + + if (present(override)) override = overridden + +end subroutine data_override_MD + + +!> Potentially override a 2-d field with values from a dataset. +subroutine data_override_2d(gridname, fieldname, data_2D, time, override) + character(len=3), intent(in) :: gridname !< String identifying the model component, in MOM6 + !! and SIS this may be either 'OCN' or 'ICE' + character(len=*), intent(in) :: fieldname !< Name of the field to override + real, dimension(:,:), intent(inout) :: data_2D !< Data that may be modified by this call + type(time_type), intent(in) :: time !< The model time, and the time for the data + logical, optional, intent(out) :: override !< True if the field has been overridden successfully + + call data_override(gridname, fieldname, data_2D, time, override) + +end subroutine data_override_2d + +!> Unset domains that had previously been set for use by data_override. +subroutine impose_data_unset_domains(unset_Ocean, unset_Ice, must_be_set) + logical, intent(in), optional :: unset_Ocean !< If present and true, unset the ocean domain for overrides + logical, intent(in), optional :: unset_Ice !< If present and true, unset the sea-ice domain for overrides + logical, intent(in), optional :: must_be_set !< If present and true, it is a fatal error to unset + !! a domain that is not set. + + call data_override_unset_domains(unset_Ocean=unset_Ocean, unset_Ice=unset_Ice, & + must_be_set=must_be_set) +end subroutine impose_data_unset_domains + +end module MOM_data_override_infra + +!> \namespace MOM_data_override_infra +!! +!! The routines here wrap routines from the FMS module data_override_mod, which potentially replace +!! model values with values read from a data file. diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 new file mode 100644 index 0000000000..57f92c2046 --- /dev/null +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -0,0 +1,474 @@ +!> A wrapper for the FMS diag_manager routines. This module should be the +!! only MOM6 module which imports the FMS shared infrastructure for +!! diagnostics. Pass through interfaces are being documented +!! here and renamed in order to clearly identify these APIs as being +!! consistent with the FMS infrastructure (Any future updates to +!! those APIs would be applied here). +module MOM_diag_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use, intrinsic :: iso_fortran_env, only : real64 +use diag_axis_mod, only : fms_axis_init=>diag_axis_init +use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name +use diag_axis_mod, only : EAST, NORTH +use diag_data_mod, only : null_axis_id +use diag_manager_mod, only : fms_diag_manager_init => diag_manager_init +use diag_manager_mod, only : fms_diag_manager_end => diag_manager_end +use diag_manager_mod, only : diag_send_complete +use diag_manager_mod, only : diag_manager_set_time_end +use diag_manager_mod, only : send_data_fms => send_data +use diag_manager_mod, only : fms_diag_field_add_attribute => diag_field_add_attribute +use diag_manager_mod, only : DIAG_FIELD_NOT_FOUND +use diag_manager_mod, only : register_diag_field_fms => register_diag_field +use diag_manager_mod, only : register_static_field_fms => register_static_field +use diag_manager_mod, only : get_diag_field_id_fms => get_diag_field_id +use MOM_time_manager, only : time_type, set_time +use MOM_domain_infra, only : MOM_domain_type +use MOM_error_infra, only : MOM_error => MOM_err, FATAL, WARNING + +implicit none ; private + +!> transmit data for diagnostic output +interface register_diag_field_infra + module procedure register_diag_field_infra_scalar + module procedure register_diag_field_infra_array +end interface register_diag_field_infra + +!> transmit data for diagnostic output +interface send_data_infra + module procedure send_data_infra_0d, send_data_infra_1d + module procedure send_data_infra_2d, send_data_infra_3d +#ifdef OVERLOAD_R8 + module procedure send_data_infra_2d_r8, send_data_infra_3d_r8 +#endif +end interface send_data_infra + +!> Add an attribute to a diagnostic field +interface MOM_diag_field_add_attribute + module procedure MOM_diag_field_add_attribute_scalar_r + module procedure MOM_diag_field_add_attribute_scalar_i + module procedure MOM_diag_field_add_attribute_scalar_c + module procedure MOM_diag_field_add_attribute_r1d + module procedure MOM_diag_field_add_attribute_i1d +end interface MOM_diag_field_add_attribute + + +! Public interfaces +public MOM_diag_axis_init +public get_MOM_diag_axis_name +public MOM_diag_manager_init +public MOM_diag_manager_end +public send_data_infra +public diag_send_complete_infra +public diag_manager_set_time_end_infra +public MOM_diag_field_add_attribute +public register_diag_field_infra +public register_static_field_infra +public get_MOM_diag_field_id +! Public data +public null_axis_id +public DIAG_FIELD_NOT_FOUND +public EAST, NORTH + + +contains + +!> Initialize a diagnostic axis +integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & + & direction, edges, set_name, coarsen, null_axis) + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif + + if (present(MOM_domain)) then + coarsening = 1 ; if (present(coarsen)) coarsening = coarsen + if (coarsening == 1) 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 + 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.") + endif + else + if (present(coarsen)) then ; if (coarsen /= 1) then + call MOM_error(FATAL, "diag_axis_init does not support grid coarsening without a MOM_domain.") + endif ; endif + MOM_diag_axis_init = fms_axis_init(name, data, units, cart_name, long_name=long_name, & + direction=direction, set_name=set_name, edges=edges) + endif + +end function MOM_diag_axis_init + +!> Returns the short name of the axis +subroutine get_MOM_diag_axis_name(id, name) + integer, intent(in) :: id !< The axis numeric id + character(len=*), intent(out) :: name !< The short name of the axis + + call fms_get_diag_axis_name(id, name) + +end subroutine get_MOM_diag_axis_name + +!> Return a unique numeric ID field a module/field name combination. +integer function get_MOM_diag_field_id(module_name, field_name) + character(len=*), intent(in) :: module_name !< A module name string to query. + character(len=*), intent(in) :: field_name !< A field name string to query. + + + get_MOM_diag_field_id = -1 + get_MOM_diag_field_id = get_diag_field_id_fms(module_name, field_name) + +end function get_MOM_diag_field_id + +!> Initializes the diagnostic manager +subroutine MOM_diag_manager_init(diag_model_subset, time_init, err_msg) + integer, optional, intent(in) :: diag_model_subset !< An optional diagnostic subset + integer, dimension(6), optional, intent(in) :: time_init !< An optional reference time for diagnostics + !! The default uses the value contained in the + !! diag_table. Format is Y-M-D-H-M-S + character(len=*), optional, intent(out) :: err_msg !< Error message. + call FMS_diag_manager_init(diag_model_subset, time_init, err_msg) + +end subroutine MOM_diag_manager_init + +!> Close the diagnostic manager +subroutine MOM_diag_manager_end(time) + type(time_type), intent(in) :: time !< Model time at call to close. + + call FMS_diag_manager_end(time) + +end subroutine MOM_diag_manager_end + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_infra_scalar(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, & + err_msg, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Field units + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_scalar = register_diag_field_fms(module_name, field_name, init_time, & + long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume) + +end function register_diag_field_infra_scalar + +!> Register a MOM diagnostic field for scalars +integer function register_diag_field_infra_array(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, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + type(time_type), optional, intent(in) :: init_time !< The registration time + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: verbose !< If true, provide additional log information + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + 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 !< The tile number for the current PE + character(len=*), optional, intent(out):: err_msg !< An error message to return + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + register_diag_field_infra_array = register_diag_field_fms(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, area, volume) + +end function register_diag_field_infra_array + + +integer function register_static_field_infra(module_name, field_name, axes, long_name, units, & + missing_value, range, mask_variant, standard_name, do_not_log, interp_method, & + tile_count, area, volume) + character(len=*), intent(in) :: module_name !< The name of the associated module + character(len=*), intent(in) :: field_name !< The name of the field + integer, dimension(:), intent(in) :: axes !< Diagnostic IDs of axis attributes for the field + character(len=*), optional, intent(in) :: long_name !< A long name for the field + character(len=*), optional, intent(in) :: units !< Units of the field + real, optional, intent(in) :: missing_value !< Missing value attribute + real, dimension(2), optional, intent(in) :: range !< A valid range of the field + logical, optional, intent(in) :: mask_variant !< If true, the field mask is varying in time + character(len=*), optional, intent(in) :: standard_name !< A standard name for the field + logical, optional, intent(in) :: do_not_log !< if TRUE, field information is not logged + 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 !< The tile number for the current PE + integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute + integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute + + if(present(missing_value) .or. present(range)) then + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant=mask_variant, standard_name=standard_name, dynamic=.false.,& + do_not_log=do_not_log, interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) + else + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & mask_variant=mask_variant, standard_name=standard_name, dynamic=.false.,do_not_log=do_not_log, & + interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) + endif +end function register_static_field_infra + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_0d(diag_field_id, field, time, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, intent(in) :: field !< The value being recorded + TYPE(time_type), optional, intent(in) :: time !< The time for the current record + CHARACTER(len=*), optional, intent(out) :: err_msg !< An optional error message + + send_data_infra_0d = send_data_fms(diag_field_id, field, time, err_msg) +end function send_data_infra_0d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_1d(diag_field_id, field, is_in, ie_in, time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:), intent(in) :: field !< A 1-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:), optional, intent(in) :: mask !< An optional rank 1 logical mask + real, dimension(:), optional, intent(in) :: rmask !< An optional rank 1 mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + if(present(rmask) .or. present(weight)) then + if(present(rmask) .and. present(weight)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, mask=mask, rmask=rmask, ie_in=ie_in,& + weight=weight, err_msg=err_msg) + elseif(present(rmask)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, mask=mask, rmask=rmask, ie_in=ie_in,& + err_msg=err_msg) + elseif(present(weight)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, ie_in=ie_in, weight=weight,& + err_msg=err_msg) + endif + else + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, ie_in=ie_in, err_msg=err_msg) + endif + +end function send_data_infra_1d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_2d(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + if(present(rmask) .or. present(weight)) then + if(present(rmask) .and. present(weight)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + rmask=rmask, ie_in=ie_in, je_in=je_in, weight=weight, err_msg=err_msg) + elseif(present(rmask)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + rmask=rmask, ie_in=ie_in, je_in=je_in, err_msg=err_msg) + elseif(present(weight)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + ie_in=ie_in, je_in=je_in, weight=weight, err_msg=err_msg) + endif + else + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + ie_in=ie_in, je_in=je_in, err_msg=err_msg) + endif +end function send_data_infra_2d + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_3d(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real, dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, & + rmask, ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d + + +#ifdef OVERLOAD_R8 +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:), optional, intent(in) :: mask !< An optional 2-d logical mask + real, dimension(:,:), optional, intent(in) :: rmask !< An optional 2-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_2d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & + rmask, ie_in, je_in, weight, err_msg) + +end function send_data_infra_2d_r8 + +!> Returns true if the argument data are successfully passed to a diagnostic manager +!! with the indicated unique reference id, false otherwise. +logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & + time, mask, rmask, weight, err_msg) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded + integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded + integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded + integer, optional, intent(in) :: je_in !< The end j-index for the data being recorded + integer, optional, intent(in) :: ks_in !< The starting k-index for the data being recorded + integer, optional, intent(in) :: ke_in !< The end k-index for the data being recorded + type(time_type), optional, intent(in) :: time !< The time for the current record + logical, dimension(:,:,:), optional, intent(in) :: mask !< An optional 3-d logical mask + real, dimension(:,:,:), optional, intent(in) :: rmask !< An optional 3-d mask array + real, optional, intent(in) :: weight !< A scalar weight factor to apply to the current + !! record if there is averaging in time + character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon + !! returning to the calling routine + + send_data_infra_3d_r8 = send_data_fms(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, & + ie_in, je_in, ke_in, weight, err_msg) + +end function send_data_infra_3d_r8 +#endif + +!> Add a real scalar attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, intent(in) :: att_value !< A real scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_r + +!> Add an integer attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, intent(in) :: att_value !< An integer scalar value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_i + +!> Add a character string attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + character(len=*), intent(in) :: att_value !< A character string value + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_scalar_c + +!> Add a real list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + real, dimension(:), intent(in) :: att_value !< An array of real values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_r1d + +!> Add a integer list of attributes attribute to a diagnostic field +subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) + integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field + character(len=*), intent(in) :: att_name !< The name of the attribute + integer, dimension(:), intent(in) :: att_value !< An array of integer values + + call FMS_diag_field_add_attribute(diag_field_id, att_name, att_value) + +end subroutine MOM_diag_field_add_attribute_i1d + +!> Finishes the diag manager reduction methods as needed for the time_step +subroutine diag_send_complete_infra () + !! The time_step in the diag_send_complete call is a dummy argument, needed for backwards compatibility + !! It won't be used at all when diag_manager_nml::use_modern_diag=.true. + !! It won't have any impact when diag_manager_nml::use_modern_diag=.false. + call diag_send_complete (set_time(0)) +end subroutine diag_send_complete_infra + +!> Sets the time that the simulation ends in the diag manager +subroutine diag_manager_set_time_end_infra(time) + type(time_type), optional, intent(in) :: time !< The time the simulation ends + + call diag_manager_set_time_end(time) +end subroutine diag_manager_set_time_end_infra + +end module MOM_diag_manager_infra diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 new file mode 100644 index 0000000000..2d5c722cbd --- /dev/null +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -0,0 +1,2052 @@ +!> Describes the decomposed MOM domain and has routines for communications across PEs +module MOM_domain_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms_infra, only : PE_here, root_PE, num_PEs +use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL + +use mpp_domains_mod, only : domain2D, domain1D +use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain +use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents, mpp_get_layout +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain +use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains +use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains +use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update +use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized +use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update +use mpp_domains_mod, only : mpp_compute_block_extent, mpp_compute_extent +use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field +use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN +use mpp_domains_mod, only : FOLD_NORTH_EDGE, FOLD_SOUTH_EDGE, FOLD_EAST_EDGE, FOLD_WEST_EDGE +use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE +use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST +use fms_io_utils_mod, only : file_exists, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get + +! This subroutine is not in MOM6/src but may be required by legacy drivers +! use mpp_domains_mod, only : global_field_sum => mpp_global_sum + +! The `group_pass_type` fields are never accessed, so we keep it as an FMS type +use mpp_domains_mod, only : group_pass_type => mpp_group_update_type + +implicit none ; private + +! These types are inherited from mpp, but are treated as opaque here. +public :: domain2D, domain1D, group_pass_type +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent +public :: deallocate_MOM_domain, get_global_shape, compute_block_extent, compute_extent +public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data +public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete +public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass +public :: redistribute_array, broadcast_domain, same_domain, global_field +public :: get_simple_array_i_ind, get_simple_array_j_ind +public :: MOM_thread_affinity_set, set_MOM_thread_affinity +! These are encoding constant parmeters with self-explanatory names. +public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +public :: set_domain, nullify_domain +! These are no longer used by MOM6 because the reproducing sum works so well, but they are +! still referenced by some of the non-GFDL couplers. +! public :: global_field_sum, BITWISE_EXACT_SUM + +!> Do a halo update on an array +interface pass_var + module procedure pass_var_3d, pass_var_2d +end interface pass_var + +!> Do a halo update on a pair of arrays representing the two components of a vector +interface pass_vector + module procedure pass_vector_3d, pass_vector_2d +end interface pass_vector + +!> Initiate a non-blocking halo update on an array +interface pass_var_start + module procedure pass_var_start_3d, pass_var_start_2d +end interface pass_var_start + +!> Complete a non-blocking halo update on an array +interface pass_var_complete + module procedure pass_var_complete_3d, pass_var_complete_2d +end interface pass_var_complete + +!> Initiate a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_start + module procedure pass_vector_start_3d, pass_vector_start_2d +end interface pass_vector_start + +!> Complete a halo update on a pair of arrays representing the two components of a vector +interface pass_vector_complete + module procedure pass_vector_complete_3d, pass_vector_complete_2d +end interface pass_vector_complete + +!> Set up a group of halo updates +interface create_group_pass + module procedure create_var_group_pass_2d + module procedure create_var_group_pass_3d + module procedure create_vector_group_pass_2d + module procedure create_vector_group_pass_3d +end interface create_group_pass + +!> Do a set of halo updates that fill in the values at the duplicated edges +!! of a staggered symmetric memory domain +interface fill_symmetric_edges + module procedure fill_vector_symmetric_edges_2d !, fill_vector_symmetric_edges_3d +! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d +end interface fill_symmetric_edges + +!> Rescale the values of an array in its computational domain by a constant factor +interface rescale_comp_data + module procedure rescale_comp_data_4d, rescale_comp_data_3d, rescale_comp_data_2d +end interface rescale_comp_data + +!> Pass an array from one MOM domain to another +interface redistribute_array + module procedure redistribute_array_2d, redistribute_array_3d, redistribute_array_4d +end interface redistribute_array + +!> Copy one MOM_domain_type into another +interface clone_MOM_domain + module procedure clone_MD_to_MD, clone_MD_to_d2D +end interface clone_MOM_domain + +!> Extract the 1-d domain components from a MOM_domain or domain2d +interface get_domain_components + module procedure get_domain_components_MD, get_domain_components_d2D +end interface get_domain_components + +!> Returns the index ranges that have been stored in a MOM_domain_type +interface get_domain_extent + module procedure get_domain_extent_MD, get_domain_extent_d2D +end interface get_domain_extent + + +!> The MOM_domain_type contains information about the domain decomposition. +type, public :: MOM_domain_type + 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 + !! on this processor, centered at h points. + integer :: niglobal !< The total horizontal i-domain size. + integer :: njglobal !< The total horizontal j-domain size. + integer :: nihalo !< The i-halo size in memory. + integer :: njhalo !< The j-halo size in memory. + logical :: symmetric !< True if symmetric memory is used with this domain. + logical :: nonblocking_updates !< If true, non-blocking halo updates are + !! allowed. The default is .false. (for now). + logical :: thin_halo_updates !< If true, optional arguments may be used to + !! specify the width of the halos that are + !! updated with each call. + integer :: layout(2) !< This domain's processor layout. This is + !! saved to enable the construction of related + !! new domains with different resolutions or + !! other properties. + integer :: io_layout(2) !< The IO-layout used with this domain. + integer :: X_FLAGS !< Flag that specifies the properties of the + !! domain in the i-direction in a define_domain call. + integer :: Y_FLAGS !< Flag that specifies the properties of the + !! domain in the j-direction in a define_domain call. + logical, pointer :: maskmap(:,:) => NULL() !< A pointer to an array indicating + !! which logical processors are actually used for + !! the ocean code. The other logical processors + !! would be contain only land points and are not + !! assigned to actual processors. This need not be + !! assigned if all logical processors are used. + integer :: turns !< Number of quarter-turns from input to this grid. + type(MOM_domain_type), pointer :: domain_in => NULL() + !< Reference to unrotated domain (if turned) +end type MOM_domain_type + +integer, parameter :: To_All = To_East + To_West + To_North + To_South !< A flag for passing in all directions + +contains + +!> pass_var_3d does a halo update for a three-dimensional array. +subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! sothe halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_3d + +!> pass_var_2d does a halo update for a two-dimensional array. +subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo + !! by default. + integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, + !! or 0 to avoid updating symmetric memory + !! computational domain points. Setting this >=0 + !! also enforces that complete=.true. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + real, allocatable, dimension(:,:) :: tmp + integer :: pos, i_halo, j_halo + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + block_til_complete = .true. ; if (present(complete)) block_til_complete = complete + pos = CENTER ; if (present(position)) pos = position + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + ! Store the original values. + allocate(tmp(size(array,1), size(array,2))) + tmp(:,:) = array(:,:) + block_til_complete = .true. + endif ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & + complete=block_til_complete, position=position) + endif + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + ! Convert to local indices for arrays starting at 1. + isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1 + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1 + i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1) + + ! Figure out the array index extents of the eastern, western, northern and southern regions to copy. + if (pos == CENTER) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif + elseif (pos == CORNER) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + elseif (pos == NORTH_FACE) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif + elseif (pos == EAST_FACE) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif + else + call MOM_error(FATAL, "pass_var_2d: Unrecognized position") + endif + + ! Copy back the stored inner halo points + do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + + deallocate(tmp) + endif ; endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_2d + +!> pass_var_start_2d starts a halo update for a two-dimensional array. +function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_2d !0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_2d + +!> pass_var_start_3d starts a halo update for a three-dimensional array. +function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before + !! progress resumes. Omitting complete is the + !! same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_var_start_3d !< The integer index for this update. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_var_start_3d + +!> pass_var_complete_2d completes a halo update for a two-dimensional array. +subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_2d + +!> pass_var_complete_3d completes a halo update for a three-dimensional array. +subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has + !! been returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, & + flags=dirflag, position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_var_complete_3d + +!> pass_vector_2d does a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_2d + +!> fill_vector_symmetric_edges_2d does an usual set of halo updates that only +!! fill in the values at the edge of a pair of symmetric memory two-dimensional +!! arrays representing the components of a two-dimensional horizontal vector. +!! If symmetric memory is not being used, this subroutine does nothing except to +!! possibly turn optional cpu clocks on or off. +subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scalar, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: scalar !< An optional argument indicating whether. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y + logical :: block_til_complete + + if (.not. MOM_dom%symmetric) then + return + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + if (.not.(stagger_local == CGRID_NE .or. stagger_local == BGRID_NE)) return + + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + + ! Adjust isc, etc., to account for the fact that the input arrays indices all + ! start at 1 (and are effectively on a SW grid!). + isc = isc - (isd-1) ; iec = iec - (isd-1) + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) + IscB = isc ; IecB = iec+1 ; JscB = jsc ; JecB = jec+1 + + dirflag = To_All ! 60 + if (present(scalar)) then ; if (scalar) dirflag = To_All+SCALAR_PAIR ; endif + + if (stagger_local == CGRID_NE) then + allocate(wbuff_x(jsc:jec)) ; allocate(sbuff_y(isc:iec)) + wbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbuffery=sbuff_y, & + gridtype=CGRID_NE) + do i=isc,iec + v_cmpt(i,JscB) = sbuff_y(i) + enddo + do j=jsc,jec + u_cmpt(IscB,j) = wbuff_x(j) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_y) + elseif (stagger_local == BGRID_NE) then + allocate(wbuff_x(JscB:JecB)) ; allocate(sbuff_x(IscB:IecB)) + allocate(wbuff_y(JscB:JecB)) ; allocate(sbuff_y(IscB:IecB)) + wbuff_x(:) = 0.0 ; wbuff_y(:) = 0.0 ; sbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0 + call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + wbufferx=wbuff_x, sbufferx=sbuff_x, & + wbuffery=wbuff_y, sbuffery=sbuff_y, & + gridtype=BGRID_NE) + do I=IscB,IecB + u_cmpt(I,JscB) = sbuff_x(I) ; v_cmpt(I,JscB) = sbuff_y(I) + enddo + do J=JscB,JecB + u_cmpt(IscB,J) = wbuff_x(J) ; v_cmpt(IscB,J) = wbuff_y(J) + enddo + deallocate(wbuff_x) ; deallocate(sbuff_x) + deallocate(wbuff_y) ; deallocate(sbuff_y) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine fill_vector_symmetric_edges_2d + +!> pass_vector_3d does a halo update for a pair of three-dimensional arrays +!! representing the components of a three-dimensional horizontal vector. +subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + logical :: block_til_complete + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + block_til_complete = .true. + if (present(complete)) block_til_complete = complete + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, & + gridtype=stagger_local, complete = block_til_complete) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_3d + +!> pass_vector_start_2d starts a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_2d !< The integer index for this + !! update. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_2d + +!> pass_vector_start_3d starts a halo update for a pair of three-dimensional arrays +!! representing the components of a three-dimensional horizontal vector. +function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, & + clock) + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + logical, optional, intent(in) :: complete !< An optional argument indicating whether the + !! halo updates should be completed before progress resumes. + !! Omitting complete is the same as setting complete to .true. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + integer :: pass_vector_start_3d !< The integer index for this + !! update. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end function pass_vector_start_3d + +!> pass_vector_complete_2d completes a halo update for a pair of two-dimensional arrays +!! representing the components of a two-dimensional horizontal vector. +subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_2d + +!> pass_vector_complete_3d completes a halo update for a pair of three-dimensional +!! arrays representing the components of a three-dimensional horizontal vector. +subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + integer, intent(in) :: id_update !< The integer id of this update which has been + !! returned from a previous call to + !! pass_var_start. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, & + whalo=halo, ehalo=halo, shalo=halo, nhalo=halo) + else + call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, & + MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine pass_vector_complete_3d + +!> create_var_group_pass_2d sets up a group of two-dimensional array halo updates. +subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & + halo, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_2d + +!> create_var_group_pass_3d sets up a group of three-dimensional array halo updates. +subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points + !! exchanged. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: sideflag !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, + !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. + integer, optional, intent(in) :: position !< An optional argument indicating the position. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + dirflag = To_All ! 60 + if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, & + position=position) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_var_group_pass_3d + +!> create_vector_group_pass_2d sets up a group of two-dimensional vector halo updates. +subroutine create_vector_group_pass_2d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_2d + +!> create_vector_group_pass_3d sets up a group of three-dimensional vector halo updates. +subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, & + clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector + !! pair which is having its halos points + !! exchanged. + real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the + !! vector pair which is having its halos points + !! exchanged. + + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: direction !< An optional integer indicating which + !! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST, + !! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional + !! scalars discretized at the typical vector component locations. For example, TO_EAST sends + !! the data to the processor to the east, so the halos on the western side are filled. TO_ALL + !! is the default if omitted. + integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID, + !! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are + !! discretized. Omitting stagger is the same as setting it to CGRID_NE. + integer, optional, intent(in) :: halo !< The size of the halo to update - the full + !! halo by default. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + ! Local variables + integer :: stagger_local + integer :: dirflag + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + stagger_local = CGRID_NE ! Default value for type of grid + if (present(stagger)) stagger_local = stagger + + dirflag = To_All ! 60 + if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + elseif (present(halo) .and. MOM_dom%thin_halo_updates) then + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, & + shalo=halo, nhalo=halo) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, & + flags=dirflag, gridtype=stagger_local) + endif + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine create_vector_group_pass_3d + +!> do_group_pass carries out a group halo update. +subroutine do_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine do_group_pass + +!> start_group_pass starts out a group halo update. +subroutine start_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_start_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine start_group_pass + +!> complete_group_pass completes a group halo update. +subroutine complete_group_pass(group, MOM_dom, clock) + type(group_pass_type), intent(inout) :: group !< The data type that store information for + !! group update. This data will be used in + !! do_group_pass. + type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain + !! needed to determine where data should be + !! sent. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + !! started then stopped to time this routine. + real :: d_type + + if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif + + call mpp_complete_group_update(group, MOM_dom%mpp_domain, d_type) + + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif + +end subroutine complete_group_pass + + +!> Pass a 2-D array from one MOM domain to another +subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_2d + +!> Pass a 3-D array from one MOM domain to another +subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_3d + +!> Pass a 4-D array from one MOM domain to another +subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) + type(domain2d), & + intent(in) :: Domain1 !< The MOM domain from which to extract information. + real, dimension(:,:,:,:), intent(in) :: array1 !< The array from which to extract information. + type(domain2d), & + intent(in) :: Domain2 !< The MOM domain receiving information. + real, dimension(:,:,:,:), intent(out) :: array2 !< The array receiving information. + logical, optional, intent(in) :: complete !< If true, finish communication before proceeding. + + ! Local variables + logical :: do_complete + + do_complete=.true.;if (PRESENT(complete)) do_complete = complete + + call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) + +end subroutine redistribute_array_4d + + +!> Rescale the values of a 4-D array in its computational domain by a constant factor +subroutine rescale_comp_data_4d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + +end subroutine rescale_comp_data_4d + +!> Rescale the values of a 3-D array in its computational domain by a constant factor +subroutine rescale_comp_data_3d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + +end subroutine rescale_comp_data_3d + +!> Rescale the values of a 2-D array in its computational domain by a constant factor +subroutine rescale_comp_data_2d(domain, array, scale) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + real, dimension(:,:), intent(inout) :: array !< The array which is having the data in its + !! computational domain rescaled + real, intent(in) :: scale !< A scaling factor by which to multiply the + !! values in the computational domain of array + integer :: is, ie, js, je + + if (scale == 1.0) return + + call get_simple_array_i_ind(domain, size(array,1), is, ie) + call get_simple_array_j_ind(domain, size(array,2), js, je) + array(is:ie,js:je) = scale*array(is:ie,js:je) + +end subroutine rescale_comp_data_2d + +!> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information +!! provided in arguments. +subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, io_layout, & + domain_name, mask_table, symmetric, thin_halos, nonblocking) + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here. + integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in + !! the i- and j-directions + integer, dimension(2), intent(in) :: n_halo !< The number of halo points on each processor + logical, dimension(2), intent(in) :: reentrant !< If true the grid is periodic in the i- and j- directions + logical, intent(in) :: tripolar_N !< If true the grid uses northern tripolar connectivity + integer, dimension(2), intent(in) :: layout !< The layout of logical PEs in the i- and j-directions. + integer, dimension(2), optional, intent(in) :: io_layout !< The layout for parallel input and output. + character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" if missing. + character(len=*), optional, intent(in) :: mask_table !< The full relative or absolute path to the mask table. + logical, optional, intent(in) :: symmetric !< If present, this specifies whether this domain + !! uses symmetric memory, or true if missing. + logical, optional, intent(in) :: thin_halos !< If present, this specifies whether to permit the use of + !! thin halo updates, or true if missing. + logical, optional, intent(in) :: nonblocking !< If present, this specifies whether to permit the use of + !! nonblocking halo updates, or false if missing. + + ! local variables + integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds + integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. + integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. + integer :: xhalo_d2, yhalo_d2 + character(len=200) :: mesg ! A string for use in error messages + logical :: mask_table_exists ! Mask_table is present and the file it points to exists + + 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) + + X_FLAGS = 0 ; Y_FLAGS = 0 + if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (reentrant(2)) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN + if (tripolar_N) then + Y_FLAGS = FOLD_NORTH_EDGE + if (reentrant(2)) call MOM_error(FATAL,"MOM_domains: "// & + "TRIPOLAR_N and REENTRANT_Y may not be used together.") + endif + + MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = thin_halos + MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric + MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) + MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) + + ! Save the extra data for creating other domains of different resolution that overlay this domain. + MOM_dom%X_FLAGS = X_FLAGS + MOM_dom%Y_FLAGS = Y_FLAGS + MOM_dom%layout(:) = layout(:) + + ! Set up the io_layout, with error handling. + MOM_dom%io_layout(:) = (/ 1, 1 /) + if (present(io_layout)) then + if (io_layout(1) == 0) then + MOM_dom%io_layout(1) = layout(1) + elseif (io_layout(1) > 1) then + MOM_dom%io_layout(1) = io_layout(1) + if (modulo(layout(1), io_layout(1)) /= 0) then + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1) + call MOM_error(FATAL, mesg) + endif + endif + + if (io_layout(2) == 0) then + MOM_dom%io_layout(2) = layout(2) + elseif (io_layout(2) > 1) then + MOM_dom%io_layout(2) = io_layout(2) + if (modulo(layout(2), io_layout(2)) /= 0) then + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2) + call MOM_error(FATAL, mesg) + endif + endif + endif + + if (present(mask_table)) then + mask_table_exists = file_exists(mask_table) + if (mask_table_exists) then + allocate(MOM_dom%maskmap(layout(1), layout(2))) + call parse_mask_table(mask_table, MOM_dom%maskmap, MOM_dom%name) + endif + else + mask_table_exists = .false. + endif + + ! Initialize as an unrotated domain + MOM_dom%turns = 0 + + 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 +!! and potentially all of its contents +subroutine deallocate_MOM_domain(MOM_domain, cursory) + type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated + 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 + + invasive = .true. ; if (present(cursory)) invasive = .not.cursory + + if (associated(MOM_domain)) then + if (associated(MOM_domain%mpp_domain)) then + 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) + endif + if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap) + deallocate(MOM_domain) + endif + +end subroutine deallocate_MOM_domain + +!> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1. +function MOM_thread_affinity_set() + ! Local variables + !$ integer :: ocean_nthreads ! Number of openMP threads + !$ integer :: omp_get_num_threads ! An openMP function that returns the number of threads + logical :: MOM_thread_affinity_set + + MOM_thread_affinity_set = .false. + !$ call fms_affinity_init() + !$OMP PARALLEL + !$OMP MASTER + !$ ocean_nthreads = omp_get_num_threads() + !$OMP END MASTER + !$OMP END PARALLEL + !$ MOM_thread_affinity_set = (ocean_nthreads > 1 ) +end function MOM_thread_affinity_set + +!> set_MOM_thread_affinity sets the number of openMP threads to use with the ocean. +subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread) + integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model + logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading + + ! Local variables + !$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions + + !$ call fms_affinity_init() ! fms_affinity_init can be safely called more than once. + !$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads) + !$ call omp_set_num_threads(ocean_nthreads) + !$OMP PARALLEL + !$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() + !$ flush(6) + !$OMP END PARALLEL +end subroutine set_MOM_thread_affinity + +!> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain +subroutine get_domain_components_MD(MOM_dom, x_domain, y_domain) + type(MOM_domain_type), intent(in) :: MOM_dom !< The MOM_domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(MOM_dom%mpp_domain, x_domain, y_domain) +end subroutine get_domain_components_MD + +!> This subroutine retrieves the 1-d domains that make up a 2d-domain +subroutine get_domain_components_d2D(domain, x_domain, y_domain) + type(domain2D), intent(in) :: domain !< The 2D domain whose contents are being extracted + type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain + type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain + + call mpp_get_domain_components(domain, x_domain, y_domain) +end subroutine get_domain_components_d2D + +!> clone_MD_to_MD copies one MOM_domain_type into another, while allowing +!! some properties of the new type to differ from the original one. +subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & + turns, refine, extra_halo, io_layout) + type(MOM_domain_type), target, intent(in) :: MD_in !< An existing MOM_domain + type(MOM_domain_type), pointer :: MOM_dom + !< A pointer to a MOM_domain that will be + !! allocated if it is unassociated, and will have data + !! copied from MD_in + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, copied + !! from MD_in if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns + integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution. + integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos + !! compared with MD_in + integer, optional, intent(in) :: io_layout(2) + !< A user-defined IO layout to replace the domain's IO layout + + + integer :: global_indices(4) + logical :: mask_table_exists + integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer, dimension(:), allocatable :: exnj ! The extents of the grid for each j-row of the layout. + ! The sum of exni must equal MOM_dom%niglobal. + integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. + integer :: i, j, nl1, nl2 + integer :: io_layout_in(2) + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (present(io_layout)) then + io_layout_in(:) = io_layout(:) + else + io_layout_in(:) = MD_in%io_layout(:) + endif + + if (.not.associated(MOM_dom)) then + allocate(MOM_dom) + allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) + endif + +! Save the extra data for creating other domains of different resolution that overlay this domain + MOM_dom%symmetric = MD_in%symmetric + MOM_dom%nonblocking_updates = MD_in%nonblocking_updates + MOM_dom%thin_halo_updates = MD_in%thin_halo_updates + + if (modulo(qturns, 2) /= 0) then + MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal + MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo + call get_layout_extents(MD_in, exnj, exni) + + MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (modulo(qturns, 4) == 1) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + elseif (modulo(qturns, 4) == 3) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + endif + + MOM_dom%layout(:) = MD_in%layout(2:1:-1) + MOM_dom%io_layout(:) = io_layout_in(2:1:-1) + else + MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal + MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo + call get_layout_extents(MD_in, exni, exnj) + + MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (modulo(qturns, 4) == 2) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + endif + + MOM_dom%layout(:) = MD_in%layout(:) + MOM_dom%io_layout(:) = io_layout_in(:) + endif + + ! Ensure that the points per processor are the same on the source and destination grids. + select case (qturns) + case (1) ; call invert(exni) + case (2) ; call invert(exni) ; call invert(exnj) + case (3) ; call invert(exnj) + end select + + if (associated(MD_in%maskmap)) then + mask_table_exists = .true. + allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) + + nl1 = MOM_dom%layout(1) ; nl2 = MOM_dom%layout(2) + select case (qturns) + case (0) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(i, j) + enddo ; enddo + case (1) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(j, nl1+1-i) + enddo ; enddo + case (2) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl1+1-i, nl2+1-j) + enddo ; enddo + case (3) + do j=1,nl2 ; do i=1,nl1 + MOM_dom%maskmap(i,j) = MD_in%maskmap(nl2+1-j, i) + enddo ; enddo + end select + else + mask_table_exists = .false. + endif + + ! Optionally enhance the grid resolution. + if (present(refine)) then ; if (refine > 1) then + MOM_dom%niglobal = refine*MOM_dom%niglobal ; MOM_dom%njglobal = refine*MOM_dom%njglobal + MOM_dom%nihalo = refine*MOM_dom%nihalo ; MOM_dom%njhalo = refine*MOM_dom%njhalo + do i=1,MOM_dom%layout(1) ; exni(i) = refine*exni(i) ; enddo + do j=1,MOM_dom%layout(2) ; exnj(j) = refine*exnj(j) ; enddo + endif ; endif + + ! Optionally enhance the grid resolution. + if (present(extra_halo)) then ; if (extra_halo > 0) then + MOM_dom%nihalo = MOM_dom%nihalo + extra_halo ; MOM_dom%njhalo = MOM_dom%njhalo + extra_halo + endif ; endif + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + if (present(min_halo)) then + MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) + min_halo(1) = MOM_dom%nihalo + MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) + min_halo(2) = MOM_dom%njhalo + endif + + if (present(halo_size)) then + MOM_dom%nihalo = halo_size ; MOM_dom%njhalo = halo_size + endif + + if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif + + if (present(domain_name)) then + MOM_dom%name = trim(domain_name) + else + MOM_dom%name = MD_in%name + endif + + MOM_dom%turns = qturns + if (qturns /= 0) then + MOM_dom%domain_in => MD_in + 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 + + +!> clone_MD_to_d2D uses information from a MOM_domain_type to create a new +!! domain2d type, while allowing some properties of the new type to differ from +!! the original one. +subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & + domain_name, turns, xextent, yextent, coarsen) + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned + type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domain in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined or + !! whether MD_in is symmetric. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns - not implemented here. + integer, optional, intent(in) :: coarsen !< A factor by which to coarsen this grid. + !! The default of 1 is for no coarsening. + integer, dimension(:), optional, intent(in) :: xextent !< The number of grid points in the + !! tracer computational domain for division of the x-layout. + integer, dimension(:), optional, intent(in) :: yextent !< The number of grid points in the + !! tracer computational domain for division of the y-layout. + + integer :: global_indices(4) + integer :: nihalo, njhalo + logical :: symmetric_dom, do_coarsen + character(len=64) :: dom_name + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") + + if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, & + "clone_MOM_domain can not have both halo_size and min_halo present.") + + do_coarsen = .false. ; if (present(coarsen)) then ; do_coarsen = (coarsen > 1) ; endif + + nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo + if (do_coarsen) then + nihalo = int(MD_in%nihalo / coarsen) ; njhalo = int(MD_in%njhalo / coarsen) + endif + + if (present(min_halo)) then + nihalo = max(nihalo, min_halo(1)) + njhalo = max(njhalo, min_halo(2)) + min_halo(1) = nihalo ; min_halo(2) = njhalo + endif + if (present(halo_size)) then + nihalo = halo_size ; njhalo = halo_size + endif + + symmetric_dom = MD_in%symmetric + if (present(symmetric)) then ; symmetric_dom = symmetric ; endif + + dom_name = MD_in%name + if (do_coarsen) dom_name = trim(MD_in%name)//"c" + if (present(domain_name)) dom_name = trim(domain_name) + + global_indices(1:4) = (/ 1, MD_in%niglobal, 1, MD_in%njglobal /) + if (do_coarsen) then + global_indices(1:4) = (/ 1, (MD_in%niglobal/coarsen), 1, (MD_in%njglobal/coarsen) /) + endif + + if (associated(MD_in%maskmap)) then + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + xextent=xextent, yextent=yextent, symmetry=symmetric_dom, name=dom_name, & + maskmap=MD_in%maskmap ) + else + call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, & + xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, & + symmetry=symmetric_dom, xextent=xextent, yextent=yextent, name=dom_name) + endif + + if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. & + (MD_in%layout(1)*MD_in%layout(2) > 1)) then + call mpp_define_io_domain(mpp_domain, MD_in%io_layout) + else + call mpp_define_io_domain(mpp_domain, (/ 1, 1 /) ) + endif + +end subroutine clone_MD_to_d2D + +!> Returns the index ranges that have been stored in a MOM_domain_type +subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & + isg, ieg, jsg, jeg, idg_offset, jdg_offset, & + symmetric, local_indexing, index_offset, coarsen) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, intent(out) :: isd !< The start i-index of the data domain + integer, intent(out) :: ied !< The end i-index of the data domain + integer, intent(out) :: jsd !< The start j-index of the data domain + integer, intent(out) :: jed !< The end j-index of the data domain + integer, optional, intent(out) :: isg !< The start i-index of the global domain + integer, optional, intent(out) :: ieg !< The end i-index of the global domain + integer, optional, intent(out) :: jsg !< The start j-index of the global domain + integer, optional, intent(out) :: jeg !< The end j-index of the global domain + integer, optional, intent(out) :: idg_offset !< The offset between the corresponding global and + !! data i-index spaces. + integer, optional, intent(out) :: jdg_offset !< The offset between the corresponding global and + !! data j-index spaces. + logical, optional, intent(out) :: symmetric !< True if symmetric memory is used. + logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, + !! as in most MOM6 code. The default is true. + 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. + + ! Local variables + integer :: isg_, ieg_, jsg_, jeg_ + integer :: ind_off, idg_off, jdg_off, coarsen_lev + logical :: local + + 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 + + if (coarsen_lev == 1) 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.") + endif + + if (local) then + ! This code institutes the MOM convention that local array indices start at 1. + idg_off = isd - 1 ; jdg_off = jsd - 1 + isc = isc - isd + 1 ; iec = iec - isd + 1 ; jsc = jsc - jsd + 1 ; jec = jec - jsd + 1 + ied = ied - isd + 1 ; jed = jed - jsd + 1 + isd = 1 ; jsd = 1 + else + idg_off = 0 ; jdg_off = 0 + endif + if (ind_off /= 0) then + idg_off = idg_off + ind_off ; jdg_off = jdg_off + ind_off + isc = isc + ind_off ; iec = iec + ind_off + jsc = jsc + ind_off ; jec = jec + ind_off + isd = isd + ind_off ; ied = ied + ind_off + jsd = jsd + ind_off ; jed = jed + ind_off + endif + if (present(isg)) isg = isg_ + if (present(ieg)) ieg = ieg_ + if (present(jsg)) jsg = jsg_ + if (present(jeg)) jeg = jeg_ + if (present(idg_offset)) idg_offset = idg_off + if (present(jdg_offset)) jdg_offset = jdg_off + if (present(symmetric)) symmetric = Domain%symmetric + +end subroutine get_domain_extent_MD + +!> Returns the index ranges that have been stored in a domain2D type +subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) + type(domain2d), intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, optional, intent(out) :: isd !< The start i-index of the data domain + integer, optional, intent(out) :: ied !< The end i-index of the data domain + integer, optional, intent(out) :: jsd !< The start j-index of the data domain + integer, optional, intent(out) :: jed !< The end j-index of the data domain + + ! Local variables + integer :: isd_, ied_, jsd_, jed_, jsg_, jeg_, isg_, ieg_ + + call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_) + + if (present(isd)) isd = isd_ + if (present(ied)) ied = ied_ + if (present(jsd)) jsd = jsd_ + if (present(jed)) jed = jed_ + +end subroutine get_domain_extent_d2D + +!> Return the (potentially symmetric) computational domain i-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The i-array size + integer, intent(out) :: is !< The computational domain starting i-index. + integer, intent(out) :: ie !< The computational domain ending i-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + isc = isc-isd+1 ; iec = iec-isd+1 ; ied = ied-isd+1 ; isd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == ied) then ; is = isc ; ie = iec + elseif (size == 1+iec-isc) then ; is = 1 ; ie = size + elseif (sym .and. (size == 1+ied)) then ; is = isc ; ie = iec+1 + elseif (sym .and. (size == 2+iec-isc)) then ; is = 1 ; ie = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_i_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') ied, 1+iec-isc + else + write(mesg2,'("Valid sizes are : ", 4i7)') ied, 1+iec-isc, 1+ied, 2+iec-isc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_i_ind + + +!> Return the (potentially symmetric) computational domain j-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_j_ind(domain, size, js, je, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The j-array size + integer, intent(out) :: js !< The computational domain starting j-index. + integer, intent(out) :: je !< The computational domain ending j-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + jsc = jsc-jsd+1 ; jec = jec-jsd+1 ; jed = jed-jsd+1 ; jsd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == jed) then ; js = jsc ; je = jec + elseif (size == 1+jec-jsc) then ; js = 1 ; je = size + elseif (sym .and. (size == 1+jed)) then ; js = jsc ; je = jec+1 + elseif (sym .and. (size == 2+jec-jsc)) then ; js = 1 ; je = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_j_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') jed, 1+jec-jsc + else + write(mesg2,'("Valid sizes are : ", 4i7)') jed, 1+jec-jsc, 1+jed, 2+jec-jsc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_j_ind + +!> Invert the contents of a 1-d array +subroutine invert(array) + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo +end subroutine invert + +!> Returns the global shape of h-point arrays +subroutine get_global_shape(domain, niglobal, njglobal) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(out) :: niglobal !< i-index global size of h-point arrays + integer, intent(out) :: njglobal !< j-index global size of h-point arrays + + niglobal = domain%niglobal + njglobal = domain%njglobal +end subroutine get_global_shape + +!> Get the array ranges in one dimension for the divisions of a global index space (alternative to compute_extent) +subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_block_extent + +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_extent + +!> Broadcast a 2-d domain from the root PE to the other PEs +subroutine broadcast_domain(domain) + type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs. + + call mpp_broadcast_domain(domain) +end subroutine broadcast_domain + +!> Broadcast an entire 2-d array from the root processor to all others. +subroutine global_field(domain, local, global) + type(domain2d), intent(inout) :: domain !< The domain2d type that describes the decomposition + real, dimension(:,:), intent(in) :: local !< The portion of the array on the local PE + real, dimension(:,:), intent(out) :: global !< The whole global array + + call mpp_global_field(domain, local, global) +end subroutine global_field + +!> same_domain returns true if two domains use the same list of PEs and layouts and have the same +!! size computational domains, and false if the domains do not conform with each other. +!! Different halo sizes or indexing conventions do not alter the results. +logical function same_domain(domain_a, domain_b) + type(domain2D), intent(in) :: domain_a !< The first domain in the comparison + type(domain2D), intent(in) :: domain_b !< The second domain in the comparison + + ! Local variables + integer :: isc_a, iec_a, jsc_a, jec_a, isc_b, iec_b, jsc_b, jec_b + integer :: layout_a(2), layout_b(2) + + ! This routine currently does a few checks for consistent domains; more could be added. + call mpp_get_layout(domain_a, layout_a) + call mpp_get_layout(domain_b, layout_b) + + call get_domain_extent(domain_a, isc_a, iec_a, jsc_a, jec_a) + call get_domain_extent(domain_b, isc_b, iec_b, jsc_b, jec_b) + + same_domain = (layout_a(1) == layout_b(1)) .and. (layout_a(2) == layout_b(2)) .and. & + (iec_a - isc_a == iec_b - isc_b) .and. (jec_a - jsc_a == jec_b - jsc_b) + +end function same_domain + +!> Returns arrays of the i- and j- sizes of the h-point computational domains for each +!! element of the grid layout. Any input values in the extent arrays are discarded, so +!! they are effectively intent out despite their declared intent of inout. +subroutine get_layout_extents(Domain, extent_i, extent_j) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, dimension(:), allocatable, intent(inout) :: extent_i !< The number of points in the + !! i-direction in each i-row of the layout + integer, dimension(:), allocatable, intent(inout) :: extent_j !< The number of points in the + !! j-direction in each j-row of the layout + + if (allocated(extent_i)) deallocate(extent_i) + if (allocated(extent_j)) deallocate(extent_j) + allocate(extent_i(domain%layout(1))) ; extent_i(:) = 0 + allocate(extent_j(domain%layout(2))) ; extent_j(:) = 0 + call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) +end subroutine get_layout_extents + +!> Set the associated domain for internal FMS I/O operations. +subroutine set_domain(Domain) + type(MOM_domain_type), intent(in) :: Domain + !< MOM domain to be designated as the internal FMS I/O domain + + ! FMS2 does not have domain-based internal FMS I/O operations, so this + ! function does nothing. +end subroutine set_domain + +subroutine nullify_domain + ! No internal FMS I/O domain can be assigned, so this function does nothing. +end subroutine nullify_domain + +end module MOM_domain_infra diff --git a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 new file mode 100644 index 0000000000..d08bd71333 --- /dev/null +++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 @@ -0,0 +1,104 @@ +!> A simple (very thin) wrapper for managing ensemble member layout information +module MOM_ensemble_manager_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init +use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup +use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id +use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size +use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist +use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist +use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix + +implicit none ; private + +public :: ensemble_manager_init, ensemble_pelist_setup +public :: get_ensemble_id, get_ensemble_size +public :: get_ensemble_pelist, get_ensemble_filter_pelist + +contains + +!> Initializes the ensemble manager which divides available resources +!! in order to concurrently execute an ensemble of model realizations. +subroutine ensemble_manager_init(ensemble_suffix) + character(len=*), optional, intent(in) :: ensemble_suffix !> Ensemble suffix provided by the cap. This may be + !! provided to bypass FMS ensemble manager. + + if (present(ensemble_suffix)) then + call fms2_io_set_filename_appendix(trim(ensemble_suffix)) + else + call FMS_ensemble_manager_init() + endif + +end subroutine ensemble_manager_init + +!> Create a list of processing elements (PEs) across components +!! associated with the current ensemble member. +subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, waves_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist, Wave_pelist) + logical, intent(in) :: concurrent !< A logical flag, if True, then ocean fast + !! PEs are run concurrently with + !! slow PEs within the coupler. + integer, intent(in) :: atmos_npes !< The number of atmospheric (fast) PEs + integer, intent(in) :: ocean_npes !< The number of ocean (slow) PEs + integer, intent(in) :: land_npes !< The number of land PEs (fast) + integer, intent(in) :: ice_npes !< The number of ice (fast) PEs + integer, intent(in) :: waves_npes !< The number of wave PEs + integer, dimension(:), intent(inout) :: Atm_pelist !< A list of Atm PEs + integer, dimension(:), intent(inout) :: Ocean_pelist !< A list of Ocean PEs + integer, dimension(:), intent(inout) :: Land_pelist !< A list of Land PEs + integer, dimension(:), intent(inout) :: Ice_pelist !< A list of Ice PEs + integer, dimension(:), intent(inout) :: Wave_pelist !< A list of Wave PEs + + + call FMS_ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, ice_npes, waves_npes, & + Atm_pelist, Ocean_pelist, Land_pelist, Ice_pelist, Wave_pelist) + +end subroutine ensemble_pelist_setup + +!> Returns the numeric id for the current ensemble member +function get_ensemble_id() + integer :: get_ensemble_id + + get_ensemble_id = FMS_get_ensemble_id() + +end function get_ensemble_id + +!> Returns ensemble information as follows, +!! index (1) :: ensemble size +!! index (2) :: Number of PEs per ensemble member +!! index (3) :: Number of ocean PEs per ensemble member +!! index (4) :: Number of atmos PEs per ensemble member +!! index (5) :: Number of land PEs per ensemble member +!! index (6) :: Number of ice PEs per ensemble member +function get_ensemble_size() + integer, dimension(7) :: get_ensemble_size + + get_ensemble_size = FMS_get_ensemble_size() + +end function get_ensemble_size + +!> Returns the list of PEs associated with all ensemble members +!! Results are stored in the argument array which must be large +!! enough to contain the list. If the optional name argument is present, +!! the returned processor list are for a particular component (atmos, ocean ,land, ice) +subroutine get_ensemble_pelist(pelist, name) + integer, intent(inout) :: pelist(:,:) !< A processor list for all ensemble members + character(len=*), optional, intent(in) :: name !< An optional component name (atmos, ocean, land, ice) + + call FMS_get_ensemble_pelist(pelist, name) + +end subroutine get_ensemble_pelist + +!> Returns the list of PEs associated with the named ensemble filter application. +!! Valid component names include ('atmos', 'ocean', 'land', and 'ice') +subroutine get_ensemble_filter_pelist(pelist, name) + integer, intent(inout) :: pelist(:) !< A processor list for the ensemble filter + character(len=*), intent(in) :: name !< The component name (atmos, ocean, land, ice) + + call FMS_get_Ensemble_filter_pelist(pelist, name) + +end subroutine get_ensemble_filter_pelist + +end module MOM_ensemble_manager_infra diff --git a/config_src/infra/FMS2/MOM_error_infra.F90 b/config_src/infra/FMS2/MOM_error_infra.F90 new file mode 100644 index 0000000000..e5a8b8dc68 --- /dev/null +++ b/config_src/infra/FMS2/MOM_error_infra.F90 @@ -0,0 +1,42 @@ +!> Routines for error handling and I/O management +module MOM_error_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout +use mpp_mod, only : NOTE, WARNING, FATAL + +implicit none ; private + +public :: MOM_err, is_root_pe, stdlog, stdout +!> Integer parameters encoding the severity of an error message +public :: NOTE, WARNING, FATAL + +contains + +!> MOM_err writes an error message, and may cause the run to stop depending on the +!! severity of the error. +subroutine MOM_err(severity, message) + integer, intent(in) :: severity !< The severity level of this error + character(len=*), intent(in) :: message !< A message to write out + + call mpp_error(severity, message) +end subroutine MOM_err + +!> stdout returns the standard Fortran unit number for output +integer function stdout() + stdout = mpp_stdout() +end function stdout + +!> stdlog returns the standard Fortran unit number to use to log messages +integer function stdlog() + stdlog = mpp_stdlog() +end function stdlog + +!> is_root_pe returns .true. if the current PE is the root PE. +logical function is_root_pe() + is_root_pe = .false. + if (mpp_pe() == mpp_root_pe()) is_root_pe = .true. +end function is_root_pe + +end module MOM_error_infra diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 new file mode 100644 index 0000000000..0b45b752ae --- /dev/null +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -0,0 +1,333 @@ +!> This module wraps the FMS temporal and spatial interpolation routines +module MOM_interp_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_io, only : axis_info +use MOM_io, only : get_var_axes_info +use MOM_time_manager, only : time_type +use MOM_error_handler, only : MOM_error, FATAL +use MOM_string_functions, only : lowercase +use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use netcdf_io_mod, only : FmsNetcdfFile_t, netcdf_file_open, netcdf_file_close +use netcdf_io_mod, only : get_num_variables, get_variable_names +use time_interp_external2_mod, only : time_interp_external +use time_interp_external2_mod, only : init_external_field, time_interp_external_init +use time_interp_external2_mod, only : get_external_field_size +use time_interp_external2_mod, only : get_external_field_missing + +implicit none ; private + +public :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init +public :: get_external_field_info +public :: run_horiz_interp, build_horiz_interp_weights +public :: external_field + +!< Handle of an external field for interpolation +type :: external_field + private + integer :: id + !< FMS ID for the interpolated field + character(len=:), allocatable :: filename + !< Filename containing the field values + character(len=:), allocatable :: label + !< Field name in the file +end type external_field + +!> Read a field based on model time, and rotate to the model domain. +interface time_interp_extern + module procedure time_interp_extern_0d + module procedure time_interp_extern_2d + module procedure time_interp_extern_3d +end interface time_interp_extern + +!> perform horizontal interpolation of field +interface run_horiz_interp + module procedure horiz_interp_from_weights_field2d + module procedure horiz_interp_from_weights_field3d +end interface + +!> build weights for horizontal interpolation of field +interface build_horiz_interp_weights + module procedure build_horiz_interp_weights_2d_to_2d +end interface build_horiz_interp_weights + +contains + +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + +!> perform horizontal interpolation of a 2d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: data_in !< input data + real, dimension(:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit, & + err_msg, new_missing_handle=.true. ) + +end subroutine horiz_interp_from_weights_field2d + +!> perform horizontal interpolation of a 3d field using pre-computed weights +!! source and destination coordinates are 2d +subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + + type(horiz_interp_type), intent(in) :: Interp !< type containing interpolation options and weights + real, dimension(:,:,:), intent(in) :: data_in !< input data + real, dimension(:,:,:), intent(out) :: data_out !< output data + integer, optional, intent(in) :: verbose !< verbosity level + real, dimension(:,:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:,:), optional, intent(out) :: mask_out !< mask for output data + real, optional, intent(in) :: missing_value !< A value indicating missing data + integer, optional, intent(in) :: missing_permit !< number of allowed points with + !! missing value for interpolation (0-3) + character(len=*), optional, intent(out) :: err_msg !< error message + + call horiz_interp(Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg) + +end subroutine horiz_interp_from_weights_field3d + + +!> build horizontal interpolation weights from source grid defined by 2d lon/lat to destination grid +!! defined by 2d lon/lat +subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + + type(horiz_interp_type), intent(inout) :: Interp !< type containing interpolation options and weights + real, dimension(:,:), intent(in) :: lon_in !< input longitude 2d + real, dimension(:,:), intent(in) :: lat_in !< input latitude 2d + real, dimension(:,:), intent(in) :: lon_out !< output longitude 2d + real, dimension(:,:), intent(in) :: lat_out !< output latitude 2d + integer, optional, intent(in) :: verbose !< verbosity level + character(len=*), optional, intent(in) :: interp_method !< interpolation method + integer, optional, intent(in) :: num_nbrs !< number of nearest neighbors + real, optional, intent(in) :: max_dist !< maximum region of influence + logical, optional, intent(in) :: src_modulo !< periodicity of E-W boundary + real, dimension(:,:), optional, intent(in) :: mask_in !< mask for input data + real, dimension(:,:), optional, intent(inout) :: mask_out !< mask for output data + logical, optional, intent(in) :: is_latlon_in !< input grid is regular lat/lon grid + logical, optional, intent(in) :: is_latlon_out !< output grid is regular lat/lon grid + + call horiz_interp_new(Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, & + is_latlon_in, is_latlon_out) + +end subroutine build_horiz_interp_weights_2d_to_2d + + +!> get size of an external field from field index +function get_extern_field_size(index) + + integer, intent(in) :: index !< field index + integer :: get_extern_field_size(4) !< field size + + get_extern_field_size = get_external_field_size(index) + +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 + + call get_var_axes_info(field%filename, field%label, axes) +end function get_extern_field_axes + + +!> get missing value of an external field from field index +function get_extern_field_missing(index) + + integer, intent(in) :: index !< field index + real :: get_extern_field_missing !< field missing value + + get_extern_field_missing = get_external_field_missing(index) + +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 + + if (present(size)) then + size(1:4) = get_extern_field_size(field%id) + endif + + if (present(axes)) then + axes(1:4) = get_extern_field_axes(field) + endif + + if (present(missing)) then + missing = get_extern_field_missing(field%id) + endif + +end subroutine get_external_field_info + + +!> Read a scalar field based on model time. +subroutine time_interp_extern_0d(field, time, data_in, verbose) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, intent(inout) :: data_in !< The interpolated value + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + + call time_interp_external(field%id, time, data_in, verbose=verbose) +end subroutine time_interp_extern_0d + + +!> Read a 2d field from an external based on model time, potentially including horizontal +!! interpolation and rotation of the data +subroutine time_interp_extern_2d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_2d + + +!> Read a 3d field based on model time, and rotate to the model grid +subroutine time_interp_extern_3d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field + type(time_type), intent(in) :: time !< The target time for the data + real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(horiz_interp_type), & + optional, intent(in) :: horz_interp !< A structure to control horizontal interpolation + logical, dimension(:,:,:), & + optional, intent(out) :: mask_out !< An array that is true where there is valid data + + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & + horz_interp=horz_interp, mask_out=mask_out) +end subroutine time_interp_extern_3d + + +!> initialize an external field +function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency) & + result(field) + + character(len=*), intent(in) :: file !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the field in the file + integer, optional, intent(in) :: threading !< A flag specifying whether the root PE reads + !! the data and broadcasts it (SINGLE_FILE) or all + !! processors read (MULTIPLE, the default). + logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(out) :: ierr !< Returns a non-zero error code in case of failure + logical, optional, intent(in) :: ignore_axis_atts !< If present and true, do not issue a + !! fatal error if the axis Cartesian attribute is + !! not set to a recognized value. + logical, optional, intent(in) :: correct_leap_year_inconsistency !< If present and true, + !! then if, (1) a calendar containing leap years + !! is in use, and (2) the modulo time period of the + !! data is an integer number of years, then map + !! a model date of Feb 29. onto a common year on Feb. 28. + type(external_field) :: field !< Handle to external field + + type(FmsNetcdfFile_t) :: extern_file + ! Local instance of netCDF file used to locate case-insensitive field name + integer :: num_fields + ! Number of fields in external file + character(len=256), allocatable :: extern_fieldnames(:) + ! List of field names in file + ! NOTE: length should NF90_MAX_NAME, but I don't know how to read it + character(len=:), allocatable :: label + ! Case-insensitive match to fieldname in file + logical :: rc + ! Return status + integer :: i + ! Loop index + + field%filename = file + + ! FMS2's init_external_field is case sensitive, so we must replicate the + ! case-insensitivity of FMS1. This requires opening the file twice. + + rc = netcdf_file_open(extern_file, file, 'read') + if (.not. rc) then + call MOM_error(FATAL, 'init_extern_file: file ' // trim(file) & + // ' could not be opened.') + endif + + ! TODO: broadcast = .false.? + num_fields = get_num_variables(extern_file) + + allocate(extern_fieldnames(num_fields)) + call get_variable_names(extern_file, extern_fieldnames) + + do i = 1, num_fields + if (lowercase(extern_fieldnames(i)) == lowercase(fieldname)) then + field%label = extern_fieldnames(i) + exit + endif + enddo + + call netcdf_file_close(extern_file) + + if (.not. allocated(field%label)) then + call MOM_error(FATAL, 'init_extern_field: field ' // trim(fieldname) & + // ' not found in ' // trim(file) // '.') + endif + + ! Pass to FMS2 implementation of init_external_field + + ! NOTE: external fields are currently assumed to be on-grid, which holds + ! across the current codebase. In the future, we may need to either enforce + ! this or somehow relax this requirement. + + if (present(MOM_Domain)) then + field%id = init_external_field(file, field%label, domain=MOM_domain%mpp_domain, & + verbose=verbose, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & + correct_leap_year_inconsistency=correct_leap_year_inconsistency, & + ongrid=.true.) + else + field%id = init_external_field(file, field%label, domain=domain, & + verbose=verbose, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & + correct_leap_year_inconsistency=correct_leap_year_inconsistency, & + ongrid=.true.) + endif +end function init_extern_field + +end module MOM_interp_infra diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 new file mode 100644 index 0000000000..a43b4e9344 --- /dev/null +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -0,0 +1,2039 @@ +!> This module contains a thin inteface to mpp and fms I/O code +module MOM_io_infra + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE +use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE +use MOM_string_functions, only : lowercase + +use fms2_io_mod, only : fms2_open_file => open_file, check_if_open, fms2_close_file => close_file +use fms2_io_mod, only : fms2_flush_file => flush_file +use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data +use fms2_io_mod, only : get_unlimited_dimension_name, get_num_dimensions, get_num_variables +use fms2_io_mod, only : get_variable_names, variable_exists, get_variable_size, get_variable_units +use fms2_io_mod, only : register_field, write_data, register_variable_attribute, register_global_attribute +use fms2_io_mod, only : variable_att_exists, get_variable_attribute, get_variable_num_dimensions +use fms2_io_mod, only : get_variable_dimension_names, is_dimension_registered, get_dimension_size +use fms2_io_mod, only : is_dimension_unlimited, register_axis, unlimited +use fms2_io_mod, only : get_dimension_names +use fms2_io_mod, only : get_global_io_domain_indices +use fms_io_utils_mod, only : fms2_file_exist => file_exists +use fms_io_utils_mod, only : get_filename_appendix + +use fms_mod, only : write_version_number, check_nml_error +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain +use mpp_mod, only : stdout_if_root=>stdout +use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes +use mpp_mod, only : mpp_get_current_pelist_name +use iso_fortran_env, only : int64 + +implicit none ; private + +! Duplication of FMS1 parameter values +! NOTE: Only kept to emulate FMS1 behavior, and may be removed in the future. +integer, parameter :: WRITEONLY_FILE = 100 +integer, parameter :: READONLY_FILE = 101 +integer, parameter :: APPEND_FILE = 102 +integer, parameter :: OVERWRITE_FILE = 103 +integer, parameter :: ASCII_FILE = 200 +integer, parameter :: NETCDF_FILE = 203 +integer, parameter :: SINGLE_FILE = 400 +integer, parameter :: MULTIPLE = 401 + +! These interfaces are actually implemented or have explicit interfaces in this file. +public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists +public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix +public :: read_field, read_vector, write_metadata, write_field +public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: 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, +! and may also wrap opaque types from the underlying infrastructure. +public :: file_type, fieldtype, axistype +! These are encoding constant parmeters. +public :: ASCII_FILE, NETCDF_FILE, SINGLE_FILE, MULTIPLE +public :: APPEND_FILE, READONLY_FILE, OVERWRITE_FILE, WRITEONLY_FILE +public :: CENTER, CORNER, NORTH_FACE, EAST_FACE + +!> Indicate whether a file exists, perhaps with domain decomposition +interface file_exists + module procedure FMS_file_exists + module procedure MOM_file_exists +end interface + +!> Read a data field from a file +interface read_field + module procedure read_field_4d + module procedure read_field_3d, read_field_3d_region + module procedure read_field_2d, read_field_2d_region + module procedure read_field_1d, read_field_1d_int + module procedure read_field_0d, read_field_0d_int +end interface + +!> Write a registered field to an output file +interface write_field + module procedure write_field_4d + module procedure write_field_3d + module procedure write_field_2d + module procedure write_field_1d + module procedure write_field_0d + module procedure MOM_write_axis +end interface write_field + +!> Read a pair of data fields representing the two components of a vector from a file +interface read_vector + module procedure read_vector_3d + module procedure read_vector_2d +end interface read_vector + +!> Write metadata about a variable or axis to a file and store it for later reuse +interface write_metadata + module procedure write_metadata_axis, write_metadata_field, write_metadata_global +end interface write_metadata + +!> Close a file (or fileset). If the file handle does not point to an open file, +!! close_file simply returns without doing anything. +interface close_file + module procedure close_file_type, close_file_unit +end interface close_file + +!> Type for holding a handle to an open file and related information +type :: file_type ; private + integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file + type(FmsNetcdfDomainFile_t), pointer :: fileobj => NULL() !< A domain-decomposed + !! file object that is open for writing + character(len=:), allocatable :: filename !< The path to this file, if it is open + logical :: open_to_read = .false. !< If true, this file or fileset can be read + logical :: open_to_write = .false. !< If true, this file or fileset can be written to + integer :: num_times !< The number of time levels in this file + real :: file_time !< The time of the latest entry in the file. +end type file_type + +!> This type is a container for information about a variable in a file. +type :: fieldtype ; private + character(len=256) :: name !< The name of this field in the files. + character(len=:), allocatable :: longname !< The long name for this field + character(len=:), allocatable :: units !< The units for this field + integer(kind=int64) :: chksum_read !< A checksum that has been read from a file + logical :: valid_chksum !< If true, this field has a valid checksum value. +end type fieldtype + +!> This type is a container for information about an axis in a file. +type :: axistype ; private + character(len=256) :: name !< The name of this axis in the files. + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. + logical :: domain_decomposed = .false. !< True if axis is domain-decomposed +end type axistype + +contains + +!> Reads the checksum value for a field that was recorded in a file, along with a flag indicating +!! whether the file contained a valid checksum for this field. +subroutine read_field_chksum(field, chksum, valid_chksum) + type(fieldtype), intent(in) :: field !< The field whose checksum attribute is to be read. + integer(kind=int64), intent(out) :: chksum !< The checksum for the field. + logical, intent(out) :: valid_chksum !< If true, chksum has been successfully read. + + chksum = -1 + valid_chksum = field%valid_chksum + if (valid_chksum) chksum = field%chksum_read + +end subroutine read_field_chksum + +!> Returns true if the named file or its domain-decomposed variant exists. +logical function MOM_file_exists(filename, MOM_Domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + + type(FmsNetcdfDomainFile_t) :: fileobj + + MOM_file_exists = fms2_open_file(fileobj, filename, "read", MOM_Domain%mpp_domain) + if (MOM_file_exists) call fms2_close_file(fileobj) +end function MOM_file_exists + +!> Returns true if the named file or its domain-decomposed variant exists. +logical function FMS_file_exists(filename) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + ! This function uses the fms_io function file_exist to determine whether + ! a named file (or its decomposed variant) exists. + + FMS_file_exists = fms2_file_exist(filename) +end function FMS_file_exists + +!> indicates whether an I/O handle is attached to an open file +logical function file_is_open(IO_handle) + type(file_type), intent(in) :: IO_handle !< Handle to a file to inquire about + + file_is_open = ((IO_handle%unit >= 0) .or. associated(IO_handle%fileobj)) +end function file_is_open + +!> closes a file (or fileset). If the file handle does not point to an open file, +!! close_file_type simply returns without doing anything. +subroutine close_file_type(IO_handle) + type(file_type), intent(inout) :: IO_handle !< The I/O handle for the file to be closed + + if (associated(IO_handle%fileobj)) then + call fms2_close_file(IO_handle%fileobj) + deallocate(IO_handle%fileobj) + endif + if (allocated(IO_handle%filename)) deallocate(IO_handle%filename) + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .false. + IO_handle%num_times = 0 ; IO_handle%file_time = 0.0 +end subroutine close_file_type + +! TODO: close_file_unit is only used for ASCII files, which are opened outside +! of the framework, so this could probably be removed, and those calls could +! just be replaced with close(unit). + +!> closes a file. If the unit does not point to an open file, +!! close_file_unit simply returns without doing anything. +subroutine close_file_unit(iounit) + integer, intent(inout) :: iounit !< The I/O unit for the file to be closed + + logical :: unit_is_open + + inquire(iounit, opened=unit_is_open) + if (unit_is_open) close(iounit) +end subroutine close_file_unit + +!> Ensure that the output stream associated with a file handle is fully sent to disk. +subroutine flush_file(IO_handle) + type(file_type), intent(in) :: IO_handle !< The I/O handle for the file to flush + + if (associated(IO_handle%fileobj)) then + call fms2_flush_file(IO_handle%fileobj) + endif +end subroutine flush_file + +!> Initialize the underlying I/O infrastructure +subroutine io_infra_init(maxunits) + integer, optional, intent(in) :: maxunits !< An optional maximum number of file + !! unit numbers that can be used. + + ! FMS2 requires no explicit initialization, so this is a null function. +end subroutine io_infra_init + +!> Gracefully close out and terminate the underlying I/O infrastructure +subroutine io_infra_end() + ! FMS2 requires no explicit finalization, so this is a null function. +end subroutine io_infra_end + +!> Open a single namelist file that is potentially readable by all PEs. +function MOM_namelist_file(filepath) result(iounit) + character(len=*), optional, intent(in) :: filepath + !< The file to open, by default "input.nml". + integer :: iounit + !< The opened unit number of the namelist file + + character(len=:), allocatable :: nmlpath + ! Namelist path + character(len=:), allocatable :: nmlpath_pe + ! Hypothetical namelist path exclusive to the current PE list + + if (present(filepath)) then + nmlpath = trim(filepath) + else + ! FMS1 first checks for a namelist unique to the PE list, `input_{}.nml`. + ! If not found, it defaults to `input.nml`. + nmlpath_pe = 'input_' // trim(mpp_get_current_pelist_name()) // '.nml' + if (file_exists(nmlpath_pe)) then + nmlpath = nmlpath_pe + else + nmlpath = 'input.nml' + endif + endif + call open_ASCII_file(iounit, nmlpath, action=READONLY_FILE) +end function MOM_namelist_file + +!> Checks the iostat argument that is returned after reading a namelist variable and writes a +!! message if there is an error. +subroutine check_namelist_error(IOstat, nml_name) + integer, intent(in) :: IOstat !< An I/O status field from a namelist read call + character(len=*), intent(in) :: nml_name !< The name of the namelist + integer :: ierr + ierr = check_nml_error(IOstat, nml_name) +end subroutine check_namelist_error + +!> Write a file version number to the log file or other output file +subroutine write_version(version, tag, unit) + character(len=*), intent(in) :: version !< A string that contains the routine name and version + character(len=*), optional, intent(in) :: tag !< A tag name to add to the message + integer, optional, intent(in) :: unit !< An alternate unit number for output + + call write_version_number(version, tag, unit) +end subroutine write_version + +!> open_file opens a file for parallel or single-file I/O. +subroutine open_file(IO_handle, filename, action, MOM_domain, threading, fileset) + type(file_type), intent(inout) :: IO_handle !< The handle for the opened file + character(len=*), intent(in) :: filename !< The path name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + !! The default is WRITE_ONLY. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj_read ! A handle to a domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + integer :: file_mode ! An integer that encodes whether the file is to be opened for + ! reading, writing or appending + character(len=40) :: mode ! A character string that encodes whether the file is to be opened for + ! reading, writing or appending + character(len=:), allocatable :: filename_tmp ! A copy of filename with .nc appended if necessary. + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + integer :: index_nc + + if (IO_handle%open_to_write) then + call MOM_error(WARNING, "open_file called for file "//trim(filename)//& + " with an IO_handle that is already open to to write.") + return + endif + if (IO_handle%open_to_read) then + call MOM_error(FATAL, "open_file called for file "//trim(filename)//& + " with an IO_handle that is already open to to read.") + endif + + file_mode = WRITEONLY_FILE ; if (present(action)) file_mode = action + + ! Domains are currently required to use FMS I/O. + ! NOTE: We restrict FMS2 IO usage to domain-based files due to issues with + ! string-based attributes in certain compilers. + ! But we may relax this requirement in the future. + if (.not. present(MOM_Domain)) & + call MOM_error(FATAL, 'open_file: FMS I/O requires a domain input.') + + if (.not.associated(IO_handle%fileobj)) allocate (IO_handle%fileobj) + + ! The FMS1 interface automatically appends .nc if necessary, but FMS2 interface does not. + index_nc = index(trim(filename), ".nc") + if (index_nc > 0) then + filename_tmp = trim(filename) + else + filename_tmp = trim(filename)//".nc" + if (is_root_PE()) call MOM_error(WARNING, "Open_file is appending .nc to the filename "//trim(filename)) + endif + + if (file_mode == WRITEONLY_FILE) then ; mode = "write" + elseif (file_mode == APPEND_FILE) then ; mode = "append" + elseif (file_mode == OVERWRITE_FILE) then ; mode = "overwrite" + elseif (file_mode == READONLY_FILE) then ; mode = "read" + else + call MOM_error(FATAL, "open_file called with unrecognized action.") + endif + + IO_handle%num_times = 0 + IO_handle%file_time = 0.0 + if ((file_mode == APPEND_FILE) .and. file_exists(filename_tmp, MOM_Domain)) then + ! Determine the latest file time and number of records so far. + success = fms2_open_file(fileObj_read, trim(filename_tmp), "read", MOM_domain%mpp_domain) + dim_unlim_name = find_unlimited_dimension_name(fileObj_read) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(fileObj_read, trim(dim_unlim_name), IO_handle%num_times) + if (IO_handle%num_times > 0) & + call fms2_read_data(fileObj_read, trim(dim_unlim_name), IO_handle%file_time, & + unlim_dim_level=IO_handle%num_times) + call fms2_close_file(fileObj_read) + endif + + success = fms2_open_file(IO_handle%fileobj, trim(filename_tmp), trim(mode), MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename_tmp)) + IO_handle%filename = trim(filename) + + if (file_mode == READONLY_FILE) then + IO_handle%open_to_read = .true. ; IO_handle%open_to_write = .false. + else + IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. + endif + +end subroutine open_file + +!> open_file opens an ascii file for parallel or single-file I/O using Fortran read and write calls. +subroutine open_ASCII_file(unit, file, action, threading, fileset) + integer, intent(out) :: unit !< The I/O unit for the opened file + character(len=*), intent(in) :: file !< The name of the file being opened + integer, optional, intent(in) :: action !< A flag indicating whether the file can be read + !! or written to and how to handle existing files. + integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) + !! or multiple PEs (MULTIPLE) participate in I/O. + !! With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due + !! to threading=MULTIPLE write to the same file (SINGLE_FILE) + !! or to one file per PE (MULTIPLE, the default). + + integer :: action_flag + integer :: threading_flag + integer :: fileset_flag + logical :: exists + logical :: is_open + character(len=6) :: action_arg, position_arg + character(len=:), allocatable :: filename + + ! NOTE: This function is written to emulate the original behavior of mpp_open + ! from the FMS1 library, on which the MOM API is still based. Much of this + ! can be removed if we choose to drop this compatibility, but for now we + ! try to retain as much as possible. + + ! NOTE: Default FMS1 I/O settings are summarized below. + ! + ! access: Fortran and mpp_open default to SEQUENTIAL. + ! form: The Fortran and mpp_open default (for MPP_ASCII) is FORMATTED. + ! recl: mpp_open uses Fortran defaults when unset, so can be ignored. + ! ios: FMS1 allowed this to be caught, but we do not support it. + ! action/position: In mpp_open, these are inferred from `action`. + ! + ! MOM flag FMS1 flag action position + ! -------- -------- ------ -------- + ! READONLY_FILE MPP_RDONLY READ REWIND + ! WRITEONLY_FILE MPP_WRONLY WRITE REWIND + ! OVERWRITE_FILE MPP_OVERWR WRITE REWIND + ! APPEND_FILE MPP_APPEND WRITE APPEND + ! + ! From this, we can omit `access`, `form`, and `recl`, and can construct + ! `action` and `position` from the input arguments. + + ! I/O configuration + + action_flag = WRITEONLY_FILE + if (present(action)) action_flag = action + + action_arg = 'write' + if (action_flag == READONLY_FILE) action_arg = 'read' + + position_arg = 'rewind' + if (action_flag == APPEND_FILE) position_arg = 'append' + + ! Threading configuration + + threading_flag = SINGLE_FILE + if (present(threading)) threading_flag = threading + + fileset_flag = MULTIPLE + if (present(fileset)) fileset_flag = fileset + + ! Force fileset to be consistent with threading (as in FMS1) + if (threading_flag == SINGLE_FILE) fileset_flag = SINGLE_FILE + + ! Construct the distributed filename, if needed + filename = file + if (fileset_flag == MULTIPLE) then + if (mpp_npes() > 10000) then + write(filename, '(a,".",i6.6)') trim(filename), mpp_pe() - mpp_root_pe() + else + write(filename, '(a,".",i4.4)') trim(filename), mpp_pe() - mpp_root_pe() + endif + endif + + inquire(file=filename, exist=exists) + if (exists .and. action_flag == WRITEONLY_FILE) & + call MOM_error(WARNING, 'open_ASCII_file: File ' // trim(filename) // & + ' opened WRITEONLY already exists!') + + open(newunit=unit, file=filename, action=trim(action_arg), & + position=trim(position_arg)) + + ! This checks if open() failed but did not raise a runtime error. + inquire(unit, opened=is_open) + if (.not. is_open) & + call MOM_error(FATAL, & + 'open_ASCII_file: File "' // trim(filename) // '" failed to open.') + + ! NOTE: There are two possible mpp_write_meta functions in FMS1: + ! - call mpp_write_meta( unit, 'filename', cval=mpp_file(unit)%name) + ! - call mpp_write_meta( unit, 'NumFilesInSet', ival=nfiles) + ! I'm not convinced we actually want these, but note them here in case. +end subroutine open_ASCII_file + + +!> Provide a string to append to filenames, to differentiate ensemble members, for example. +subroutine get_filename_suffix(suffix) + character(len=*), intent(out) :: suffix !< A string to append to filenames + + call get_filename_appendix(suffix) +end subroutine get_filename_suffix + + +!> Get information about the number of dimensions, variables and time levels +!! in the file associated with an open file unit +subroutine get_file_info(IO_handle, ndim, nvar, ntime) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim !< The number of dimensions in the file + integer, optional, intent(out) :: nvar !< The number of variables in the file + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + ! Local variables + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + integer :: ndims, nvars, natts, ntimes + + if (present(ndim)) ndim = get_num_dimensions(IO_handle%fileobj) + if (present(nvar)) nvar = get_num_variables(IO_handle%fileobj) + if (present(ntime)) then + ntime = 0 + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(IO_handle%fileobj, trim(dim_unlim_name), ntime) + endif +end subroutine get_file_info + + +!> Get the times of records from a file +subroutine get_file_times(IO_handle, time_values, ntime) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + real, allocatable, dimension(:), intent(inout) :: time_values !< The real times for the records in file. + integer, optional, intent(out) :: ntime !< The number of time levels in the file + + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + integer :: ntimes ! The number of time levels in the file + + !### Modify this routine to optionally convert to time_type, using information about the dimensions? + + if (allocated(time_values)) deallocate(time_values) + call get_file_info(IO_handle, ntime=ntimes) + if (present(ntime)) ntime = ntimes + if (ntimes > 0) then + allocate(time_values(ntimes)) + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) + if (len_trim(dim_unlim_name) > 0) & + call fms2_read_data(IO_handle%fileobj, trim(dim_unlim_name), time_values) + endif +end subroutine get_file_times + +!> Set up the field information (e.g., names and metadata) for all of the variables in a file. The +!! argument fields must be allocated with a size that matches the number of variables in a file. +subroutine get_file_fields(IO_handle, fields) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O + type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of + !! the variables in a file. + character(len=256), dimension(size(fields)) :: var_names ! The names of all variables + character(len=256) :: units ! The units of a variable as recorded in the file + character(len=2048) :: longname ! The long-name of a variable as recorded in the file + character(len=64) :: checksum_char ! The hexadecimal checksum read from the file + integer(kind=int64), dimension(3) :: checksum_file ! The checksums for a variable in the file + integer :: nvar ! The number of variables in the file + integer :: i + + nvar = size(fields) + ! Local variables + call get_variable_names(IO_handle%fileobj, var_names) + do i=1,nvar + fields(i)%name = trim(var_names(i)) + longname = "" + if (variable_att_exists(IO_handle%fileobj, var_names(i), "long_name")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "long_name", longname) + fields(i)%longname = trim(longname) + units = "" + if (variable_att_exists(IO_handle%fileobj, var_names(i), "units")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "units", units) + fields(i)%units = trim(units) + + fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") + if (fields(i)%valid_chksum) then + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_char) + ! If there are problems, there might need to be code added to handle commas. + read (checksum_char(1:16), '(Z16)') fields(i)%chksum_read + endif + enddo +end subroutine get_file_fields + +!> Extract information from a field type, as stored or as found in a file +subroutine get_field_atts(field, name, units, longname, checksum) + type(fieldtype), intent(in) :: field !< The field to extract information from + character(len=*), optional, intent(out) :: name !< The variable name + character(len=*), optional, intent(out) :: units !< The units of the variable + character(len=*), optional, intent(out) :: longname !< The long name of the variable + integer(kind=int64), dimension(:), & + optional, intent(out) :: checksum !< The checksums of the variable in a file + + if (present(name)) name = trim(field%name) + if (present(units)) units = trim(field%units) + if (present(longname)) longname = trim(field%longname) + if (present(checksum)) checksum = field%chksum_read + +end subroutine get_field_atts + +!> Field_exists returns true if the field indicated by field_name is present in the +!! file file_name. If file_name does not exist, it returns false. +function field_exists(filename, field_name, domain, no_domain, MOM_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + character(len=*), intent(in) :: field_name !< The name of the field being sought + type(domain2d), target, optional, intent(in) :: domain !< A domain2d type that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + logical :: field_exists !< True if filename exists and field_name is in filename + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileObj_dd ! A handle to a domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + type(FmsNetcdfFile_t) :: fileObj_simple ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + logical :: domainless ! If true, this file does not use a domain-decomposed file. + + domainless = .not.(present(MOM_domain) .or. present(domain)) + if (present(no_domain)) then + if (domainless .and. .not.no_domain) call MOM_error(FATAL, & + "field_exists: When no_domain is present and false, a domain must be supplied in query about "//& + trim(field_name)//" in file "//trim(filename)) + domainless = no_domain + endif + + field_exists = .false. + if (file_exists(filename)) then + if (domainless) then + success = fms2_open_file(fileObj_simple, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileObj_simple, field_name) + call fms2_close_file(fileObj_simple) + endif + else + if (present(MOM_domain)) then + success = fms2_open_file(fileObj_dd, trim(filename), "read", MOM_domain%mpp_domain) + else + success = fms2_open_file(fileObj_dd, trim(filename), "read", domain) + endif + if (success) then + field_exists = variable_exists(fileobj_dd, field_name) + call fms2_close_file(fileObj_dd) + endif + endif + endif +end function field_exists + +!> Given filename and fieldname, this subroutine returns the size of the field in the file +subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The name of the variable whose sizes are returned + integer, dimension(:), intent(inout) :: sizes !< The sizes of the variable in each dimension + logical, optional, intent(out) :: field_found !< This indicates whether the field was found in + !! the input file. Without this argument, there + !! is a fatal error if the field is not found. + logical, optional, intent(in) :: no_domain !< If present and true, do not check for file + !! names with an appended tile number + ! Local variables + type(FmsNetcdfFile_t) :: fileobj_read ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: success ! If true, the file was opened successfully + logical :: field_exists ! True if filename exists and field_name is in filename + integer :: i, ndims + character(len=512), allocatable :: dimnames(:) ! Field dimension names + logical, allocatable :: is_x(:), is_y(:), is_t(:) ! True if index matches axis type + integer :: size_indices(4) ! Mapping of size index to FMS1 convention + integer :: idx, swap + + field_exists = .false. + if (file_exists(filename)) then + success = fms2_open_file(fileObj_read, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileobj_read, fieldname) + if (field_exists) then + ndims = get_variable_num_dimensions(fileobj_read, fieldname) + if (ndims > size(sizes)) call MOM_error(FATAL, & + "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) + call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) + + do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo + + ! If sizes exceeds ndims, then we fallback to the FMS1 convention + ! where sizes has at least 4 dimension, and try to position values. + if (size(sizes) > ndims) then + ! Assume FMS1 positioning rules: (nx, ny, nz, nt, ...) + if (size(sizes) < 4) & + call MOM_error(FATAL, "If sizes(:) exceeds field dimensions, "& + &"then its length must be at least 4.") + + ! Fall back to the FMS1 default values of 1 (from mpp field%size) + sizes(ndims+1:) = 1 + + ! Gather the field dimension names + allocate(dimnames(ndims)) + dimnames(:) = "" + call get_variable_dimension_names(fileObj_read, trim(fieldname), & + dimnames) + + ! Test the dimensions against standard (x,y,t) names and attributes + allocate(is_x(ndims), is_y(ndims), is_t(ndims)) + is_x(:) = .false. + is_y(:) = .false. + is_t(:) = .false. + call categorize_axes(fileObj_read, filename, ndims, dimnames, & + is_x, is_y, is_t) + + ! Currently no z-test is supported, so disable assignment with 0 + size_indices = [ & + find_index(is_x), & + find_index(is_y), & + 0, & + find_index(is_t) & + ] + + do i = 1, size(size_indices) + idx = size_indices(i) + if (idx > 0) then + swap = sizes(i) + sizes(i) = sizes(idx) + sizes(idx) = swap + endif + enddo + + deallocate(is_x, is_y, is_t) + deallocate(dimnames) + endif + endif + endif + endif + if (present(field_found)) field_found = field_exists +end subroutine get_field_size + + +!> Return the index of the first True element of a logical array. +!! +!! If all elements are false, return zero. +function find_index(vec) result(loc) + ! NOTE: This function acts as a replacement for findloc() F2008 intrinsic, + ! which is not available on some compilers, or may not support logicals. + logical, intent(in) :: vec(:) + integer :: loc + + integer :: i + + loc = 0 + do i = 1, size(vec) + if (vec(i)) then + loc = i + exit + endif + enddo +end function find_index + + +!> 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 + + 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 + endif +end subroutine get_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, & + global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain)) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "read_field_0d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj_DD, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj_DD, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + else + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_0d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + data = scale*data + endif ; endif + +end subroutine read_field_0d + +!> This routine uses the fms_io subroutine read_data to read a 1-D data field named +!! "fieldname" from a single or domain-decomposed file "filename". +subroutine read_field_1d(filename, fieldname, data, timelevel, scale, MOM_Domain, & + global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain)) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "read_field_1d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj_DD, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj_DD, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + else + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_1d: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + data(:) = scale*data(:) + endif ; endif + +end subroutine read_field_1d + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 2-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine read_field_2d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened + + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_2d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine read_field_2d + +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 2-D data field named "fieldname" from file "filename". +subroutine read_field_2d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:), intent(inout) :: data !< The 2-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 2-d read, the 3rd + !! and 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain)) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "read_field_2d_region: ", & + filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj_DD, var_to_read, data, corner=start(1:2), edge_lengths=nread(1:2)) + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + else + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_2d_region: ", filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj, var_to_read, data, corner=start(1:2), edge_lengths=nread(1:2)) + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:) = scale*data(:,:) + endif + endif ; endif + +end subroutine read_field_2d_region + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 3-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file, file_may_be_4d) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + logical, optional, intent(in) :: file_may_be_4d !< If true, this file may have 4-d arrays, but + !! with the FMS2 I/O interfaces this does not matter. + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + logical :: success ! True if the file was successfully opened + + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_3d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine read_field_3d + +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 3-D data field named "fieldname" from file "filename". +subroutine read_field_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 3 + !! dimensions. For this 3-d read, the + !! 4th value is always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain)) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "read_field_2d_region: ", & + filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj_DD, var_to_read, data, corner=start(1:3), edge_lengths=nread(1:3)) + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + else + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_2d_region: ", filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj, var_to_read, data, corner=start(1:3), edge_lengths=nread(1:3)) + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:,:) = scale*data(:,:,:) + endif + endif ; endif + +end subroutine read_field_3d_region + +!> This routine uses the fms_io subroutine read_data to read a distributed +!! 4-D data field named "fieldname" from file "filename". Valid values for +!! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. +subroutine read_field_4d(filename, fieldname, data, MOM_Domain, & + timelevel, position, scale, global_file) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:,:), intent(inout) :: data !< The 4-dimensional array into which the data + !! should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + logical, optional, intent(in) :: global_file !< If true, read from a single global file + + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_4d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine read_field_4d + +!> This routine uses the fms_io subroutine read_data to read a scalar integer +!! data field named "fieldname" from file "filename". +subroutine read_field_0d_int(filename, fieldname, data, timelevel) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + integer, intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! If true, the file was opened successfully + + ! This routine might not be needed for MOM6. + + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_0d_int: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) +end subroutine read_field_0d_int + +!> This routine uses the fms_io subroutine read_data to read a 1-D integer +!! data field named "fieldname" from file "filename". +subroutine read_field_1d_int(filename, fieldname, data, timelevel) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + integer, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data + integer, optional, intent(in) :: timelevel !< The time level in the file to read + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file for obtaining information + ! about the exiting time axis entries in append mode. + logical :: has_time_dim ! True if the variable has an unlimited time axis. + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! If true, the file was opened successfully + + ! This routine might not be needed for MOM6. + + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_1d_int: ", filename, & + var_to_read, has_time_dim, timelevel) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) +end subroutine read_field_1d_int + + +!> This routine uses the fms_io subroutine read_data to read a pair of distributed +!! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:), intent(inout) :: u_data !< The 2 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:), intent(inout) :: v_data !< The 2 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variables have an unlimited time axis. + character(len=96) :: u_var, v_var ! Name of u and v variables to read from the netcdf file + logical :: success ! True if the file was successfully opened + integer :: u_pos, v_pos ! Flags indicating the positions of the u- and v- components. + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, "read_vector_2d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, "read_vector_2d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data. There would already been an error message for one + ! of the variables if they are inconsistent in having an unlimited dimension. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + +end subroutine read_vector_2d + +!> This routine uses the fms_io subroutine read_data to read a pair of distributed +!! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for +!! "stagger" include CGRID_NE, BGRID_NE, and AGRID. +subroutine read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & + timelevel, stagger, scalar_pair, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file + character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file + real, dimension(:,:,:), intent(inout) :: u_data !< The 3 dimensional array into which the + !! u-component of the data should be read + real, dimension(:,:,:), intent(inout) :: v_data !< The 3 dimensional array into which the + !! v-component of the data should be read + type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + integer, optional, intent(in) :: timelevel !< The time level in the file to read + integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read. + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + + ! Local variables + type(FmsNetcdfDomainFile_t) :: fileobj ! A handle to a domain-decomposed file object + logical :: has_time_dim ! True if the variables have an unlimited time axis. + character(len=96) :: u_var, v_var ! Name of u and v variables to read from the netcdf file + logical :: success ! True if the file was successfully opened + integer :: u_pos, v_pos ! Flags indicating the positions of the u- and v- components. + + u_pos = EAST_FACE ; v_pos = NORTH_FACE + if (present(stagger)) then + if (stagger == CGRID_NE) then ; u_pos = EAST_FACE ; v_pos = NORTH_FACE + elseif (stagger == BGRID_NE) then ; u_pos = CORNER ; v_pos = CORNER + elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif + endif + + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, "read_vector_3d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, "read_vector_3d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data, dangerously assuming either both or neither have time dimensions. + ! There would already been an error message for one of the variables if they are inconsistent. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, u_data, scale) + call rescale_comp_data(MOM_Domain, v_data, scale) + endif ; endif + +end subroutine read_vector_3d + + +!> Find the case-sensitive name of the variable in a netCDF file with a case-insensitive name match. +!! Optionally also determine whether this variable has an unlimited time dimension. +subroutine find_varname_in_file(fileobj, fieldname, err_header, filename, var_to_read, has_time_dim, timelevel) + type(FmsNetcdfFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open NetCDF file + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension + integer, optional, intent(in) :: timelevel !< A time level to read + + ! Local variables + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file + character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions + integer :: nvars ! The number of variables in the file + integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. + integer :: num_var_dims ! The number of dimensions a variable has in the file. + integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 + ! if it has no unlimited dimension. + integer :: i + + ! Open the file if necessary + if (.not.check_if_open(fileobj)) & + call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to find_varname_in_file.") + + ! Search for the variable in the file, looking for the case-sensitive name first. + if (variable_exists(fileobj, trim(fieldname))) then + var_to_read = trim(fieldname) + else ! Look for case-insensitive variable name matches. + nvars = get_num_variables(fileobj) + if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + allocate(var_names(nvars)) + call get_variable_names(fileobj, var_names) + + ! search for the variable in the file + variable_found = .false. + do i=1,nvars + if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + deallocate(var_names) + endif + + ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, + ! so some error checking and logic are required. + if (present(has_time_dim) .or. present(timelevel)) then + time_dim = -1 + + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) + + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + time_dim = i + if (present(timelevel)) then + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) + if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & + trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of the time dimension in "//trim(filename)) + endif + exit + endif + enddo + deallocate(dim_names) + + if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& + " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") + if (present(has_time_dim)) has_time_dim = (time_dim > 0) + endif + +end subroutine find_varname_in_file + + +!> Find the case-insensitive name match with a variable in an open domain-decomposed file-set, +!! prepare FMS2 to read this variable, and return some information needed to call fms2_read_data +!! correctly for this variable and file. +subroutine prepare_to_read_var(fileobj, fieldname, err_header, filename, var_to_read, & + has_time_dim, timelevel, position) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< An FMS2 handle to an open domain-decomposed file + character(len=*), intent(in) :: fieldname !< The variable name to seek in the file + character(len=*), intent(in) :: err_header !< A descriptive prefix for error messages + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(out) :: var_to_read !< The variable name to read from the file + logical, optional, intent(out) :: has_time_dim !< Indicates whether fieldname has a time dimension + integer, optional, intent(in) :: timelevel !< A time level to read + integer, optional, intent(in) :: position !< A flag indicating where this variable is discretized + + ! Local variables + logical :: variable_found ! Is a case-insensitive version of the variable found in the netCDF file? + character(len=256), allocatable, dimension(:) :: var_names ! The names of all the variables in the netCDF file + character(len=256), allocatable :: dim_names(:) ! The names of a variable's dimensions + integer :: nvars ! The number of variables in the file. + integer :: dim_unlim_size ! The current size of the unlimited (time) dimension in the file. + integer :: num_var_dims ! The number of dimensions a variable has in the file. + integer :: time_dim ! The position of the unlimited (time) dimension for a variable, or -1 + ! if it has no unlimited dimension. + integer :: i + + ! Open the file if necessary + if (.not.check_if_open(fileobj)) & + call MOM_error(FATAL, trim(err_header)//trim(filename)//" was not open in call to prepare_to_read_var.") + + ! Search for the variable in the file, looking for the case-sensitive name first. + if (variable_exists(fileobj, trim(fieldname))) then + var_to_read = trim(fieldname) + else ! Look for case-insensitive variable name matches. + nvars = get_num_variables(fileobj) + if (nvars < 1) call MOM_error(FATAL, "nvars is less than 1 for file "//trim(filename)) + allocate(var_names(nvars)) + call get_variable_names(fileobj, var_names) + + variable_found = .false. + do i=1,nvars + if (lowercase(trim(var_names(i))) == lowercase(trim(fieldname))) then + variable_found = .true. + var_to_read = trim(var_names(i)) + exit + endif + enddo + if (.not.(variable_found)) & + call MOM_error(FATAL, trim(err_header)//trim(fieldname)//" not found in "//trim(filename)) + deallocate(var_names) + endif + + ! FMS2 can not handle a timelevel argument if the variable does not have one in the file, + ! so some error checking and logic are required. + if (present(has_time_dim) .or. present(timelevel)) then + time_dim = -1 + + num_var_dims = get_variable_num_dimensions(fileobj, trim(var_to_read)) + allocate(dim_names(num_var_dims)) ; dim_names(:) = "" + call get_variable_dimension_names(fileobj, trim(var_to_read), dim_names) + + do i=1,num_var_dims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + time_dim = i + if (present(timelevel)) then + call get_dimension_size(fileobj, dim_names(i), dim_unlim_size) + if ((timelevel > dim_unlim_size) .and. is_root_PE()) call MOM_error(FATAL, & + trim(err_header)//"Attempting to read a time level of "//trim(var_to_read)//& + " that exceeds the size of the time dimension in "//trim(filename)) + endif + exit + endif + enddo + deallocate(dim_names) + + if (present(timelevel) .and. (time_dim < 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"time level specified, but the variable "//& + trim(var_to_read)//" does not have an unlimited dimension in "//trim(filename)) + if ((.not.present(timelevel)) .and. (time_dim > 0) .and. is_root_PE()) & + call MOM_error(WARNING, trim(err_header)//"The variable "//trim(var_to_read)//& + " has an unlimited dimension in "//trim(filename)//" but no time level is specified.") + if (present(has_time_dim)) has_time_dim = (time_dim > 0) + endif + + ! Registering the variable axes essentially just specifies the discrete position of this variable. + call MOM_register_variable_axes(fileobj, var_to_read, filename, position) + +end subroutine prepare_to_read_var + +!> register axes associated with a variable from a domain-decomposed netCDF file +subroutine MOM_register_variable_axes(fileObj, variableName, filename, position) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileObj !< Handle to an open FMS2 netCDF file object + character(len=*), intent(in) :: variableName !< name of the variable + character(len=*), intent(in) :: filename !< The name of the file to read + integer, optional, intent(in) :: position !< A flag indicating where this data is discretized + + ! Local variables + character(len=256), allocatable, dimension(:) :: dim_names ! variable dimension names + integer, allocatable, dimension(:) :: dimSizes ! variable dimension sizes + logical, allocatable, dimension(:) :: is_x ! Is this a (likely domain-decomposed) x-axis + logical, allocatable, dimension(:) :: is_y ! Is this a (likely domain-decomposed) y-axis + logical, allocatable, dimension(:) :: is_t ! Is this a time axis or another unlimited axis + integer :: ndims ! number of dimensions + integer :: xPos, yPos ! Discrete positions for x and y axes. Default is CENTER + integer :: i + + xPos = CENTER ; yPos = CENTER + if (present(position)) then + if ((position == CORNER) .or. (position == EAST_FACE)) xPos = EAST_FACE + if ((position == CORNER) .or. (position == NORTH_FACE)) yPos = NORTH_FACE + endif + + ! get variable dimension names and lengths + ndims = get_variable_num_dimensions(fileObj, trim(variableName)) + allocate(dimSizes(ndims)) + allocate(dim_names(ndims)) + allocate(is_x(ndims)) ; is_x(:) = .false. + allocate(is_y(ndims)) ; is_y(:) = .false. + allocate(is_t(ndims)) ; is_t(:) = .false. + call get_variable_size(fileObj, trim(variableName), dimSizes) + call get_variable_dimension_names(fileObj, trim(variableName), dim_names) + call categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) + + ! register the axes + do i=1,ndims + if ( .not.is_dimension_registered(fileobj, trim(dim_names(i))) ) then + if (is_x(i)) then + call register_axis(fileObj, trim(dim_names(i)), "x", domain_position=xPos) + elseif (is_y(i)) then + call register_axis(fileObj, trim(dim_names(i)), "y", domain_position=yPos) + else + call register_axis(fileObj, trim(dim_names(i)), dimSizes(i)) + endif + endif + enddo + + deallocate(dimSizes, dim_names, is_x, is_y, is_t) +end subroutine MOM_register_variable_axes + +!> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other +!! unlimited dimensions are also labeled as time axes for these purposes. +subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) + class(FmsNetcdfFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object + character(len=*), intent(in) :: filename !< The name of the file to read + integer, intent(in) :: ndims !< The number of dimensions associated with a variable + character(len=*), dimension(ndims), intent(in) :: dim_names !< Names of the dimensions associated with a variable + logical, dimension(ndims), intent(out) :: is_x !< Indicates if each dimension a (likely decomposed) x-axis + logical, dimension(ndims), intent(out) :: is_y !< Indicates if each dimension a (likely decomposed) y-axis + logical, dimension(ndims), intent(out) :: is_t !< Indicates if each dimension unlimited (usually time) axis + + ! Local variables + character(len=128) :: cartesian ! A flag indicating a Cartesian direction - usually a single character. + character(len=512) :: dim_list ! A concatenated list of dimension names. + character(len=128) :: units ! units corresponding to a specific variable dimension + logical :: x_found, y_found ! Indicate whether an x- or y- dimension have been found. + integer :: i + + x_found = .false. ; y_found = .false. + is_x(:) = .false. ; is_y(:) = .false. + do i=1,ndims + is_t(i) = is_dimension_unlimited(fileObj, trim(dim_names(i))) + ! First look for indicative variable attributes + if (.not.is_t(i)) then + if (variable_exists(fileobj, trim(dim_names(i)))) then + cartesian = "" + if (variable_att_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then + call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian(1:1)) + elseif (variable_att_exists(fileobj, trim(dim_names(i)), "axis")) then + call get_variable_attribute(fileobj, trim(dim_names(i)), "axis", cartesian(1:1)) + endif + cartesian = adjustl(cartesian) + if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. + if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. + if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. + endif + endif + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + enddo + + if (.not.(x_found .and. y_found)) then + ! Next look for hints from axis names for uncharacterized axes + do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then + call categorize_axis_from_name(dim_names(i), is_x(i), is_y(i)) + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + endif ; enddo + endif + + if (.not.(x_found .and. y_found)) then + ! Look for hints from CF-compliant axis units for uncharacterized axes + do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then + if (variable_exists(fileobj, trim(dim_names(i)))) then + call get_variable_units(fileobj, trim(dim_names(i)), units) + call categorize_axis_from_units(units, is_x(i), is_y(i)) + endif + if (is_x(i)) x_found = .true. + if (is_y(i)) y_found = .true. + endif ; enddo + endif + + if (.not.(x_found .and. y_found) .and. ((ndims>2) .or. ((ndims==2) .and. .not.is_t(ndims)))) then + ! This is a case where one would expect to find x-and y-dimensions, but none have been found. + if (is_root_pe()) then + dim_list = trim(dim_names(1))//", "//trim(dim_names(2)) + do i=3,ndims ; dim_list = trim(dim_list)//", "//trim(dim_names(i)) ; enddo + call MOM_error(WARNING, "categorize_axes: Failed to identify x- and y- axes in the axis list ("//& + trim(dim_list)//") of a variable being read from "//trim(filename)) + endif + endif + +end subroutine categorize_axes + +!> Determine whether an axis is associated with the x- or y-directions based on a comparison of +!! its units with CF-compliant variants of latitude or longitude units. +subroutine categorize_axis_from_units(unit_string, is_x, is_y) + character(len=*), intent(in) :: unit_string !< string of units + logical, intent(out) :: is_x !< Indicates if the axis units are associated with an x-direction axis + logical, intent(out) :: is_y !< Indicates if the axis units are associated with an y-direction axis + + is_x = .false. ; is_y = .false. + select case (lowercase(trim(unit_string))) + case ("degrees_north"); is_y = .true. + case ("degree_north") ; is_y = .true. + case ("degrees_n") ; is_y = .true. + case ("degree_n") ; is_y = .true. + case ("degreen") ; is_y = .true. + case ("degreesn") ; is_y = .true. + case ("degrees_east") ; is_x = .true. + case ("degree_east") ; is_x = .true. + case ("degreese") ; is_x = .true. + case ("degreee") ; is_x = .true. + case ("degree_e") ; is_x = .true. + case ("degrees_e") ; is_x = .true. + case default ; is_x = .false. ; is_y = .false. + end select + +end subroutine categorize_axis_from_units + +!> Tries to determine whether the axis name is commonly associated with an x- or y- axis. This +!! approach is fragile and unreliable, but it a backup to reading a CARTESIAN file attribute. +subroutine categorize_axis_from_name(dimname, is_x, is_y) + character(len=*), intent(in) :: dimname !< A dimension name + logical, intent(out) :: is_x !< Indicates if the axis name is associated with an x-direction axis + logical, intent(out) :: is_y !< Indicates if the axis name is associated with an y-direction axis + + is_x = .false. ; is_y = .false. + select case(trim(lowercase(dimname))) + case ("grid_x_t") ; is_x = .true. + case ("nx") ; is_x = .true. + case ("nxp") ; is_x = .true. + case ("longitude") ; is_x = .true. + case ("long") ; is_x = .true. + case ("lon") ; is_x = .true. + case ("lonh") ; is_x = .true. + case ("lonq") ; is_x = .true. + case ("xh") ; is_x = .true. + case ("xq") ; is_x = .true. + case ("i") ; is_x = .true. + + case ("grid_y_t") ; is_y = .true. + case ("ny") ; is_y = .true. + case ("nyp") ; is_y = .true. + case ("latitude") ; is_y = .true. + case ("lat") ; is_y = .true. + case ("lath") ; is_y = .true. + case ("latq") ; is_y = .true. + case ("yh") ; is_y = .true. + case ("yq") ; is_y = .true. + case ("j") ; is_y = .true. + + case default ; is_x = .false. ; is_y = .false. + end select + +end subroutine categorize_axis_from_name + + +!> Write a 4d field to an output file. +subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + + ! Local variables + integer :: time_index + + if (present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + else + call write_data(IO_handle%fileobj, trim(field_md%name), field) + endif +end subroutine write_field_4d + +!> Write a 3d field to an output file. +subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + ! Local variables + integer :: time_index + + if (present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + else + call write_data(IO_handle%fileobj, trim(field_md%name), field) + endif +end subroutine write_field_3d + +!> Write a 2d field to an output file. +subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, fill_value) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + + ! Local variables + integer :: time_index + + if (present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + else + call write_data(IO_handle%fileobj, trim(field_md%name), field) + endif +end subroutine write_field_2d + +!> Write a 1d field to an output file. +subroutine write_field_1d(IO_handle, field_md, field, tstamp) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + + ! Local variables + integer :: time_index + + if (present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + else + call write_data(IO_handle%fileobj, trim(field_md%name), field) + endif +end subroutine write_field_1d + +!> Write a 0d field to an output file. +subroutine write_field_0d(IO_handle, field_md, field, tstamp) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(in) :: field_md !< Field type with metadata + real, intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model time of this field + + ! Local variables + integer :: time_index + + if (present(tstamp)) then + time_index = write_time_if_later(IO_handle, tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) + else + call write_data(IO_handle%fileobj, trim(field_md%name), field) + endif +end subroutine write_field_0d + +!> Returns the integer time index for a write in this file, also writing the time variable to +!! the file if this time is later than what is already in the file. +integer function write_time_if_later(IO_handle, field_time) + type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing + real, intent(in) :: field_time !< Model time of this field + + ! Local variables + character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file + + if ((field_time > IO_handle%file_time) .or. (IO_handle%num_times == 0)) then + IO_handle%file_time = field_time + IO_handle%num_times = IO_handle%num_times + 1 + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) + if (len_trim(dim_unlim_name) > 0) & + call write_data(IO_handle%fileobj, trim(dim_unlim_name), [field_time], & + corner=[IO_handle%num_times], edge_lengths=[1]) + endif + + write_time_if_later = IO_handle%num_times +end function write_time_if_later + +!> Write the data for an axis +subroutine MOM_write_axis(IO_handle, axis) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(in) :: axis !< An axis type variable with information to write + + integer :: is, ie + + if (axis%domain_decomposed) then + ! FMS2 does not domain-decompose 1d arrays, so we explicitly slice it + call get_global_io_domain_indices(IO_handle%fileobj, trim(axis%name), is, ie) + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data(is:ie)) + else + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) + endif +end subroutine MOM_write_axis + +!> Store information about an axis in a previously defined axistype and write this +!! information to the file indicated by unit. +subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian, sense, domain, data, & + edge_axis, calendar) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(axistype), intent(inout) :: axis !< The axistype where this information is stored. + character(len=*), intent(in) :: name !< The name in the file of this axis + character(len=*), intent(in) :: units !< The units of this axis + character(len=*), intent(in) :: longname !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense !< This is 1 for axes whose values increase upward, or + !! -1 if they increase downward. + type(domain1D), optional, intent(in) :: domain !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar !< The name of the calendar used with a time axis + + character(len=:), allocatable :: cart ! A left-adjusted and trimmed copy of cartesian + logical :: is_x, is_y, is_t ! If true, this is a domain-decomposed axis in one of the directions. + integer :: position ! A flag indicating the axis staggering position. + integer :: i, isc, iec, global_size + + if (is_dimension_registered(IO_handle%fileobj, trim(name))) then + call MOM_error(FATAL, "write_metadata_axis was called more than once for axis "//trim(name)//& + " in file "//trim(IO_handle%filename)) + return + endif + + axis%name = trim(name) + if (present(data) .and. allocated(axis%ax_data)) call MOM_error(FATAL, & + "Data is already allocated in a call to write_metadata_axis for axis "//& + trim(name)//" in file "//trim(IO_handle%filename)) + + is_x = .false. ; is_y = .false. ; is_t = .false. + position = CENTER + if (present(cartesian)) then + cart = trim(adjustl(cartesian)) + if ((index(cart, "X") == 1) .or. (index(cart, "x") == 1)) is_x = .true. + if ((index(cart, "Y") == 1) .or. (index(cart, "y") == 1)) is_y = .true. + if ((index(cart, "T") == 1) .or. (index(cart, "t") == 1)) is_t = .true. + endif + + ! For now, we assume that all horizontal axes are domain-decomposed. + if (is_x .or. is_y) & + axis%domain_decomposed = .true. + + if (is_x) then + if (present(edge_axis)) then ; if (edge_axis) position = EAST_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'x', domain_position=position) + elseif (is_y) then + if (present(edge_axis)) then ; if (edge_axis) position = NORTH_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'y', domain_position=position) + elseif (is_t .and. .not.present(data)) then + ! This is the unlimited (time) dimension. + call register_axis(IO_handle%fileobj, trim(name), unlimited) + else + if (.not.present(data)) call MOM_error(FATAL,"MOM_io:register_diagnostic_axis: "//& + "An axis_length argument is required to register the axis "//trim(name)) + call register_axis(IO_handle%fileobj, trim(name), size(data)) + endif + + if (present(data)) then + ! With FMS2, the data for the axis labels has to match the computational domain on this PE. + if (present(domain)) then + ! The commented-out code on the next ~11 lines runs but there is missing data in the output file + ! call mpp_get_compute_domain(domain, isc, iec) + ! call mpp_get_global_domain(domain, size=global_size) + ! if (size(data) == global_size) then + ! allocate(axis%ax_data(iec+1-isc)) ; axis%ax_data(:) = data(isc:iec) + ! ! A simpler set of labels: do i=1,iec-isc ; axis%ax_data(i) = real(isc + i) - 1.0 ; enddo + ! elseif (size(data) == global_size+1) then + ! ! This is an edge axis. Note the effective SW indexing convention here. + ! allocate(axis%ax_data(iec+2-isc)) ; axis%ax_data(:) = data(isc:iec+1) + ! ! A simpler set of labels: do i=1,iec+1-isc ; axis%ax_data(i) = real(isc + i) - 1.5 ; enddo + ! else + ! call MOM_error(FATAL, "Unexpected size of data for "//trim(name)//" in write_metadata_axis.") + ! endif + + ! This works for a simple 1x1 IO layout, but gives errors for nontrivial IO layouts + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + + else ! Store the entire array of axis labels. + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) + endif + endif + + + ! Now create the variable that describes this axis. + call register_field(IO_handle%fileobj, trim(name), "double", dimensions=(/name/)) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (present(cartesian)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'cartesian_axis', & + trim(cartesian), len_trim(cartesian)) + if (present(sense)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'sense', sense) +end subroutine write_metadata_axis + +!> Store information about an output variable in a previously defined fieldtype and write this +!! information to the file indicated by unit. +subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & + pack, standard_name, checksum) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + type(fieldtype), intent(inout) :: field !< The fieldtype where this information is stored + type(axistype), dimension(:), intent(in) :: axes !< Handles for the axis used for this variable + character(len=*), intent(in) :: name !< The name in the file of this variable + character(len=*), intent(in) :: units !< The units of this variable + character(len=*), intent(in) :: longname !< The long description of this variable + integer, optional, intent(in) :: pack !< A precision reduction factor with which the + !! variable. The default, 1, has no reduction, + !! but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), & + optional, intent(in) :: checksum !< Checksum values that can be used to verify reads. + + ! Local variables + character(len=256), dimension(size(axes)) :: dim_names ! The names of the dimensions + character(len=16) :: prec_string ! A string specifying the precision with which to save this variable + character(len=64) :: checksum_string ! checksum character array created from checksum argument + integer :: i, ndims + + ndims = size(axes) + do i=1,ndims ; dim_names(i) = trim(axes(i)%name) ; enddo + prec_string = "double" ; if (present(pack)) then ; if (pack > 1) prec_string = "float" ; endif + call register_field(IO_handle%fileobj, trim(name), trim(prec_string), dimensions=dim_names) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (present(standard_name)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'standard_name', & + trim(standard_name), len_trim(standard_name)) + if (present(checksum)) then + write (checksum_string,'(Z16)') checksum(1) ! Z16 is the hexadecimal format code + call register_variable_attribute(IO_handle%fileobj, trim(name), "checksum", & + trim(checksum_string), len_trim(checksum_string)) + endif + + ! Store information in the field-type, regardless of which interfaces are used. + field%name = trim(name) + field%longname = trim(longname) + field%units = trim(units) + field%chksum_read = -1 + field%valid_chksum = .false. + +end subroutine write_metadata_field + +!> Write a global text attribute to a file. +subroutine write_metadata_global(IO_handle, name, attribute) + type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for writing + character(len=*), intent(in) :: name !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute !< The value of this attribute + + call register_global_attribute(IO_handle%fileobj, name, attribute, len_trim(attribute)) +end subroutine write_metadata_global + +!> Return unlimited dimension name in file, or empty string if none exists. +function find_unlimited_dimension_name(fileobj) result(label) + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj + !< File handle + character(len=:), allocatable :: label + !< Unlimited dimension name, or empty string if none exists + + integer :: ndims + !< Number of dimensions + character(len=256), allocatable :: dim_names(:) + !< File handle dimension names + integer :: i + !< Loop index + + ndims = get_num_dimensions(fileobj) + allocate(dim_names(ndims)) + call get_dimension_names(fileobj, dim_names) + + do i = 1, ndims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + label = trim(dim_names(i)) + exit + endif + enddo + deallocate(dim_names) + + if (.not. allocated(label)) & + label = '' +end function find_unlimited_dimension_name + +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 new file mode 100644 index 0000000000..5f3279b713 --- /dev/null +++ b/config_src/infra/FMS2/MOM_time_manager.F90 @@ -0,0 +1,54 @@ +!> Wraps the FMS time manager functions +module MOM_time_manager + +! This file is part of MOM6. See LICENSE.md for the license. + +use time_manager_mod, only : time_type, get_time, set_time +use time_manager_mod, only : time_type_to_real, real_to_time_type +use time_manager_mod, only : operator(+), operator(-), operator(*), operator(/) +use time_manager_mod, only : operator(>), operator(<), operator(>=), operator(<=) +use time_manager_mod, only : operator(==), operator(/=), operator(//) +use time_manager_mod, only : set_ticks_per_second , get_ticks_per_second +use time_manager_mod, only : get_date, set_date, increment_date +use time_manager_mod, only : days_in_month, month_name +use time_manager_mod, only : set_calendar_type, get_calendar_type +use time_manager_mod, only : JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN +use time_manager_mod, only : NO_CALENDAR + +implicit none ; private + +public :: time_type, get_time, set_time +public :: time_type_to_real, real_to_time_type, real_to_time +public :: set_ticks_per_second, get_ticks_per_second +public :: operator(+), operator(-), operator(*), operator(/) +public :: operator(>), operator(<), operator(>=), operator(<=) +public :: operator(==), operator(/=), operator(//) +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 + +contains + +!> Returns a time_type version of a real time in seconds, using an alternate implementation to the +!! FMS function real_to_time_type that is accurate over a larger range of input values. With 32 bit +!! 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) :: real_to_time !< The output time as a time_type + real, intent(in) :: x !< The input time in real seconds. + character(len=*), optional, intent(out) :: err_msg !< An optional returned error message. + + ! Local variables + integer :: seconds, days, ticks + real :: real_subsecond_remainder + + days = floor(x/86400.) + seconds = floor(x - 86400.*days) + real_subsecond_remainder = x - (days*86400. + seconds) + 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 + +end module MOM_time_manager diff --git a/config_src/mct_driver/MOM_ocean_model.F90 b/config_src/mct_driver/MOM_ocean_model.F90 deleted file mode 100644 index 8bb3346021..0000000000 --- a/config_src/mct_driver/MOM_ocean_model.F90 +++ /dev/null @@ -1,1070 +0,0 @@ -module MOM_ocean_model - -! This file is part of MOM6. See LICENSE.md for the license. - -!----------------------------------------------------------------------- -! -! This is the top level module for the MOM6 ocean model. It contains routines -! for initialization, termination and update of ocean model state. This -! particular version wraps all of the calls for MOM6 in the calls that had -! been used for MOM4. -! -! Robert Hallberg -! -! -! -! This code is a stop-gap wrapper of the MOM6 code to enable it to be called -! in the same way as MOM4. -! - -use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end -use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization -use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline -use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging -use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end -use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE -use MOM_domains, only : TO_ALL, Omit_Corners, fill_symmetric_edges -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -use MOM_forcing_type, only : allocate_forcing_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields -use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing -use MOM_forcing_type, only : set_derived_forcing_fields -use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags -use MOM_forcing_type, only : allocate_mech_forcing -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, file_exists, read_data, write_version_number -use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart -use MOM_string_functions, only : uppercase -use MOM_surface_forcing, only : surface_forcing_init -use MOM_surface_forcing, only : convert_IOB_to_fluxes -use MOM_surface_forcing, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum -use MOM_surface_forcing, only : ice_ocean_boundary_type, surface_forcing_CS -use MOM_surface_forcing, only : forcing_save_restart -use MOM_time_manager, only : time_type, get_time, set_time, operator(>) -use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) -use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real -use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init -use MOM_tracer_flow_control, only : call_tracer_flux_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type -use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data -use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain -use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only : MOM_wave_interface_init_lite, Update_Surface_Waves - -! MCT specfic routines -use ocn_cpl_indices, only : cpl_indices_type -use MOM_coms, only : reproducing_sum -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_spatial_means, only : adjust_area_mean_to_zero -use MOM_diag_mediator, only : safe_alloc_ptr -use MOM_domains, only : MOM_infra_end -use user_revise_forcing, only : user_alter_forcing -use data_override_mod, only : data_override - -! FMS modules -use time_interp_external_mod, only : time_interp_external - -#include - -#ifdef _USE_GENERIC_TRACER -use MOM_generic_tracer, only : MOM_generic_tracer_fluxes_accumulate -#endif - -implicit none ; public - -public ocean_model_init, ocean_model_end, update_ocean_model -public get_ocean_grid ! add by Jiande -public ocean_model_save_restart, Ocean_stock_pe -public ocean_model_init_sfc, ocean_model_flux_init -public ocean_model_restart -public ocean_public_type_chksum -public ocean_model_data_get -public ice_ocn_bnd_type_chksum - -interface ocean_model_data_get - module procedure ocean_model_data1D_get - module procedure ocean_model_data2D_get -end interface - -!> This type is used for communication with other components via the FMS coupler. -!! The element names and types can be changed only with great deliberation, hence -!! the persistnce of things like the cutsy element name "avg_kount". -type, public :: ocean_public_type - type(domain2d) :: Domain !< The domain for the surface fields. - logical :: is_ocean_pe !! .true. on processors that run the ocean model. - character(len=32) :: instance_name = '' !< A name that can be used to identify - !! this instance of an ocean model, for example - !! in ensembles when writing messages. - integer, pointer, dimension(:) :: pelist => NULL() !< The list of ocean PEs. - logical, pointer, dimension(:,:) :: maskmap =>NULL() !< A pointer to an array - !! indicating which logical processors are actually - !! used for the ocean code. The other logical - !! processors would be all land points and are not - !! assigned to actual processors. This need not be - !! assigned if all logical processors are used. - - integer :: stagger = -999 !< The staggering relative to the tracer points - !! points of the two velocity components. Valid entries - !! include AGRID, BGRID_NE, CGRID_NE, BGRID_SW, and CGRID_SW, - !! corresponding to the community-standard Arakawa notation. - !! (These are named integers taken from mpp_parameter_mod.) - !! Following MOM5, stagger is BGRID_NE by default when the - !! ocean is initialized, but here it is set to -999 so that - !! a global max across ocean and non-ocean processors can be - !! used to determine its value. - real, pointer, dimension(:,:) :: & - t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) - s_surf => NULL(), & !< SSS on t-cell (psu) - u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. - v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. - sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, - !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) - frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil - !! formation in the ocean. - melt_potential => NULL(), & !< Accumulated heat used to melt sea ice (in W/m^2) - area => NULL(), & !< cell area of the ocean surface, in m2. - OBLD => NULL() !< Ocean boundary layer depth, in m. - type(coupler_2d_bc_type) :: fields !< A structure that may contain an - !! array of named tracer-related fields. - integer :: avg_kount !< Used for accumulating averages of this type. - integer, dimension(2) :: axes = 0 !< Axis numbers that are available - ! for I/O using this surface data. -end type ocean_public_type - -!> Contains information about the ocean state, although it is not necessary that -!! this is implemented with all models. This type is NOT private, and can therefore CANNOT vary -!! between different ocean models. -type, public :: ocean_state_type - logical :: is_ocean_PE = .false. !< True if this is an ocean PE. - type(time_type) :: Time !< The ocean model's time and master clock. - integer :: Restart_control !< An integer that is bit-tested to determine whether - !! incremental restart files are saved and whether they - !! have a time stamped name. +1 (bit 0) for generic - !! files and +2 (bit 1) for time-stamped files. A - !! restart file is saved at the end of a run segment - !! unless Restart_control is negative. - integer :: nstep = 0 !< The number of calls to update_ocean. - logical :: use_ice_shelf !< If true, the ice shelf model is enabled. - logical :: icebergs_apply_rigid_boundary !< If true, the icebergs can change ocean bd condition. - real :: kv_iceberg !< The viscosity of the icebergs in m2/s (for ice rigidity) - real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy - !! so that fluxes below are set to zero. (0.5 is a - !! good value to use. Not applied for negative values. - real :: latent_heat_fusion !< Latent heat of fusion - real :: density_iceberg !< A typical density of icebergs in kg/m3 (for ice rigidity) - type(ice_shelf_CS), pointer :: Ice_shelf_CSp => NULL() !< ice shelf structure. - logical :: restore_salinity !< If true, the coupled MOM driver adds a term to - !! restore salinity to a specified value. - logical :: restore_temp !< If true, the coupled MOM driver adds a term to - !! restore sst to a specified value. - real :: press_to_z !< A conversion factor between pressure and ocean - !! depth in m, usually 1/(rho_0*g), in m Pa-1. - real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. - logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode - !! with the barotropic and baroclinic dynamics, thermodynamics, - !! etc. stepped forward integrated in time. - !! If true, all of the above are bypassed with all - !! fields necessary to integrate only the tracer advection - !! and diffusion equation read in from files stored from - !! a previous integration of the prognostic model. - type(directories) :: dirs !< A structure containing several relevant directory paths. - type(mech_forcing) :: forces!< A structure with the driving mechanical surface forces - type(forcing) :: fluxes !< A structure containing pointers to - !! the ocean forcing fields. - type(forcing) :: flux_tmp !< A secondary structure containing pointers to the - !! ocean forcing fields for when multiple coupled - !! timesteps are taken per thermodynamic step. - type(surface) :: sfc_state !< A structure containing pointers to - !! the ocean surface state fields. - type(ocean_grid_type), pointer :: grid => NULL() !< A pointer to a grid structure - !! containing metrics and related information. - type(verticalGrid_type), pointer :: GV => NULL() !< A pointer to a vertical grid - !! structure containing metrics and related information. - type(unit_scale_type), pointer :: US => NULL() !< A pointer to a structure containing - !! dimensional unit scaling factors. - type(MOM_control_struct), pointer :: MOM_CSp => NULL() - type(surface_forcing_CS), pointer :: forcing_CSp => NULL() - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. - type(diag_ctrl), pointer :: & - diag => NULL() !< A pointer to the diagnostic regulatory structure -end type ocean_state_type - -integer :: id_clock_forcing - -!======================================================================= -contains -!======================================================================= - -!======================================================================= -! -! -! -! Initialize the ocean model. -! - -!> Initializes the ocean model, including registering fields -!! for restarts and reading restart files if appropriate. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) - type(ocean_public_type), target, & - intent(inout) :: Ocean_sfc !< A structure containing various - !! publicly visible ocean surface properties after initialization, - !! the data in this type is intent(out). - type(ocean_state_type), pointer :: OS !< A structure whose internal - !! contents are private to ocean_model_mod that may be used to - !! contain all information about the ocean's interior state. - type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar - type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. - type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the - !! ocean and surface-ice fields that will participate - !! in the calculation of additional gas or other - !! tracer fluxes, and can be used to spawn related - !! internal variables in the ice model. - character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read - -! This subroutine initializes both the ocean state and the ocean surface type. -! Because of the way that indicies and domains are handled, Ocean_sfc must have -! been used in a previous call to initialize_ocean_type. - - real :: Rho0 !< The Boussinesq ocean density [kg m-3]. - real :: G_Earth !< The gravitational acceleration [m s-2]. - !! This include declares and sets the variable "version". - real :: HFrz !< If HFrz > 0 (m), melt potential will be computed. - !! The actual depth over which melt potential is computed will - !! min(HFrz, OBLD), where OBLD is the boundary layer depth. - !! If HFrz <= 0 (default), melt potential will not be computed. - logical :: use_melt_pot!< If true, allocate melt_potential array - -#include "version_variable.h" - character(len=40) :: mdl = "ocean_model_init" !< This module's name. - character(len=48) :: stagger - logical :: use_temperature - integer :: secs, days - type(param_file_type) :: param_file !< A structure to parse for run-time parameters - - call callTree_enter("ocean_model_init(), ocn_comp_mct.F90") - if (associated(OS)) then - call MOM_error(WARNING, "ocean_model_init called with an associated "// & - "ocean_state_type structure. Model is already initialized.") - return - endif - allocate(OS) - - OS%is_ocean_pe = Ocean_sfc%is_ocean_pe - if (.not.OS%is_ocean_pe) return - - OS%Time = Time_in - call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & - input_restart_file=input_restart_file, diag_ptr=OS%diag, & - count_calls=.true.) - call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%fluxes%C_p, & - use_temp=use_temperature) - OS%C_p = OS%fluxes%C_p - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "RESTART_CONTROL", OS%Restart_control, & - "An integer whose bits encode which restart files are "//& - "written. Add 2 (bit 1) for a time-stamped file, and odd "//& - "(bit 0) for a non-time-stamped file. A restart file "//& - "will be saved at the end of the run segment for any "//& - "non-negative value.", default=1) - call get_param(param_file, mdl, "OCEAN_SURFACE_STAGGER", stagger, & - "A case-insensitive character string to indicate the "//& - "staggering of the surface velocity field that is "//& - "returned to the coupler. Valid values include "//& - "'A', 'B', or 'C'.", default="C") - if (uppercase(stagger(1:1)) == 'A') then - Ocean_sfc%stagger = AGRID - elseif (uppercase(stagger(1:1)) == 'B') then - Ocean_sfc%stagger = BGRID_NE - elseif (uppercase(stagger(1:1)) == 'C') then - Ocean_sfc%stagger = CGRID_NE - else - call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & - trim(stagger)//" is invalid.") - end if - - call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & - "If true, the coupled driver will add a globally-balanced "//& - "fresh-water flux that drives sea-surface salinity "//& - "toward specified values.", default=.false.) - call get_param(param_file, mdl, "RESTORE_TEMPERATURE",OS%restore_temp, & - "If true, the coupled driver will add a "//& - "heat flux that drives sea-surface temperature "//& - "toward specified values.", default=.false.) - 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 "//& - "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, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) - - call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & - "If true, enables the ice shelf model.", default=.false.) - - call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_apply_rigid_boundary, & - "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) - - if (OS%icebergs_apply_rigid_boundary) then - call get_param(param_file, mdl, "KV_ICEBERG", OS%kv_iceberg, & - "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) - call get_param(param_file, mdl, "DENSITY_ICEBERGS", OS%density_iceberg, & - "A typical density of icebergs.", units="kg m-3", default=917.0) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", OS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) - call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", OS%berg_area_threshold, & - "Fraction of grid cell which iceberg must occupy, so that fluxes "//& - "below berg are set to zero. Not applied for negative "//& - " values.", units="non-dim", default=-1.0) - endif - - OS%press_to_z = 1.0/(Rho0*G_Earth) - - ! 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 get_param(param_file, mdl, "HFREEZE", HFrz, & - "If HFREEZE > 0, melt potential will be computed. The actual depth "//& - "over which melt potential is computed will be min(HFREEZE, OBLD), "//& - "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& - "melt potential will not be computed.", units="m", default=-1.0, do_not_log=.true.) - - if (HFrz .gt. 0.0) then - use_melt_pot=.true. - else - use_melt_pot=.false. - endif - - 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) - - call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & - OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) - - if (OS%use_ice_shelf) then - call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) - endif - if (OS%icebergs_apply_rigid_boundary) then - !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - if (.not. OS%use_ice_shelf) call allocate_forcing_type(OS%grid, OS%fluxes, ustar=.true., shelf=.true.) - endif - - if (associated(OS%grid%Domain%maskmap)) then - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, maskmap=OS%grid%Domain%maskmap, & - gas_fields_ocn=gas_fields_ocn) - else - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, gas_fields_ocn=gas_fields_ocn) - endif - - ! This call can only occur here if the coupler_bc_type variables have been - ! initialized already using the information from gas_fields_ocn. - if (present(gas_fields_ocn)) then - call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - endif - - call close_param_file(param_file) - call diag_mediator_close_registration(OS%diag) - - call callTree_leave("ocean_model_init(") - -end subroutine ocean_model_init -! NAME="ocean_model_init" - -!======================================================================= -! -! -! -! Update in time the ocean model fields. This code wraps the call to step_MOM -! with MOM4's call. -! -! - -!> Updates the ocean model fields. This code wraps the call to step_MOM with MOM6's call. -!! It uses the forcing to advance the ocean model's state from the -!! input value of Ocean_state (which must be for time time_start_update) for a time interval -!! of Ocean_coupling_time_step, returning the publicly visible ocean surface properties in -!! Ocean_sfc and storing the new ocean properties in Ocean_state. -subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & - time_start_update, Ocean_coupling_time_step) - - type(ice_ocean_boundary_type), & - intent(in) :: Ice_ocean_boundary !< A structure containing the - !! various forcing fields coming from the ice. - - type(ocean_state_type), & - pointer :: OS !< A pointer to a private structure containing - !! the internal ocean state. - - type(ocean_public_type), & - intent(inout) :: Ocean_sfc !< A structure containing all the - !! publicly visible ocean surface fields after - !! a coupling time step. The data in this type is - !! intent out. - - type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. - type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over - !! which to advance the ocean. - - ! local variables - type(time_type) :: Master_time !< This allows step_MOM to temporarily change - !! the time that is seen by internal modules. - type(time_type) :: Time1 !< The value of the ocean model's time at the - !! start of a call to step_MOM. - integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocn boundary type - real :: weight !< Flux accumulation weight - real :: time_step !< The time step of a call to step_MOM in seconds. - integer :: secs, days - integer :: is, ie, js, je - - call callTree_enter("update_ocean_model(), MOM_ocean_model.F90") - call get_time(Ocean_coupling_time_step, secs, days) - time_step = 86400.0*real(days) + real(secs) - - if (time_start_update /= OS%Time) then - call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& - "agree with time_start_update argument.") - endif - - if (.not.associated(OS)) then - call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & - "ocean_state_type structure. ocean_model_init must be "// & - "called first to allocate this structure.") - return - endif - - ! This is benign but not necessary if ocean_model_init_sfc was called or if - ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. - is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec - call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - - ! Translate Ice_ocean_boundary into fluxes. - call mpp_get_compute_domain(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), & - index_bnds(3), index_bnds(4)) - weight = 1.0 - - call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time, & - OS%grid, OS%US, OS%forcing_CSp) - - if (OS%fluxes%fluxes_used) then - - ! GMM, is enable_averaging needed now? - call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%diag) - - ! Import fluxes from coupler to ocean. Also, perform do SST and SSS restoring, if needed. - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, OS%Time, OS%grid, OS%US, OS%forcing_CSp, & - OS%sfc_state, OS%restore_salinity, OS%restore_temp) - - ! Fields that exist in both the forcing and mech_forcing types must be copied. - call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) - -#ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes -#endif - - ! Add ice shelf fluxes - if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, time_step, OS%Ice_shelf_CSp) - call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) - endif - - ! GMM, check ocean_model_MOM.F90 to enable the following option - !if (OS%icebergs_apply_rigid_boundary) then - ! This assumes that the iceshelf and ocean are on the same grid. I hope this is true. - ! call add_berg_flux_to_shelf(OS%grid, OS%forces,OS%fluxes,OS%use_ice_shelf,OS%density_iceberg, & - ! OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) - !endif - - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = time_step - - else - - OS%flux_tmp%C_p = OS%fluxes%C_p - - ! Import fluxes from coupler to ocean. Also, perform do SST and SSS restoring, if needed. - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, OS%Time, OS%grid, OS%US, OS%forcing_CSp, & - OS%sfc_state, OS%restore_salinity, OS%restore_temp) - - if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, time_step, OS%Ice_shelf_CSp) - call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) - endif - - ! GMM, check ocean_model_MOM.F90 to enable the following option - !if (OS%icebergs_apply_rigid_boundary) then - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - ! call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf,OS%density_iceberg, & - ! OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) - !endif - - ! Accumulate the forcing over time steps - call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, time_step, OS%grid, weight) - - ! Some of the fields that exist in both the forcing and mech_forcing types - ! are time-averages must be copied back to the forces type. - call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) -#ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average -#endif - endif - - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) - call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) - - if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) - endif - - call disable_averaging(OS%diag) - Master_time = OS%Time ; Time1 = OS%Time - - if(OS%offline_tracer_mode) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) - else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) - endif - - OS%Time = Master_time + Ocean_coupling_time_step - OS%nstep = OS%nstep + 1 - - call enable_averaging(time_step, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, time_step, OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) - - if (OS%fluxes%fluxes_used) then - call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) - call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) - endif - -! 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) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - - call callTree_leave("update_ocean_model()") - -end subroutine update_ocean_model -! NAME="update_ocean_model" - -!======================================================================= -! -! -! -! write out restart file. -! Arguments: -! timestamp (optional, intent(in)) : A character string that represents the model time, -! used for writing restart. timestamp will prepend to -! the any restart file name as a prefix. -! -! -subroutine ocean_model_restart(OS, timestamp) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state being saved to a restart file - character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be - !! prepended to the file name. (Currently this is unused.) - - if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & - call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& - "dynamics and advective times. Additional restart fields "//& - "that have not been coded yet would be required for reproducibility.") - if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_restart "//& - "was called with unused buoyancy fluxes. For conservation, the ocean "//& - "restart files can only be created after the buoyancy forcing is applied.") - - if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) - endif - endif - if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - endif - -end subroutine ocean_model_restart -! NAME="ocean_model_restart" - -!======================================================================= -! -! -! -! Close down the ocean model -! - -!> Terminates the model run, saving the ocean state in a -!! restart file and deallocating any data associated with the ocean. -subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) - type(ocean_public_type), intent(inout) :: Ocean_sfc !< An ocean_public_type structure that is to be - !! deallocated upon termination. - type(ocean_state_type), pointer :: Ocean_state!< pointer to the structure containing the internal - ! !! ocean state to be deallocated upon termination. - type(time_type), intent(in) :: Time !< The model time, used for writing restarts. - - 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) - -end subroutine ocean_model_end -! NAME="ocean_model_end" - -!======================================================================= - -!> ocean_model_save_restart causes restart files associated with the ocean to be -!! written out. -subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (in). - type(time_type), intent(in) :: Time !< The model time at this call, needed for mpp_write calls. - character(len=*), optional, intent(in) :: directory !< An optional directory into which to - !! write these restart files. - character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time-stamp) - !! to append to the restart file names. -! Arguments: Ocean_state - A structure containing the internal ocean state (in). -! (in) Time - The model time at this call. This is needed for mpp_write calls. -! (in, opt) directory - An optional directory into which to write these restart files. -! (in, opt) filename_suffix - An optional suffix (e.g., a time-stamp) to append -! to the restart file names. - -! Note: This is a new routine - it will need to exist for the new incremental -! checkpointing. It will also be called by ocean_model_end, giving the same -! restart behavior as now in FMS. - character(len=200) :: restart_dir - - if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & - call MOM_error(WARNING, "ocean_model_save_restart called with inconsistent "//& - "dynamics and advective times. Additional restart fields "//& - "that have not been coded yet would be required for reproducibility.") - if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_save_restart "//& - "was called with unused buoyancy fluxes. For conservation, the ocean "//& - "restart files can only be created after the buoyancy forcing is applied.") - - if (present(directory)) then - restart_dir = directory - else - restart_dir = OS%dirs%restart_output_dir - endif - - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) - - call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) - - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - -end subroutine ocean_model_save_restart - -!======================================================================= - -!> Initializes domain and state variables contained in the ocean public type. -subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & - gas_fields_ocn) - type(domain2D), intent(in) :: input_domain !< The FMS domain for the input structure - type(ocean_public_type), intent(inout) :: Ocean_sfc !< Ocean surface state - type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. - logical, intent(in), optional :: maskmap(:,:) !< A pointer to an array indicating which - !! logical processors are actually used for the ocean code. - type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the - !! ocean and surface-ice fields that will participate - !! in the calculation of additional gas or other - !! tracer fluxes. - ! local variables - integer :: xsz, ysz, layout(2) - integer :: isc, iec, jsc, jec - - call mpp_get_layout(input_domain,layout) - call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) - if(PRESENT(maskmap)) then - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) - else - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) - endif - call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) - - allocate (Ocean_sfc%t_surf (isc:iec,jsc:jec), & - Ocean_sfc%s_surf (isc:iec,jsc:jec), & - Ocean_sfc%u_surf (isc:iec,jsc:jec), & - Ocean_sfc%v_surf (isc:iec,jsc:jec), & - Ocean_sfc%sea_lev(isc:iec,jsc:jec), & - Ocean_sfc%area (isc:iec,jsc:jec), & - Ocean_sfc%OBLD (isc:iec,jsc:jec), & - Ocean_sfc%melt_potential(isc:iec,jsc:jec), & - Ocean_sfc%frazil (isc:iec,jsc:jec)) - - Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model - Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models - Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav - Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model - Ocean_sfc%melt_potential = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model - Ocean_sfc%OBLD = 0.0 ! ocean boundary layer depth, in m - Ocean_sfc%area = 0.0 - Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics - - if (present(gas_fields_ocn)) then - call coupler_type_spawn(gas_fields_ocn, Ocean_sfc%fields, (/isc,isc,iec,iec/), & - (/jsc,jsc,jec,jec/), suffix = '_ocn', as_needed=.true.) - endif - -end subroutine initialize_ocean_public_type - -!> Translates the coupler's ocean_data_type into MOM6's surface state variable. -!! This may eventually be folded into the MOM6's code that calculates the -!! surface state in the first place. -subroutine convert_state_to_ocean_type(state, Ocean_sfc, G, patm, press_to_z) - type(surface), intent(inout) :: state - type(ocean_public_type), target, intent(inout) :: Ocean_sfc !< Ocean surface state - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, optional, intent(in) :: patm(:,:) !< Atmospheric pressure. - real, optional, intent(in) :: press_to_z !< Factor to tranform atmospheric - !! pressure to z? - - ! local variables - real :: IgR0 - character(len=48) :: val_str - integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - integer :: i, j, i0, j0, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - call pass_vector(state%u,state%v,G%Domain) - - call mpp_get_compute_domain(Ocean_sfc%Domain, isc_bnd, iec_bnd, & - jsc_bnd, jec_bnd) - if (present(patm)) then - ! Check that the inidicies in patm are (isc_bnd:iec_bnd,jsc_bnd:jec_bnd). - if (.not.present(press_to_z)) call MOM_error(FATAL, & - 'convert_state_to_ocean_type: press_to_z must be present if patm is.') - endif - - i0 = is - isc_bnd ; j0 = js - jsc_bnd - if (state%T_is_conT) then - ! Convert the surface T from conservative T to potential T. - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(state%SSS(i+i0,j+j0), & - state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET - enddo ; enddo - else - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET - enddo ; enddo - endif - if (state%S_is_absS) then - ! Convert the surface S from absolute salinity to practical salinity. - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(state%SSS(i+i0,j+j0)) - enddo ; enddo - else - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = state%SSS(i+i0,j+j0) - enddo ; enddo - endif - - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) - if (present(patm)) & - Ocean_sfc%sea_lev(i,j) = Ocean_sfc%sea_lev(i,j) + patm(i,j) * press_to_z - if (associated(state%frazil)) & - Ocean_sfc%frazil(i,j) = state%frazil(i+i0,j+j0) - if (allocated(state%melt_potential)) & - Ocean_sfc%melt_potential(i,j) = state%melt_potential(i+i0,j+j0) - if (allocated(state%Hml)) & - Ocean_sfc%OBLD(i,j) = state%Hml(i+i0,j+j0) - enddo ; enddo - - if (Ocean_sfc%stagger == AGRID) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0,J-1+j0)) - enddo ; enddo - elseif (Ocean_sfc%stagger == BGRID_NE) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0+1,J+j0)) - enddo ; enddo - elseif (Ocean_sfc%stagger == CGRID_NE) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*state%v(i+i0,J+j0) - enddo ; enddo - else - write(val_str, '(I8)') Ocean_sfc%stagger - call MOM_error(FATAL, "convert_state_to_ocean_type: "//& - "Ocean_sfc%stagger has the unrecognized value of "//trim(val_str)) - endif - - if (coupler_type_initialized(state%tr_fields)) then - if (.not.coupler_type_initialized(Ocean_sfc%fields)) then - call MOM_error(FATAL, "convert_state_to_ocean_type: "//& - "Ocean_sfc%fields has not been initialized.") - endif - call coupler_type_copy_data(state%tr_fields, Ocean_sfc%fields) - endif - -end subroutine convert_state_to_ocean_type - -!> This subroutine extracts the surface properties from the ocean's internal -!! state and stores them in the ocean type returned to the calling ice model. -!! It has to be separate from the ocean_initialization call because the coupler -!! module allocates the space for some of these variables. -subroutine ocean_model_init_sfc(OS, Ocean_sfc) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (in). - type(ocean_public_type), intent(inout) :: Ocean_sfc !< Ocean surface state - - integer :: is, ie, js, je - - is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec - call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - - call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - -end subroutine ocean_model_init_sfc -! - -!======================================================================= - -!> ocean_model_flux_init is used to initialize properties of the air-sea fluxes -!! as determined by various run-time parameters. It can be called from -!! non-ocean PEs, or PEs that have not yet been initialzed, and it can safely -!! be called multiple times. -subroutine ocean_model_flux_init(OS, verbosity) - type(ocean_state_type), optional, pointer :: OS !< An optional pointer to the ocean state, - !! used to figure out if this is an ocean PE that - !! has already been initialized. - integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. - - logical :: OS_is_set - integer :: verbose - - OS_is_set = .false. ; if (present(OS)) OS_is_set = associated(OS) - - ! Use this to control the verbosity of output; consider rethinking this logic later. - verbose = 5 ; if (OS_is_set) verbose = 3 - if (present(verbosity)) verbose = verbosity - - call call_tracer_flux_init(verbosity=verbose) - -end subroutine ocean_model_flux_init - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! Ocean_stock_pe - returns stocks of heat, water, etc. for conservation checks.! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -!> Ocean_stock_pe - returns the integrated stocks of heat, water, etc. for conservation checks. -!! Because of the way FMS is coded, only the root PE has the integrated amount, -!! while all other PEs get 0. -subroutine Ocean_stock_pe(OS, index, value, time_index) - use stock_constants_mod, only : ISTOCK_WATER, ISTOCK_HEAT,ISTOCK_SALT - type(ocean_state_type), pointer :: OS !< A structure containing the internal ocean state. - !! The data in OS is intent(in). - integer, intent(in) :: index !< The stock index for the quantity of interest. - real, intent(out) :: value !< Sum returned for the conservation quantity of interest. - integer, optional, intent(in) :: time_index !< An unused optional argument, present only for - !! interfacial compatibility with other models. -! Arguments: OS - A structure containing the internal ocean state. -! (in) index - Index of conservation quantity of interest. -! (in) value - Sum returned for the conservation quantity of interest. -! (in,opt) time_index - Index for time level to use if this is necessary. - - real :: salt - - value = 0.0 - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - - select case (index) - case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in kg. - if (OS%GV%Boussinesq) then - call get_ocean_stocks(OS%MOM_CSp, mass=value, on_PE_only=.true.) - else ! In non-Boussinesq mode, the mass of salt needs to be subtracted. - call get_ocean_stocks(OS%MOM_CSp, mass=value, salt=salt, on_PE_only=.true.) - value = value - salt - endif - case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. - call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) - case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) - case default ; value = 0.0 - end select - ! If the FMS coupler is changed so that Ocean_stock_PE is only called on - ! ocean PEs, uncomment the following and eliminate the on_PE_only flags above. - ! if (.not.is_root_pe()) value = 0.0 - -end subroutine Ocean_stock_pe - -subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) - use MOM_constants, only : CELSIUS_KELVIN_OFFSET - type(ocean_state_type), pointer :: OS - type(ocean_public_type), intent(in) :: Ocean - character(len=*) , intent(in) :: name - real, dimension(isc:,jsc:), intent(out):: array2D - integer , intent(in) :: isc,jsc - - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) - - g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - - - select case(name) - case('area') - array2D(isc:,jsc:) = OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) -!OR same result -! do j=g_jsc,g_jec ; do i=g_isc,g_iec -! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case('tlat') - array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) - case('tlon') - array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) - case('ulat') - array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) - case('ulon') - array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) - case('vlat') - array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) - case('vlon') - array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) - case('geoLatBu') - array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) - case('geoLonBu') - array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) - case('cos_rot') - array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 - case('sin_rot') - array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 - case default - call MOM_error(FATAL,'ocean_model_data2D_get: unknown argument name='//name) - end select -end subroutine ocean_model_data2D_get - -subroutine ocean_model_data1D_get(OS,Ocean, name, value) - type(ocean_state_type), pointer :: OS - type(ocean_public_type), intent(in) :: Ocean - character(len=*) , intent(in) :: name - real , intent(out):: value - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - - select case(name) - case('c_p') - value = OS%C_p - case default - call MOM_error(FATAL,'ocean_model_data1D_get: unknown argument name='//name) - end select -end subroutine ocean_model_data1D_get - -subroutine ocean_public_type_chksum(id, timestep, ocn) - - character(len=*), intent(in) :: id - integer , intent(in) :: timestep - type(ocean_public_type), intent(in) :: ocn - integer :: n,m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - write(outunit,100) 'ocean%OBLD ',mpp_chksum(ocn%OBLD ) - write(outunit,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) - - call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') -100 FORMAT(" CHECKSUM::",A20," = ",Z20) -end subroutine ocean_public_type_chksum - -!======================================================================= -! -! -! -! Obtain the ocean grid. -! -! -subroutine get_ocean_grid(OS, Gridp) - type(ocean_state_type) :: OS - type(ocean_grid_type) , pointer :: Gridp - - Gridp => OS%grid - return - -end subroutine get_ocean_grid -! NAME="get_ocean_grid" - -end module MOM_ocean_model diff --git a/config_src/mct_driver/MOM_surface_forcing.F90 b/config_src/mct_driver/MOM_surface_forcing.F90 deleted file mode 100644 index 5d30f3c9cb..0000000000 --- a/config_src/mct_driver/MOM_surface_forcing.F90 +++ /dev/null @@ -1,1380 +0,0 @@ -module MOM_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coms, only : reproducing_sum -use MOM_constants, only : hlv, hlf -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT -use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_mediator, only : safe_alloc_ptr, time_type -use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM -use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All -use MOM_domains, only : To_North, To_East, Omit_Corners -use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags -use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type -use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, write_version_number, MOM_read_data -use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS -use MOM_restart, only : restart_init_end, save_restart, restore_state -use MOM_string_functions, only : uppercase -use MOM_spatial_means, only : adjust_area_mean_to_zero -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init -use user_revise_forcing, only : user_revise_forcing_CS - -use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn -use coupler_types_mod, only : coupler_type_copy_data -use data_override_mod, only : data_override_init, data_override -use fms_mod, only : stdout -use fms_mod, only : read_data -use mpp_mod, only : mpp_chksum -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init - -! MCT specfic routines -use ocn_cpl_indices, only : cpl_indices_type - -implicit none ; private - -#include - -public IOB_allocate -public convert_IOB_to_fluxes -public convert_IOB_to_forces -public surface_forcing_init -public ice_ocn_bnd_type_chksum -public forcing_save_restart -public apply_flux_adjustments - -!> Contains pointers to the forcing fields which may be used to drive MOM. -!! All fluxes are positive downward. -type, public :: surface_forcing_CS ; - integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integer values - !! from MOM_domains) to indicate the staggering of - !! the winds that are being provided in calls to - !! update_ocean_model. CIME uses AGRID, so this option - !! is being hard coded for now. - logical :: use_temperature !< If true, temp and saln used as state variables - real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). - ! smg: remove when have A=B code reconciled - logical :: bulkmixedlayer !< If true, model based on bulk mixed layer code - real :: Rho0 !< Boussinesq reference density [kg m-3] - real :: area_surf = -1.0 !< Total ocean surface area [m2] - real :: latent_heat_fusion !< Latent heat of fusion [J kg-1] - real :: latent_heat_vapor !< Latent heat of vaporization [J kg-1] - real :: max_p_surf !< maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice, - !! [Pa]. This is needed because the FMS coupling - !! structure does not limit the water that can be - !! frozen out of the ocean and the ice-ocean heat - !! fluxes are treated explicitly. - logical :: use_limited_P_SSH !< If true, return the sea surface height with - !! the correction for the atmospheric (and sea-ice) - !! pressure limited by max_p_surf instead of the - !! full atmospheric pressure. The default is true. - real :: gust_const !< constant unresolved background gustiness for ustar [Pa] - logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied - !! from an input file. - real, pointer, dimension(:,:) :: & - TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the - !! bottom boundary layer by drag on the tidal flows, - !! in W m-2. - gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar (Pa). - !! gust is used when read_gust_2d is true. - ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [m s-1] - real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) - real :: utide !< constant tidal velocity to use if read_tideamp - !! is false [m s-1]. - logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. - logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts - !! to damp surface deflections (especially surface - !! gravity waves). The default is false. - real :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !< viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< typical density of sea-ice [kg m-3]. The value is - !! only used to convert the ice pressure into - !! appropriate units for use with Kv_sea_ice. - real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which - !! sea-ice viscosity becomes effective, in kg m-2, - !! typically of order 1000 kg m-2. - logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments - real :: Flux_const !< piston velocity for surface restoring [m s-1] - logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux - logical :: adjust_net_srestore_to_zero !< adjust srestore to zero (for both salt_flux or vprec) - logical :: adjust_net_srestore_by_scaling !< adjust srestore w/o moving zero contour - logical :: adjust_net_fresh_water_to_zero !< adjust net surface fresh-water (w/ restoring) to zero - logical :: use_net_FW_adjustment_sign_bug ! use the wrong sign when adjusting net FW - logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour - logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil - !! criteria for salinity restoring. - real :: ice_salt_concentration !< salt concentration for sea ice (kg/kg) - logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas - real :: max_delta_srestore !< maximum delta salinity used for restoring - real :: max_delta_trestore !< maximum delta sst used for restoring - real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring - type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing - character(len=200) :: inputdir !< directory where NetCDF input files are - character(len=200) :: salt_restore_file !< filename for salt restoring data - character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file - logical :: mask_srestore ! if true, apply a 2-dimensional mask to the surface - ! salinity restoring fluxes. The masking file should be - ! in inputdir/salt_restore_mask.nc and the field should - ! be named 'mask' - real, pointer, dimension(:,:) :: srestore_mask => NULL() ! mask for SSS restoring - character(len=200) :: temp_restore_file !< filename for sst restoring data - character(len=30) :: temp_restore_var_name !< name of surface temperature in temp_restore_file - logical :: mask_trestore ! if true, apply a 2-dimensional mask to the surface - ! temperature restoring fluxes. The masking file should be - ! in inputdir/temp_restore_mask.nc and the field should - ! be named 'mask' - real, pointer, dimension(:,:) :: trestore_mask => NULL() ! mask for SST restoring - integer :: id_srestore = -1 !< id number for time_interp_external. - integer :: id_trestore = -1 !< id number for time_interp_external. - type(forcing_diags), public :: handles !< diagnostics handles - type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< restart pointer - type(user_revise_forcing_CS), pointer :: urf_CS => NULL()!< user revise pointer -end type surface_forcing_CS - -! ice_ocean_boundary_type is a structure corresponding to forcing, but with -! the elements, units, and conventions that exactly conform to the use for -! MOM-based coupled models. -type, public :: ice_ocean_boundary_type - real, pointer, dimension(:,:) :: latent_flux =>NULL() !< latent flux (W/m2) - real, pointer, dimension(:,:) :: rofl_flux =>NULL() !< liquid runoff (W/m2) - real, pointer, dimension(:,:) :: rofi_flux =>NULL() !< ice runoff (W/m2) - real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress (Pa) - real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress (Pa) - real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux (W/m2) - real, pointer, dimension(:,:) :: seaice_melt_heat =>NULL() !< sea ice and snow melt heat flux (W/m2) - real, pointer, dimension(:,:) :: seaice_melt =>NULL() !< water flux due to sea ice and snow melting (kg/m2/s) - real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux (kg/m2/s) - real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux (kg/m2/s) - real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() !< direct Near InfraRed sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation (W/m2) - real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip (kg/m2/s) - real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip (kg/m2/s) - real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff (kg/m2/s) - real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff (kg/m2/s) - real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m s-1] - real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs(m2/m2) - real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) - real, pointer, dimension(:,:) :: runoff_hflx =>NULL() !< heat content of liquid runoff (W/m2) - real, pointer, dimension(:,:) :: calving_hflx =>NULL() !< heat content of frozen runoff (W/m2) - real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere - !< on ocean surface (Pa) - real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice (kg/m2) - real, pointer, dimension(:,:) :: ice_rigidity =>NULL() !< rigidity of the sea ice, sea-ice and - !! ice-shelves, expressed as a coefficient - !! for divergence damping, as determined - !! outside of the ocean model in (m3/s) - integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT - type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of - !! named fields used for passive tracer fluxes. - integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of - !! wind stresses. This flag may be set by the - !! flux-exchange code, based on what the sea-ice - !! model is providing. Otherwise, the value from - !! the surface_forcing_CS is used. -end type ice_ocean_boundary_type - -integer :: id_clock_forcing - -!======================================================================= -contains -!======================================================================= - -!> This function has a few purposes: 1) it allocates and initializes the data -!! in the fluxes structure; 2) it imports surface fluxes using data from -!! the coupler; and 3) it can apply restoring in SST and SSS. -!! See \ref section_ocn_import for a summary of the surface fluxes that are -!! passed from MCT to MOM6, including fluxes that need to be included in -!! the future. -subroutine convert_IOB_to_fluxes(IOB, fluxes, Time, G, US, CS, & - sfc_state, restore_salt, restore_temp) - - type(ice_ocean_boundary_type), & - target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive - !! the ocean in a coupled model - - type(forcing), intent(inout) :: fluxes !< A structure containing pointers to - !! all possible mass, heat or salt flux forcing fields. - !! Unused fields have NULL ptrs. - type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the - !! salinity to the right time, when it is being restored. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a - !! previous call to surface_forcing_init. - type(surface), intent(in) :: sfc_state !< A structure containing fields that describe the - !! surface state of the ocean. - logical, optional, intent(in) :: restore_salt !< If true, salinity is restored to a target value. - logical, optional, intent(in) :: restore_temp !< If true, temperature is restored to a target value. - - ! local variables - real, dimension(SZI_(G),SZJ_(G)) :: & - data_restore, & ! The surface value toward which to restore (g/kg or degC) - SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value (deg C) - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value (g/kg) - SSS_mean, & ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation anomalies (g/kg) - PmE_adj, & ! The adjustment to PminusE that will cause the salinity - ! to be restored toward its target value (kg/(m^2 * s)) - net_FW, & ! The area integrated net freshwater flux into the ocean (kg/s) - net_FW2, & ! The area integrated net freshwater flux into the ocean (kg/s) - work_sum, & ! A 2-d array that is used as the work space for a global - ! sum, used with units of m2 or (kg/s) - open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria - - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer - - logical :: restore_salinity ! local copy of the argument restore_salt, if it - ! is present, or false (no restoring) otherwise. - logical :: restore_sst ! local copy of the argument restore_temp, if it - ! is present, or false (no restoring) otherwise. - real :: delta_sss ! temporary storage for sss diff from restoring value - real :: delta_sst ! temporary storage for sst diff from restoring value - - real :: C_p ! heat capacity of seawater ( J/(K kg) ) - real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. - - call cpu_clock_begin(id_clock_forcing) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 - - C_p = fluxes%C_p - open_ocn_mask(:,:) = 1.0 - pme_adj(:,:) = 0.0 - fluxes%vPrecGlobalAdj = 0.0 - fluxes%vPrecGlobalScl = 0.0 - fluxes%saltFluxGlobalAdj = 0.0 - fluxes%saltFluxGlobalScl = 0.0 - fluxes%netFWGlobalAdj = 0.0 - fluxes%netFWGlobalScl = 0.0 - - restore_salinity = .false. - if (present(restore_salt)) restore_salinity = restore_salt - restore_sst = .false. - if (present(restore_temp)) restore_sst = restore_temp - - ! allocation and initialization if this is the first time that this - ! flux type has been used. - if (fluxes%dt_buoy_accum < 0) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_nir_dif,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) - - if (CS%allow_flux_adjustments) then - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - endif - - do j=js-2,je+2 ; do i=is-2,ie+2 - fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) - fluxes%ustar_tidal(i,j) = US%m_to_Z*US%T_to_s*CS%ustar_tidal(i,j) - enddo; enddo - - if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - - fluxes%dt_buoy_accum = 0.0 - endif ! endif for allocation and initialization - - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 - endif - - if (CS%area_surf < 0.0) then - do j=js,je ; do i=is,ie - work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) - enddo; enddo - CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) - endif ! endif for allocation and initialization - - do j=js,je ; do i=is,ie - fluxes%salt_flux(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - enddo; enddo - - ! Salinity restoring logic - if (restore_salinity) then - call time_interp_external(CS%id_srestore,Time,data_restore) - ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) - open_ocn_mask(:,:) = 1.0 - if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice - do j=js,je ; do i=is,ie - if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo - endif - if (CS%salt_restore_as_sflux) then - do j=js,je ; do i=is,ie - delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & - (CS%basin_mask(i,j)*open_ocn_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 - enddo; enddo - if (CS%adjust_net_srestore_to_zero) then - if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) - fluxes%saltFluxGlobalAdj = 0. - else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj - endif - endif - fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic - else - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then - delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & - delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) - endif - enddo; enddo - if (CS%adjust_net_srestore_to_zero) then - if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) - fluxes%vPrecGlobalAdj = 0. - else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) - fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf - do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo - endif - endif - endif - endif - - ! SST restoring logic - if (restore_sst) then - call time_interp_external(CS%id_trestore,Time,data_restore) - do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- sfc_state%SST(i,j) - delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) - fluxes%heat_added(i,j) = G%mask2dT(i,j) * (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 - enddo; enddo - endif - - ! obtain fluxes from IOB - i0 = 0; j0 = 0 - do j=js,je ; do i=is,ie - ! liquid precipitation (rain) - if (associated(fluxes%lprec)) & - fluxes%lprec(i,j) = G%mask2dT(i,j) * IOB%lprec(i-i0,j-j0) - - ! frozen precipitation (snow) - if (associated(fluxes%fprec)) & - fluxes%fprec(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0) - - ! evaporation - if (associated(fluxes%evap)) & - fluxes%evap(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0) - - ! river runoff flux - if (associated(fluxes%lrunoff)) & - fluxes%lrunoff(i,j) = G%mask2dT(i,j) * IOB%rofl_flux(i-i0,j-j0) - - ! ice runoff flux - if (associated(fluxes%frunoff)) & - fluxes%frunoff(i,j) = G%mask2dT(i,j) * IOB%rofi_flux(i-i0,j-j0) - - ! GMM, we don't have an icebergs yet so the following is not needed - !if (((associated(IOB%ustar_berg) .and. (.not. associated(fluxes%ustar_berg))) & - ! .or. (associated(IOB%area_berg) .and. (.not. associated(fluxes%area_berg)))) & - ! .or. (associated(IOB%mass_berg) .and. (.not. associated(fluxes%mass_berg)))) & - ! call allocate_forcing_type(G, fluxes, iceberg=.true.) - !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) - !if (associated(IOB%area_berg)) & - ! fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) - !if (associated(IOB%mass_berg)) & - ! fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) - - ! GMM, cime does not not have an equivalent for heat_content_lrunoff and - ! heat_content_frunoff. I am seeting these to zero for now. - if (associated(fluxes%heat_content_lrunoff)) & - fluxes%heat_content_lrunoff(i,j) = 0.0 * G%mask2dT(i,j) - - if (associated(fluxes%heat_content_frunoff)) & - fluxes%heat_content_frunoff(i,j) = 0.0 * G%mask2dT(i,j) - - ! longwave radiation, sum up and down (W/m2) - if (associated(fluxes%LW)) & - fluxes%LW(i,j) = G%mask2dT(i,j) * IOB%lw_flux(i-i0,j-j0) - - ! sensible heat flux (W/m2) - if (associated(fluxes%sens)) & - fluxes%sens(i,j) = G%mask2dT(i,j) * IOB%t_flux(i-i0,j-j0) - - ! sea ice and snow melt heat flux (W/m2) - if (associated(fluxes%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) - - ! water flux due to sea ice and snow melt (kg/m2/s) - if (associated(fluxes%seaice_melt)) & - fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) - - ! latent heat flux (W/m^2) - ! old method, latent = IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor - !if (associated(fluxes%latent)) & - ! fluxes%latent(i,j) = G%mask2dT(i,j) * IOB%latent_flux(i-i0,j-j0) - ! new method - fluxes%latent(i,j) = 0.0 - ! contribution from frozen ppt - if (associated(fluxes%fprec)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion - endif - ! contribution from frozen runoff - if (associated(fluxes%frunoff)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%rofi_flux(i-i0,j-j0)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%rofi_flux(i-i0,j-j0)*CS%latent_heat_fusion - endif - ! contribution from evaporation - if (associated(IOB%q_flux)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor - endif - fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) - - if (associated(IOB%sw_flux_vis_dir)) & - fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dir(i-i0,j-j0) - if (associated(IOB%sw_flux_vis_dif)) & - fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dif(i-i0,j-j0) - if (associated(IOB%sw_flux_nir_dir)) & - fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dir(i-i0,j-j0) - if (associated(IOB%sw_flux_nir_dif)) & - fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dif(i-i0,j-j0) - - fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & - fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) - - ! salt flux - ! more salt restoring logic - if (associated(fluxes%salt_flux)) & - fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) - IOB%salt_flux(i-i0,j-j0)) - - if (associated(fluxes%salt_flux_in)) & - fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*(-IOB%salt_flux(i-i0,j-j0)) - - enddo; enddo - - ! adjust the NET fresh-water flux to zero, if flagged - if (CS%adjust_net_fresh_water_to_zero) then - sign_for_net_FW_bug = 1. - if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. - do j=js,je ; do i=is,ie - net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & - (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) - ! The following contribution appears to be calculating the volume flux of sea-ice - ! melt. This calculation is clearly WRONG if either sea-ice has variable - ! salinity or the sea-ice is completely fresh. - ! Bob thinks this is trying ensure the net fresh-water of the ocean + sea-ice system - ! is constant. - ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA - ! GMM: as stated above, the following is wrong. CIME deals with volume/mass and - ! heat from sea ice/snow via seaice_melt and seaice_melt_heat, respectively. - if (associated(fluxes%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & - net_FW(i,j) = net_FW(i,j) + G%areaT(i,j) * & - (fluxes%salt_flux(i,j) / CS%ice_salt_concentration) - - net_FW2(i,j) = net_FW(i,j)/G%areaT(i,j) - enddo; enddo - - if (CS%adjust_net_fresh_water_by_scaling) then - call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) - do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) - enddo; enddo - else - fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf - do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo - endif - endif - - if (CS%allow_flux_adjustments) then - ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, fluxes) - endif - - ! Allow for user-written code to alter fluxes after all the above - call user_alter_forcing(sfc_state, fluxes, Time, G, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) - -end subroutine convert_IOB_to_fluxes - -!======================================================================= - -!> This subroutine translates the Ice_ocean_boundary_type into a MOM -!! mechanical forcing type, including changes of units, sign conventions, -!! and putting the fields into arrays with MOM-standard halos. -subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) - type(ice_ocean_boundary_type), & - target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive - !! the ocean in a coupled model - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. - type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the - !! salinity to the right time, when it is being restored. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a - !! previous call to surface_forcing_init. - - real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & ! Zonal wind stresses at q points (Pa) - tauy_at_q ! Meridional wind stresses at q points (Pa) - - real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & ! Ice rigidity at tracer points (m3 s-1) - taux_at_h, & ! Zonal wind stresses at h points (Pa) - tauy_at_h ! Meridional wind stresses at h points (Pa) - - real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) - real :: Irho0 ! inverse of the mean density in (m^3/kg) - real :: taux2, tauy2 ! squared wind stresses (Pa^2) - real :: tau_mag ! magnitude of the wind stress (Pa) - real :: I_GEarth ! 1.0 / G_Earth [s2 m-1] - real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) - real :: mass_ice ! mass of sea ice at a face (kg/m^2) - real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) - - integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer - integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - - call cpu_clock_begin(id_clock_forcing) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 - - !isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) - !jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) - !if (is_root_pe()) write(*,*)'isc_bnd, jsc_bnd, iec_bnd, jec_bnd',isc_bnd, jsc_bnd, iec_bnd, jec_bnd - !i0 = is - isc_bnd ; j0 = js - jsc_bnd - i0 = 0; j0 = 0 ! TODO: is this right? - - Irho0 = 1.0/CS%Rho0 - - ! allocation and initialization if this is the first time that this - ! mechanical forcing type has been used. - if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) - call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) - call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) - if (CS%rigid_sea_ice) then - call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) - call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) - endif - - forces%initialized = .true. - endif - - if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 - if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 - - !applied surface pressure from atmosphere and cryosphere - !sea-level pressure (Pa) - do j=js,je ; do i=is,ie - if (associated(forces%p_surf_full) .and. associated(forces%p_surf)) then - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) - - if (CS%max_p_surf >= 0.0) then - forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) - else - forces%p_surf(i,j) = forces%p_surf_full(i,j) - endif - - endif - enddo; enddo - - if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf - else - forces%p_surf_SSH => forces%p_surf_full - endif - - ! GMM, CIME uses AGRID. All the BGRID_NE code can be cleaned later - wind_stagger = AGRID - - if (wind_stagger == BGRID_NE) then - ! This is necessary to fill in the halo points. - taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 - endif - if (wind_stagger == AGRID) then - ! This is necessary to fill in the halo points. - taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 - endif - - ! obtain fluxes from IOB; note the staggering of indices - do j=js,je ; do i=is,ie - if (wind_stagger == BGRID_NE) then - if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - elseif (wind_stagger == AGRID) then - if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - else ! C-grid wind stresses. - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - endif - - enddo ; enddo - - ! surface momentum stress related fields as function of staggering - if (wind_stagger == BGRID_NE) then - if (G%symmetric) & - call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & - G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & - (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) - enddo; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & - G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & - (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) - enddo; enddo - - ! ustar is required for the bulk mixed layer formulation. The background value - ! of 0.02 Pa is a relatively small value intended to give reasonable behavior - ! in regions of very weak winds. - - do j=js,je ; do i=is,ie - tau_mag = 0.0 ; gustiness = CS%gust_const - if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & - ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) - if (CS%read_gust_2d) gustiness = CS%gust(i,j) - endif - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(gustiness*Irho0 + Irho0*tau_mag) - enddo; enddo - - elseif (wind_stagger == AGRID) then - call pass_vector(taux_at_h, tauy_at_h, G%Domain,stagger=AGRID) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & - G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & - (G%mask2dT(i,j) + G%mask2dT(i+1,j)) - enddo; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & - G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & - (G%mask2dT(i,j) + G%mask2dT(i,j+1)) - enddo; enddo - - do j=js,je ; do i=is,ie - gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & - sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) - enddo; enddo - - else ! C-grid wind stresses. - if (G%symmetric) & - call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) - call pass_vector(forces%taux, forces%tauy, G%Domain) - - do j=js,je ; do i=is,ie - taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & - taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & - G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - - tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & - G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - - if (CS%read_gust_2d) then - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) - else - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) - endif - enddo; enddo - - endif ! endif for wind related fields - - ! sea ice related dynamic fields - if (CS%rigid_sea_ice) then - call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%G_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) - do I=is-1,ie ; do j=js,je - mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth - mass_eff = 0.0 - if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) - endif - forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff - enddo ; enddo - do i=is,ie ; do J=js-1,je - mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth - mass_eff = 0.0 - if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) - endif - forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff - enddo ; enddo - endif - - if (CS%allow_flux_adjustments) then - ! Apply adjustments to forces - call apply_force_adjustments(G, CS, Time, forces) - endif - -!### ! Allow for user-written code to alter fluxes after all the above -!### call user_alter_mech_forcing(forces, Time, G, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) -end subroutine convert_IOB_to_forces - -!======================================================================= - -!> Allocates ice-ocean boundary type containers and sets to 0. -subroutine IOB_allocate(IOB, isc, iec, jsc, jec) - type(ice_ocean_boundary_type), intent(inout) :: IOB !< An ice-ocean boundary type with fluxes to drive - integer, intent(in) :: isc, iec, jsc, jec !< The ocean's local grid size - - allocate ( IOB% latent_flux (isc:iec,jsc:jec), & - IOB% rofl_flux (isc:iec,jsc:jec), & - IOB% rofi_flux (isc:iec,jsc:jec), & - IOB% u_flux (isc:iec,jsc:jec), & - IOB% v_flux (isc:iec,jsc:jec), & - IOB% t_flux (isc:iec,jsc:jec), & - IOB% seaice_melt_heat (isc:iec,jsc:jec),& - IOB% seaice_melt (isc:iec,jsc:jec), & - IOB% q_flux (isc:iec,jsc:jec), & - IOB% salt_flux (isc:iec,jsc:jec), & - IOB% lw_flux (isc:iec,jsc:jec), & - IOB% sw_flux_vis_dir (isc:iec,jsc:jec), & - IOB% sw_flux_vis_dif (isc:iec,jsc:jec), & - IOB% sw_flux_nir_dir (isc:iec,jsc:jec), & - IOB% sw_flux_nir_dif (isc:iec,jsc:jec), & - IOB% lprec (isc:iec,jsc:jec), & - IOB% fprec (isc:iec,jsc:jec), & - IOB% ustar_berg (isc:iec,jsc:jec), & - IOB% area_berg (isc:iec,jsc:jec), & - IOB% mass_berg (isc:iec,jsc:jec), & - IOB% calving (isc:iec,jsc:jec), & - IOB% runoff_hflx (isc:iec,jsc:jec), & - IOB% calving_hflx (isc:iec,jsc:jec), & - IOB% mi (isc:iec,jsc:jec), & - IOB% p (isc:iec,jsc:jec)) - - IOB%latent_flux = 0.0 - IOB%rofl_flux = 0.0 - IOB%rofi_flux = 0.0 - IOB%u_flux = 0.0 - IOB%v_flux = 0.0 - IOB%t_flux = 0.0 - IOB%seaice_melt_heat = 0.0 - IOB%seaice_melt = 0.0 - IOB%q_flux = 0.0 - IOB%salt_flux = 0.0 - IOB%lw_flux = 0.0 - IOB%sw_flux_vis_dir = 0.0 - IOB%sw_flux_vis_dif = 0.0 - IOB%sw_flux_nir_dir = 0.0 - IOB%sw_flux_nir_dif = 0.0 - IOB%lprec = 0.0 - IOB%fprec = 0.0 - IOB%ustar_berg = 0.0 - IOB%area_berg = 0.0 - IOB%mass_berg = 0.0 - IOB%calving = 0.0 - IOB%runoff_hflx = 0.0 - IOB%calving_hflx = 0.0 - IOB%mi = 0.0 - IOB%p = 0.0 - -end subroutine IOB_allocate - -!======================================================================= - -!> Adds flux adjustments obtained via data_override -!! Component name is 'OCN' -!! Available adjustments are: -!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) -!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_flux_adjustments(G, CS, Time, fluxes) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure - type(time_type), intent(in) :: Time !< Model time structure - type(forcing), optional, intent(inout) :: fluxes !< Surface fluxes structure - - ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Fluxes at h points (W m-2 or kg m-2 s-1) - - integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau - logical :: overrode_x, overrode_y, overrode_h - - 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) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%heat_added, G%Domain) - - overrode_h = .false. - call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%salt_flux_added, G%Domain) - overrode_h = .false. - - call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%vprec, G%Domain) - -end subroutine apply_flux_adjustments - -!======================================================================= - -!> Adds mechanical forcing adjustments obtained via data_override -!! Component name is 'OCN' -!! Available adjustments are: -!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) -!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_force_adjustments(G, CS, Time, forces) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure - type(time_type), intent(in) :: Time !< Model time structure - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - - ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) - - integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau - logical :: overrode_x, overrode_y - - isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec - - tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 - ! Either reads data or leaves contents unchanged - overrode_x = .false. ; overrode_y = .false. - call data_override('OCN', 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x) - call data_override('OCN', 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y) - - if (overrode_x .or. overrode_y) then - if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& - "Both taux_adj and tauy_adj must be specified, or neither, in data_table") - - ! Rotate winds - call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID, halo=1) - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 - dLonDx = G%geoLonCu(I,j) - G%geoLonCu(I-1,j) - dLonDy = G%geoLonCv(i,J) - G%geoLonCv(i,J-1) - rDlon = sqrt( dLonDx * dLonDx + dLonDy * dLonDy ) - if (rDlon > 0.) rDlon = 1. / rDlon - cosA = dLonDx * rDlon - sinA = dLonDy * rDlon - zonal_tau = tempx_at_h(i,j) - merid_tau = tempy_at_h(i,j) - tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau - tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau - enddo ; enddo - - ! Average to C-grid locations - do j=jsc,jec ; do I=isc-1,iec - forces%taux(I,j) = forces%taux(I,j) + 0.5 * ( tempx_at_h(i,j) + tempx_at_h(i+1,j) ) - enddo ; enddo - - do J=jsc-1,jec ; do i=isc,iec - forces%tauy(i,J) = forces%tauy(i,J) + 0.5 * ( tempy_at_h(i,j) + tempy_at_h(i,j+1) ) - enddo ; enddo - endif ! overrode_x .or. overrode_y - -end subroutine apply_force_adjustments - -!======================================================================= - -!> Saves restart fields associated with the forcing -subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & - filename_suffix) - type(surface_forcing_CS), pointer :: CS !< pointer to the control structure - !! returned by a previous call to - !! surface_forcing_init - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time !< model time at this call - character(len=*), intent(in) :: directory !< optional directory into which - !! to write these restart files - logical, optional, intent(in) :: time_stamped !< If true, the restart file - !! names include a unique time - !! stamp - character(len=*), optional, intent(in) :: filename_suffix !< optional suffix - !! (e.g., a time-stamp) to append to the - !! restart file names - if (.not.associated(CS)) return - if (.not.associated(CS%restart_CSp)) return - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) - -end subroutine forcing_save_restart - -!======================================================================= - -!> Initializes surface forcing: get relevant parameters and allocate arrays. -subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, restore_temp) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output - type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the - !! control structure for this module - logical, optional, intent(in) :: restore_salt, restore_temp !< If present and true, - !! temp/salt restoring will be applied - - ! local variables - real :: utide !< The RMS tidal velocity [m s-1]. - type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags - type(time_type) :: Time_frc - character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "ocn_comp_mct" ! This module's name. - character(len=48) :: stagger - character(len=240) :: basin_file - integer :: i, j, isd, ied, jsd, jed - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if (associated(CS)) then - call MOM_error(WARNING, "surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - id_clock_forcing=cpu_clock_id('Ocean surface forcing', grain=CLOCK_SUBCOMPONENT) - call cpu_clock_begin(id_clock_forcing) - - CS%diag => diag - - call write_version_number (version) - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & - "The directory in which all input files are found.", & - default=".") - CS%inputdir = slasher(CS%inputdir) - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) - call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & - "The latent heat of fusion.", units="J/kg", default=hlv) - call get_param(param_file, mdl, "MAX_P_SURF", CS%max_p_surf, & - "The maximum surface pressure that can be exerted by the "//& - "atmosphere and floating sea-ice or ice shelves. This is "//& - "needed because the FMS coupling structure does not "//& - "limit the water that can be frozen out of the ocean and "//& - "the ice-ocean heat fluxes are treated explicitly. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) - call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & - CS%adjust_net_srestore_to_zero, & - "If true, adjusts the salinity restoring seen to zero "//& - "whether restoring is via a salt flux or virtual precip.",& - default=restore_salt) - call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_BY_SCALING", & - CS%adjust_net_srestore_by_scaling, & - "If true, adjustments to salt restoring to achieve zero net are "//& - "made by scaling values without moving the zero contour.",& - default=.false.) - call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_TO_ZERO", & - CS%adjust_net_fresh_water_to_zero, & - "If true, adjusts the net fresh-water forcing seen "//& - "by the ocean (including restoring) to zero.", default=.false.) - if (CS%adjust_net_fresh_water_to_zero) & - call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & - CS%use_net_FW_adjustment_sign_bug, & - "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.false.) - call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & - CS%adjust_net_fresh_water_by_scaling, & - "If true, adjustments to net fresh water to achieve zero net are "//& - "made by scaling values without moving the zero contour.",& - default=.false.) - call get_param(param_file, mdl, "ICE_SALT_CONCENTRATION", & - CS%ice_salt_concentration, & - "The assumed sea-ice salinity needed to reverse engineer the "//& - "melt flux (or ice-ocean fresh-water flux).", & - units="kg/kg", default=0.005) - call get_param(param_file, mdl, "USE_LIMITED_PATM_SSH", CS%use_limited_P_SSH, & - "If true, return the sea surface height with the "//& - "correction for the atmospheric (and sea-ice) pressure "//& - "limited by max_p_surf instead of the full atmospheric "//& - "pressure.", default=.true.) - -! smg: should get_param call should be removed when have A=B code reconciled. -! this param is used to distinguish how to diagnose surface heat content from water. - call get_param(param_file, mdl, "BULKMIXEDLAYER", CS%bulkmixedlayer, & - default=CS%use_temperature,do_not_log=.true.) - - call get_param(param_file, mdl, "WIND_STAGGER", 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 - 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 = "// & - trim(stagger)//" is invalid.") ; endif - call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & - "A factor multiplying the wind-stress given to the ocean by the "//& - "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) - - if (restore_salt) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & - "A file in which to find the surface salinity to use for restoring.", & - default="salt_restore.nc") - call get_param(param_file, mdl, "SALT_RESTORE_VARIABLE", CS%salt_restore_var_name, & - "The name of the surface salinity variable to read from "//& - "SALT_RESTORE_FILE for restoring salinity.", & - default="salt") -! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 - - call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & - "If true, the restoring of salinity is applied as a salt "//& - "flux instead of as a freshwater flux.", default=.false.) - call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & - "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0) - call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & - CS%mask_srestore_under_ice, & - "If true, disables SSS restoring under sea-ice based on a frazil "//& - "criteria (SST<=Tf). Only used when RESTORE_SALINITY is True.", & - default=.false.) - call get_param(param_file, mdl, "MASK_SRESTORE_MARGINAL_SEAS", & - CS%mask_srestore_marginal_seas, & - "If true, disable SSS restoring in marginal seas. Only used when "//& - "RESTORE_SALINITY is True.", default=.false.) - call get_param(param_file, mdl, "BASIN_FILE", basin_file, & - "A file in which to find the basin masks, in variable 'basin'.", & - default="basin.nc") - basin_file = trim(CS%inputdir) // trim(basin_file) - call safe_alloc_ptr(CS%basin_mask,isd,ied,jsd,jed) ; CS%basin_mask(:,:) = 1.0 - if (CS%mask_srestore_marginal_seas) then - call read_data(basin_file,'basin',CS%basin_mask,domain=G%domain%mpp_domain,timelevel=1) - do j=jsd,jed ; do i=isd,ied - if (CS%basin_mask(i,j) >= 6.0) then ; CS%basin_mask(i,j) = 0.0 - else ; CS%basin_mask(i,j) = 1.0 ; endif - enddo ; enddo - endif - endif - - if (restore_temp) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & - "A file in which to find the surface temperature to use for restoring.", & - default="temp_restore.nc") - call get_param(param_file, mdl, "SST_RESTORE_VARIABLE", CS%temp_restore_var_name, & - "The name of the surface temperature variable to read from "//& - "SST_RESTORE_FILE for restoring sst.", & - default="temp") -! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 - - call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & - "The maximum sst difference used in restoring terms.", & - units="degC ", default=999.0) - - endif - -! Optionally read tidal amplitude from input file [m s-1] on model grid. -! Otherwise use default tidal amplitude for bottom frictionally-generated -! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of -! work done against tides globally using OSU tidal amplitude. - call get_param(param_file, mdl, "CD_TIDES", CS%cd_tides, & - "The drag coefficient that applies to the tides.", & - units="nondim", default=1.0e-4) - call get_param(param_file, mdl, "READ_TIDEAMP", CS%read_TIDEAMP, & - "If true, read a file (given by TIDEAMP_FILE) containing "//& - "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) - if (CS%read_TIDEAMP) then - call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & - "The path to the file containing the spatially varying "//& - "tidal amplitudes with INT_TIDE_DISSIPATION.", & - default="tideamp.nc") - CS%utide=0.0 - else - call get_param(param_file, mdl, "UTIDE", CS%utide, & - "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) - endif - - call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) - call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) - - if (CS%read_TIDEAMP) then - TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call read_data(TideAmp_file,'tideamp',CS%TKE_tidal,domain=G%domain%mpp_domain,timelevel=1) - 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 - 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 - enddo ; enddo - endif - - call time_interp_external_init - -! Optionally read a x-y gustiness field in place of a global -! constant. - - call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from "//& - "an input file", default=.false.) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) - if (CS%read_gust_2d) then - call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in "//& - "variable gustiness.") - - call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) - gust_file = trim(CS%inputdir) // trim(gust_file) - call read_data(gust_file,'gustiness',CS%gust,domain=G%domain%mpp_domain, & - timelevel=1) ! units should be Pa - endif - -! See whether sufficiently thick sea ice should be treated as rigid. - call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & - "If true, sea-ice is rigid enough to exert a "//& - "nonhydrostatic pressure that resist vertical motion.", & - default=.false.) - if (CS%rigid_sea_ice) then - call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) - call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & - "A typical density of sea ice, used with the kinematic "//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) - call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & - "The kinematic viscosity of sufficiently thick sea ice "//& - "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) - call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & - "The mass of sea-ice per unit area at which the sea-ice "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) - endif - - 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 register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles, & - use_berg_fluxes=iceberg_flux_diags) - - call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & - "If true, allows flux adjustments to specified via the "//& - "data_table using the component name 'OCN'.", default=.false.) - if (CS%allow_flux_adjustments) then - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) - endif - - if (present(restore_salt)) then ; if (restore_salt) then - salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) - endif ; endif - - if (present(restore_temp)) then ; if (restore_temp) then - temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) - endif ; endif - - ! Set up any restart fields associated with the forcing. - call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") - call restart_init_end(CS%restart_CSp) - - if (associated(CS%restart_CSp)) then - call Get_MOM_Input(dirs=dirs) - - new_sim = .false. - if ((dirs%input_filename(1:1) == 'n') .and. & - (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. - if (.not.new_sim) then - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) - endif - endif - - call user_revise_forcing_init(param_file, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) -end subroutine surface_forcing_init - -!======================================================================= - -!> Finalizes surface forcing: deallocate surface forcing control structure -subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS - type(forcing), optional, intent(inout) :: fluxes -! Arguments: CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init, it will be deallocated here. -! (inout) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. - - if (present(fluxes)) call deallocate_forcing_type(fluxes) - - if (associated(CS)) deallocate(CS) - CS => NULL() - -end subroutine surface_forcing_end - -!======================================================================= - -subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) - - character(len=*), intent(in) :: id - integer , intent(in) :: timestep - type(ice_ocean_boundary_type), intent(in) :: iobt - integer :: n,m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ', mpp_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ', mpp_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ', mpp_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%seaice_melt_heat', mpp_chksum( iobt%seaice_melt_heat) - write(outunit,100) 'iobt%seaice_melt ', mpp_chksum( iobt%seaice_melt ) - write(outunit,100) 'iobt%q_flux ', mpp_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%rofl_flux ', mpp_chksum( iobt%rofl_flux ) - write(outunit,100) 'iobt%rofi_flux ', mpp_chksum( iobt%rofi_flux ) - write(outunit,100) 'iobt%salt_flux ', mpp_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%lw_flux ', mpp_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir ', mpp_chksum( iobt%sw_flux_vis_dir ) - write(outunit,100) 'iobt%sw_flux_vis_dif ', mpp_chksum( iobt%sw_flux_vis_dif ) - write(outunit,100) 'iobt%sw_flux_nir_dir ', mpp_chksum( iobt%sw_flux_nir_dir ) - write(outunit,100) 'iobt%sw_flux_nir_dif ', mpp_chksum( iobt%sw_flux_nir_dif ) - write(outunit,100) 'iobt%lprec ', mpp_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ', mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%calving ', mpp_chksum( iobt%calving ) - write(outunit,100) 'iobt%p ', mpp_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) -100 FORMAT(" CHECKSUM::",A20," = ",Z20) - - call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') - -end subroutine ice_ocn_bnd_type_chksum - -end module MOM_surface_forcing diff --git a/config_src/dynamic/MOM_memory.h b/config_src/memory/dynamic_nonsymmetric/MOM_memory.h similarity index 100% rename from config_src/dynamic/MOM_memory.h rename to config_src/memory/dynamic_nonsymmetric/MOM_memory.h diff --git a/config_src/dynamic_symmetric/MOM_memory.h b/config_src/memory/dynamic_symmetric/MOM_memory.h similarity index 100% rename from config_src/dynamic_symmetric/MOM_memory.h rename to config_src/memory/dynamic_symmetric/MOM_memory.h diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 deleted file mode 100644 index 3992aae530..0000000000 --- a/config_src/nuopc_driver/mom_cap.F90 +++ /dev/null @@ -1,2533 +0,0 @@ -!> -!! @mainpage MOM NUOPC Cap -!! @author Fei Liu (fei.liu@gmail.com) -!! @date 5/10/13 Original documentation -!! @author Rocky Dunlap (rocky.dunlap@noaa.gov) -!! @date 1/12/17 Moved to doxygen -!! @date 2/28/19 Rewrote for unified cap -!! -!! @tableofcontents -!! -!! @section Overview Overview -!! -!! **This MOM cap has been tested with MOM6.** -!! -!! This document describes the MOM NUOPC "cap", which is a light weight software layer that is -!! required when the [MOM ocean model](https://github.com/NOAA-GFDL/MOM6/tree/dev/master) -!! is used in [National Unified Operation Prediction Capability] -!! (http://www.earthsystemcog.org/projects/nuopc) (NUOPC) coupled systems. Also see the -!! [MOM wiki](https://github.com/NOAA-GFDL/MOM6-Examples/wiki) for more documentation. -!! -!! NUOPC is a software layer built on top of the [Earth System Modeling -!! Framework] (https://www.earthsystemcog.org/projects/esmf) (ESMF). -!! ESMF is a high-performance modeling framework that provides -!! data structures, interfaces, and operations suited for building coupled models -!! from a set of components. NUOPC refines the capabilities of ESMF by providing -!! a more precise definition of what it means for a model to be a component and -!! how components should interact and share data in a coupled system. The NUOPC -!! Layer software is designed to work with typical high-performance models in the -!! Earth sciences domain, most of which are written in Fortran and are based on a -!! distributed memory model of parallelism (MPI). -!! -!! A NUOPC "cap" is a Fortran module that serves as the interface to a model -!! when it's used in a NUOPC-based coupled system. -!! The term "cap" is used because it is a light weight software layer that sits on top -!! of model code, making calls into it and exposing model data structures in a -!! standard way. -!! -!! The MOM cap package includes the cap code itself (mom_cap.F90, mom_cap_methods.F90 -!! and mom_cap_time.F90), a set of time utilities (time_utils.F90) for converting between ESMF and FMS -!! time type and two modules MOM_ocean_model.F90 and MOM_surface_forcing.F90. MOM_surface_forcing.F90 -!! converts the input ESMF data (import data) to a MOM-specific data type (surface_forcing_CS). -!! MOM_ocean_model.F90 contains routines for initialization, update and finalization of the ocean model state. -!! -!! @subsection CapSubroutines Cap Subroutines -!! -!! The MOM cap modules contains a set of subroutines that are required -!! by NUOPC. These subroutines are called by the NUOPC infrastructure according -!! to a predefined calling sequence. Some subroutines are called during -!! initialization of the coupled system, some during the run of the coupled -!! system, and some during finalization of the coupled system. -!! -!! The initialization sequence is the most complex and is governed by the NUOPC technical rules. -!! Details about the initialization sequence can be found in the [NUOPC Reference Manual] -!! (http://www.earthsystemmodeling.org/esmf_releases/last_built/NUOPC_refdoc/). -!! The cap requires beta snapshot ESMF v8.0.0bs16 or later. -!! -!! The following table summarizes the NUOPC-required subroutines that appear in the -!! MOM cap. The "Phase" column says whether the subroutine is called during the -!! initialization, run, or finalize part of the coupled system run. -!! -!! Phase | MOM Cap Subroutine | Description -!! ---------|--------------------------------------------------------------------|-------------------------------------- -!! Init | [InitializeP0] (@ref mom_cap_mod::initializep0) | Sets the Initialize Phase Definition -!! | (IPD) version to use -!! Init | [InitializeAdvertise] (@ref mom_cap_mod::initializeadvertise) | Advertises standard names of import -!! | and export fields -!! Init | [InitializeRealize] (@ref mom_cap_mod::initializerealize) | Creates an ESMF_Grid or ESMF_Mesh -!! | as well as ESMF_Fields for import -!! | and export fields -!! Run | [ModelAdvance] (@ref mom_cap_mod::modeladvance) | Advances the model by a timestep -!! Final | [Finalize] (@ref mom_cap_mod::ocean_model_finalize) | Cleans up -!! -!! @section UnderlyingModelInterfaces Underlying Model Interfaces -!! -!! -!! @subsection DomainCreation Domain Creation -!! -!! The cap can accomodate a MOM tripolar grid which is represented either as a 2D `ESMF_Grid` or -!! as a 1D `ESMF_Mesh`. Other MOM grids (e.g. a bipolar grid) can be represented as a 1d `ESMF_Mesh` only. -!! Coupling fields are placed on either the `ESMF_Grid` or `ESMF_Mesh`. -!! Note that for either the `ESMF_Grid` or `ESMF_Mesh` representation, the fields are translated into -!! a 2D MOM specific surface boundary type and the distinction between the two is no longer there. -!! Calls related to creating the grid are located in the [InitializeRealize] -!! (@ref mom_cap_mod::initializerealize) subroutine, which is called by the NUOPC infrastructure -!! during the intialization sequence. -!! -!! The cap determines parameters for setting up the grid by calling subroutines in the -!! `mpp_domains_mod` module. The global domain size is determined by calling `mpp_get_global_domain()`. -!! A check is in place to ensure that there is only a single tile in the domain (the -!! cap is currently limited to one tile; multi-tile mosaics are not supported). The -!! decomposition across processors is determined via calls to `mpp_get_compute_domains()` -!! (to retrieve decomposition block indices) and `mpp_get_pelist()` (to determine how -!! blocks are assigned to processors). -!! -!! The `ESMF_Grid` is created in several steps: -!! - an `ESMF_DELayout` is created based on the pelist from MOM -!! - an `ESMF_DistGrid` is created over the global index space. Connections are set -!! up so that the index space is periodic in the first dimension and has a -!! fold at the top for the bipole. The decompostion blocks are also passed in -!! along with the `ESMF_DELayout` mentioned above. -!! - an `ESMF_Grid` is then created by passing in the above `ESMF_DistGrid`. -!! - masks, areas, center (tlat, tlon), and corner (ulat, ulon) coordinates are then added to the `ESMF_Grid` -!! by retrieving those fields from the MOM datatype `ocean_grid` elements. -!! -!! The `ESMF_Mesh` is also created in several steps: -!! - the target mesh is generated offline. -!! - a temporary mesh is created from an input file specified by the config variable `mesh_ocn`. -!! the mesh has a distribution that is automatically generated by ESMF when reading in the mesh -!! - an `ESMF_DistGrid` is created from the global index space for the computational domain. -!! - the final `ESMF_Mesh` is then created by distributing the temporary mesh using the created `ESMF_DistGrid`. -!! -!! -!! @subsection Initialization Initialization -!! -!! During the [InitializeAdvertise] (@ref mom_cap_mod::initializeadvertise) phase, calls are -!! made to MOM's native initialization subroutines, including `fms_init()`, `constants_init()`, -!! `field_manager_init()`, `diag_manager_init()`, and `set_calendar_type()`. The MPI communicator -!! is pulled in through the ESMF VM object for the MOM component. The dt and start time are set -!! from parameters from the incoming ESMF clock with calls to `set_time()` and `set_date().` -!! -!! -!! @subsection Run Run -!! -!! The [ModelAdvance] (@ref mom_cap_mod::modeladvance) subroutine is called by the NUOPC -!! infrastructure when it's time for MOM to advance in time. During this subroutine, there is a -!! call into the MOM update routine: -!! -!! call update_ocean_model(Ice_ocean_boundary, Ocean_state, Ocean_public, Time, Time_step_coupled) -!! -!! Priori to the call to `update_ocean_model()`, the cap performs these steps -!! - the `Time` and `Time_step_coupled` parameters, based on FMS types, are derived from the incoming ESMF clock -!! - diagnostics are optionally written to files `field_ocn_import_*`, one for each import field -!! - mom_import is called and translates to the ESMF input data to a MOM specific data type -!! - momentum flux vectors are rotated to internal grid -!! -!! After the call to `update_ocean_model()`, the cap performs these steps: -!! - mom_export is called -!! - the `ocean_mask` export is set to match that of the internal MOM mask -!! - the `freezing_melting_potential` export is converted from J m-2 to W m-2 by dividing by the coupling interval -!! - vector rotations are applied to the `ocean_current_zonal` and `ocean_current_merid` exports, back to lat-lon grid -!! - diagnostics are optionally written to files `field_ocn_export_*`, one for each export field -!! - optionally, a call is made to `ocean_model_restart()` at the interval `restart_interval` -!! -!! @subsubsection VectorRotations Vector Rotations -!! -!! Vector rotations are applied to incoming momentum fluxes (from regular lat-lon to tripolar grid) and -!! outgoing ocean currents (from tripolar to regular lat-lon). The rotation angles are provided -!! from the native MOM grid by a call to `get_ocean_grid(Ocean_grid)`. -!! The cosine and sine of the rotation angle are: -!! -!! ocean_grid%cos_rot(i,j) -!! ocean_grid%sin_rot(i,j) -!! -!! The rotation of momentum flux from regular lat-lon to tripolar is: -!! \f[ -!! \begin{bmatrix} -!! \tau_x' \\ -!! \tau_y' -!! \end{bmatrix} = -!! \begin{bmatrix} -!! cos \theta & sin \theta \\ -!! -sin \theta & cos \theta -!! \end{bmatrix} * -!! \begin{bmatrix} -!! \tau_x \\ -!! \tau_y -!! \end{bmatrix} -!! \f] -!! -!! The rotation of ocean current from tripolar to regular lat-lon is: -!! \f[ -!! \begin{bmatrix} -!! u' \\ -!! v' -!! \end{bmatrix} = -!! \begin{bmatrix} -!! cos \theta & -sin \theta \\ -!! sin \theta & cos \theta -!! \end{bmatrix} * -!! \begin{bmatrix} -!! u \\ -!! v -!! \end{bmatrix} -!! \f] -!! @subsection Finalization Finalization -!! -!! NUOPC infrastructure calls [ocean_model_finalize] (@ref mom_cap_mod::ocean_model_finalize) -!! at the end of the run. This subroutine is a hook to call into MOM's native shutdown -!! procedures: -!! -!! call ocean_model_end (ocean_public, ocean_State, Time) -!! call diag_manager_end(Time ) -!! call field_manager_end -!! call fms_io_exit -!! call fms_end -!! -!! @section ModelFields Model Fields -!! -!! The following tables list the import and export fields currently set up in the MOM cap. -!! -!! @subsection ImportFields Import Fields -!! -!! Standard Name | Units | Model Variable | Description | Notes -!! --------------------------|------------|-----------------|---------------------------------------|------------------- -!! inst_pres_height_surface | Pa | p | pressure of overlying sea ice and atmosphere -!! mass_of_overlying_sea_ice | kg | mi | mass of overlying sea ice | | -!! seaice_melt_heat | W m-2 | seaice_melt_heat| sea ice and snow melt heat flux | | -!! seaice_melt | kg m-2 s-1 | seaice_melt | water flux due to sea ice and snow melting | | -!! mean_calving_heat_flx | W m-2 | calving_hflx | heat flux, relative to 0C, of frozen land water into ocean -!! mean_calving_rate | kg m-2 s-1 | calving | mass flux of frozen runoff | | -!! mean_evap_rate | kg m-2 s-1 | q_flux | specific humidity flux | -!! mean_fprec_rate | kg m-2 s-1 | fprec | mass flux of frozen precip | | -!! mean_merid_moment_flx | Pa | v_flux | j-directed wind stress into ocean -!! | [vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar -!! mean_net_lw_flx | W m-2 | lw_flux | long wave radiation | | -!! mean_net_sw_ir_dif_flx | W m-2 | sw_flux_nir_dif | diffuse near IR shortwave radiation| | -!! mean_net_sw_ir_dir_flx | W m-2 | sw_flux_nir_dir | direct near IR shortwave radiation | | -!! mean_net_sw_vis_dif_flx | W m-2 | sw_flux_vis_dif | diffuse visible shortware radiation| | -!! mean_net_sw_vis_dir_flx | W m-2 | sw_flux_vis_dir | direct visible shortware radiation | | -!! mean_prec_rate | kg m-2 s-1 | lprec | mass flux of liquid precip | | -!! mean_runoff_heat_flx | W m-2 | runoff_hflx | heat flux, relative to 0C, of liquid land water into ocean -!! mean_runoff_rate | kg m-2 s-1 | runoff | mass flux of liquid runoff | | -!! mean_salt_rate | kg m-2 s-1 | salt_flux | salt flux | | -!! mean_sensi_heat_flx | W m-2 | t_flux | sensible heat flux into ocean | -!! mean_zonal_moment_flx | Pa | u_flux | i-directed wind stress into ocean -!! | [vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar -!! -!! -!! @subsection ExportField Export Fields -!! -!! Export fields are populated from the `ocean_public` parameter (type `ocean_public_type`) -!! after the call to `update_ocean_model()`. -!! -!! Standard Name | Units | Model Variable | Description | Notes -!! ---------------------------|-------|----------------|-------------------------------------------|-------------------- -!! freezing_melting_potential | W m-2 | combination of frazil and melt_potential -!! | cap converts model units (J m-2) to (W m-2) for export -!! ocean_mask | | | ocean mask | | -!! ocn_current_merid | m s-1 | v_surf | j-directed surface velocity on u-cell -!! | [vector rotation] (@ref VectorRotations) applied -!! | - tripolar to lat-lon -!! ocn_current_zonal | m s-1 | u_surf | i-directed surface velocity on u-cell -!! | [vector rotation] (@ref VectorRotations) applied -!! | - tripolar to lat-lon -!! s_surf | psu | s_surf | sea surface salinity on t-cell | | -!! sea_surface_temperature | K | t_surf | sea surface temperature on t-cell | | -!! sea_surface_slope_zonal ! unitless | created from ssh | sea surface zonal slope -!! sea_surface_slope_merid ! unitless | created from ssh | sea surface meridional slope -!! so_bldepth ! m ! obld | ocean surface boundary layer depth -!! -!! @subsection MemoryManagement Memory Management -!! -!! The MOM cap has an internal state type with pointers to three -!! types defined by MOM. There is also a small wrapper derived type -!! required to associate an internal state instance -!! with the ESMF/NUOPC component: -!! -!! type ocean_internalstate_type -!! type(ocean_public_type), pointer :: ocean_public_type_ptr -!! type(ocean_state_type), pointer :: ocean_state_type_ptr -!! type(ice_ocean_boundary_type), pointer :: ice_ocean_boundary_type_ptr -!! end type -!! -!! type ocean_internalstate_wrapper -!! type(ocean_internalstate_type), pointer :: ptr -!! end type -!! -!! The member of type `ocean_public_type` stores ocean surface fields used during the coupling. -!! The member of type `ocean_state_type` is required by the ocean driver, -!! although its internals are private (not to be used by the coupling directly). -!! This type is passed to the ocean init and update routines -!! so that it can maintain state there if desired. -!! The member of type `ice_ocean_boundary_type` is populated by this cap -!! with incoming coupling fields from other components. These three derived types are allocated during the -!! [InitializeAdvertise] (@ref mom_cap_mod::initializeadvertise) phase. Also during that -!! phase, the `ice_ocean_boundary` type members are all allocated using bounds retrieved -!! from `mpp_get_compute_domain()`. -!! -!! During the [InitializeRealize] (@ref mom_cap_mod::initializerealize) phase, -!! `ESMF_Field`s are created for each of the coupling fields in the `ice_ocean_boundary` -!! and `ocean_public_type` members of the internal state. These fields directly reference into the members of -!! the `ice_ocean_boundary` and `ocean_public_type` so that memory-to-memory copies are not required to move -!! data from the cap's import and export states to the memory areas used internally -!! by MOM. -!! -!! @subsection IO I/O -!! -!! The cap can optionally output coupling fields for diagnostic purposes if the ESMF attribute -!! "DumpFields" has been set to "true". In this case the cap will write out NetCDF files -!! with names "field_ocn_import_.nc" and "field_ocn_export_.nc". -!! Additionally, calls will be made to the cap subroutine [dumpMomInternal] -!! (@ref mom_cap_mod::dumpmominternal) to write out model internal fields to files -!! named "field_ocn_internal_.nc". In all cases these NetCDF files will -!! contain a time series of field data. -!! -!! @section RuntimeConfiguration Runtime Configuration -!! -!! At runtime, the MOM cap can be configured with several options provided -!! as ESMF attributes. Attributes can be set in the cap by the NUOPC Driver -!! above this cap, or in some systems ESMF attributes are set by -!! reading in from a configuration file. The available attributes are: -!! -!! * `DumpFields` - when set to "true", write out diagnostic NetCDF files for import/export/internal fields -!! * `ProfileMemory` - when set to "true", write out memory usage information to the ESMF log files; this -!! information is written when entering and leaving the [ModelAdvance] -!! (@ref mom_cap_mod::modeladvance) subroutine and before and after the call to -!! `update_ocean_model()`. -!! * `restart_interval` - integer number of seconds indicating the interval at -!! which to call `ocean_model_restart()`; no restarts written if set to 0 -!! -!! - -!> This module contains a set of subroutines that are required by NUOPC. -module mom_cap_mod -use constants_mod, only: constants_init -use diag_manager_mod, only: diag_manager_init, diag_manager_end -use field_manager_mod, only: field_manager_init, field_manager_end -use fms_mod, only: fms_init, fms_end, open_namelist_file, check_nml_error -use fms_mod, only: close_file, file_exist, uppercase -use fms_io_mod, only: fms_io_exit -use mpp_domains_mod, only: domain2d, mpp_get_compute_domain, mpp_get_compute_domains -use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain -use mpp_domains_mod, only: mpp_get_domain_npes -use mpp_io_mod, only: mpp_open, MPP_RDONLY, MPP_ASCII, MPP_OVERWR, MPP_APPEND, mpp_close, MPP_SINGLE -use mpp_mod, only: input_nml_file, mpp_error, FATAL, NOTE, mpp_pe, mpp_npes, mpp_set_current_pelist -use mpp_mod, only: stdlog, stdout, mpp_root_pe, mpp_clock_id -use mpp_mod, only: mpp_clock_begin, mpp_clock_end, MPP_CLOCK_SYNC -use mpp_mod, only: MPP_CLOCK_DETAILED, CLOCK_COMPONENT, MAXPES -use time_interp_external_mod, only: time_interp_external_init -use time_manager_mod, only: set_calendar_type, time_type, increment_date -use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name -use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR -use time_manager_mod, only: operator( <= ), operator( < ), operator( >= ) -use time_manager_mod, only: operator( + ), operator( - ), operator( / ) -use time_manager_mod, only: operator( * ), operator( /= ), operator( > ) -use time_manager_mod, only: date_to_string -use time_manager_mod, only: fms_get_calendar_type => get_calendar_type -use MOM_domains, only: MOM_infra_init, num_pes, root_pe, pe_here -use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file -use MOM_get_input, only: Get_MOM_Input, directories -use MOM_domains, only: pass_var -use MOM_error_handler, only: is_root_pe -use MOM_ocean_model, only: ice_ocean_boundary_type -use MOM_grid, only: ocean_grid_type, get_global_grid_size -use MOM_ocean_model, only: ocean_model_restart, ocean_public_type, ocean_state_type -use MOM_ocean_model, only: ocean_model_init_sfc -use MOM_ocean_model, only: ocean_model_init, update_ocean_model, ocean_model_end, get_ocean_grid -use mom_cap_time, only: AlarmInit -use mom_cap_methods, only: mom_import, mom_export, mom_set_geomtype -#ifdef CESMCOUPLED -use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit -#endif -use time_utils_mod, only: esmf2fms_time - -use, intrinsic :: iso_fortran_env, only: output_unit - -use ESMF, only: ESMF_ClockAdvance, ESMF_ClockGet, ESMF_ClockPrint -use ESMF, only: ESMF_ClockGetAlarm, ESMF_ClockGetNextTime, ESMF_ClockAdvance -use ESMF, only: ESMF_ClockSet, ESMF_Clock, ESMF_GeomType_Flag, ESMF_LOGMSG_INFO -use ESMF, only: ESMF_Grid, ESMF_GridCreate, ESMF_GridAddCoord -use ESMF, only: ESMF_GridGetCoord, ESMF_GridAddItem, ESMF_GridGetItem -use ESMF, only: ESMF_GridComp, ESMF_GridCompSetEntryPoint, ESMF_GridCompGet -use ESMF, only: ESMF_LogFoundError, ESMF_LogWrite, ESMF_LogSetError -use ESMF, only: ESMF_LOGERR_PASSTHRU, ESMF_KIND_R8, ESMF_RC_VAL_WRONG -use ESMF, only: ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_SUCCESS -use ESMF, only: ESMF_METHOD_INITIALIZE, ESMF_MethodRemove, ESMF_State -use ESMF, only: ESMF_LOGMSG_INFO, ESMF_RC_ARG_BAD, ESMF_VM, ESMF_Time -use ESMF, only: ESMF_TimeInterval, ESMF_MAXSTR, ESMF_VMGetCurrent -use ESMF, only: ESMF_VMGet, ESMF_TimeGet, ESMF_TimeIntervalGet -use ESMF, only: ESMF_MethodExecute, ESMF_Mesh, ESMF_DeLayout, ESMF_Distgrid -use ESMF, only: ESMF_DistGridConnection, ESMF_StateItem_Flag, ESMF_KIND_I4 -use ESMF, only: ESMF_KIND_I8, ESMF_FAILURE, ESMF_DistGridCreate, ESMF_MeshCreate -use ESMF, only: ESMF_FILEFORMAT_ESMFMESH, ESMF_DELayoutCreate, ESMF_DistGridConnectionSet -use ESMF, only: ESMF_DistGridGet, ESMF_STAGGERLOC_CORNER, ESMF_GRIDITEM_MASK -use ESMF, only: ESMF_TYPEKIND_I4, ESMF_TYPEKIND_R8, ESMF_STAGGERLOC_CENTER -use ESMF, only: ESMF_GRIDITEM_AREA, ESMF_Field, ESMF_ALARM, ESMF_VMLogMemInfo -use ESMF, only: ESMF_AlarmIsRinging, ESMF_AlarmRingerOff, ESMF_StateRemove -use ESMF, only: ESMF_FieldCreate, ESMF_LOGMSG_ERROR, ESMF_LOGMSG_WARNING -use ESMF, only: ESMF_COORDSYS_SPH_DEG, ESMF_GridCreate, ESMF_INDEX_DELOCAL -use ESMF, only: ESMF_MESHLOC_ELEMENT, ESMF_RC_VAL_OUTOFRANGE, ESMF_StateGet -use ESMF, only: ESMF_TimePrint, ESMF_AlarmSet, ESMF_FieldGet -use ESMF, only: operator(==), operator(/=), operator(+), operator(-) - -! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. -!! Model does not compile with "use ESMF, only: ESMF_GridCompGetInternalState" -!! Is this okay? - -use NUOPC, only: NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize -use NUOPC, only: NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet, NUOPC_CompAttributeAdd -use NUOPC, only: NUOPC_Advertise, NUOPC_SetAttribute, NUOPC_IsUpdated, NUOPC_Write -use NUOPC, only: NUOPC_IsConnected, NUOPC_Realize, NUOPC_CompAttributeSet -use NUOPC_Model, only: NUOPC_ModelGet -use NUOPC_Model, & - model_routine_SS => SetServices, & - model_label_Advance => label_Advance, & - model_label_DataInitialize => label_DataInitialize, & - model_label_SetRunClock => label_SetRunClock, & - model_label_Finalize => label_Finalize - -implicit none; private - -public SetServices - -!> Internal state type with pointers to three types defined by MOM. -type ocean_internalstate_type - type(ocean_public_type), pointer :: ocean_public_type_ptr - type(ocean_state_type), pointer :: ocean_state_type_ptr - type(ice_ocean_boundary_type), pointer :: ice_ocean_boundary_type_ptr -end type - -!> Wrapper-derived type required to associate an internal state instance -!! with the ESMF/NUOPC component -type ocean_internalstate_wrapper - type(ocean_internalstate_type), pointer :: ptr -end type - -!> Contains field information -type fld_list_type - character(len=64) :: stdname - character(len=64) :: shortname - character(len=64) :: transferOffer -end type fld_list_type - -integer,parameter :: fldsMax = 100 -integer :: fldsToOcn_num = 0 -type (fld_list_type) :: fldsToOcn(fldsMax) -integer :: fldsFrOcn_num = 0 -type (fld_list_type) :: fldsFrOcn(fldsMax) - -integer :: debug = 0 -integer :: import_slice = 1 -integer :: export_slice = 1 -character(len=256) :: tmpstr -logical :: write_diagnostics = .false. -character(len=32) :: runtype !< run type -integer :: logunit !< stdout logging unit number -logical :: profile_memory = .true. -logical :: grid_attach_area = .false. -character(len=128) :: scalar_field_name = '' -integer :: scalar_field_count = 0 -integer :: scalar_field_idx_grid_nx = 0 -integer :: scalar_field_idx_grid_ny = 0 -character(len=*),parameter :: u_file_u = & - __FILE__ - -#ifdef CESMCOUPLED -logical :: cesm_coupled = .true. -type(ESMF_GeomType_Flag) :: geomtype = ESMF_GEOMTYPE_MESH -#else -logical :: cesm_coupled = .false. -type(ESMF_GeomType_Flag) :: geomtype = ESMF_GEOMTYPE_GRID -#endif - -contains - -!> NUOPC SetService method is the only public entry point. -!! SetServices registers all of the user-provided subroutines -!! in the module with the NUOPC layer. -!! -!! @param gcomp an ESMF_GridComp object -!! @param rc return code -subroutine SetServices(gcomp, rc) - - type(ESMF_GridComp) :: gcomp !< an ESMF_GridComp object - integer, intent(out) :: rc !< return code - - ! local variables - character(len=*),parameter :: subname='(mom_cap:SetServices)' - - rc = ESMF_SUCCESS - - ! the NUOPC model component will register the generic methods - call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! switching to IPD versions - call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & - userRoutine=InitializeP0, phase=0, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! set entry point for methods that require specific implementation - call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & - phaseLabelList=(/"IPDv03p1"/), userRoutine=InitializeAdvertise, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & - phaseLabelList=(/"IPDv03p3"/), userRoutine=InitializeRealize, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !------------------ - ! attach specializing method(s) - !------------------ - - call NUOPC_CompSpecialize(gcomp, specLabel=model_label_DataInitialize, & - specRoutine=DataInitialize, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & - specRoutine=ModelAdvance, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & - specRoutine=ModelSetRunClock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & - specRoutine=ocean_model_finalize, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - -end subroutine SetServices - -!> First initialize subroutine called by NUOPC. The purpose -!! is to set which version of the Initialize Phase Definition (IPD) -!! to use. -!! -!! For this MOM cap, we are using IPDv01. -!! -!! @param gcomp an ESMF_GridComp object -!! @param importState an ESMF_State object for import fields -!! @param exportState an ESMF_State object for export fields -!! @param clock an ESMF_Clock object -!! @param rc return code -subroutine InitializeP0(gcomp, importState, exportState, clock, rc) - type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object - type(ESMF_State) :: importState, exportState !< ESMF_State object for - !! import/export fields - type(ESMF_Clock) :: clock !< ESMF_Clock object - integer, intent(out) :: rc !< return code - - ! local variables - logical :: isPresent, isSet - integer :: iostat - character(len=64) :: value, logmsg - character(len=*),parameter :: subname='(mom_cap:InitializeP0)' - - rc = ESMF_SUCCESS - - ! Switch to IPDv03 by filtering all other phaseMap entries - call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & - acceptStringList=(/"IPDv03p"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - write_diagnostics = .false. - call NUOPC_CompAttributeGet(gcomp, name="DumpFields", value=value, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) write_diagnostics=(trim(value)=="true") - - write(logmsg,*) write_diagnostics - call ESMF_LogWrite('mom_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - profile_memory = .false. - call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=value, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) profile_memory=(trim(value)=="true") - write(logmsg,*) profile_memory - call ESMF_LogWrite('mom_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - grid_attach_area = .false. - call NUOPC_CompAttributeGet(gcomp, name="GridAttachArea", value=value, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) grid_attach_area=(trim(value)=="true") - write(logmsg,*) grid_attach_area - call ESMF_LogWrite('mom_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - scalar_field_name = "" - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - scalar_field_name = trim(value) - call ESMF_LogWrite('mom_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - scalar_field_count = 0 - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=value, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_count - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldCount not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_count - call ESMF_LogWrite('mom_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - scalar_field_idx_grid_nx = 0 - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=value, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('mom_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - scalar_field_idx_grid_ny = 0 - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=value, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('mom_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - call NUOPC_CompAttributeAdd(gcomp, & - attrList=(/'RestartFileToRead', 'RestartFileToWrite'/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - -end subroutine - -!> Called by NUOPC to advertise import and export fields. "Advertise" -!! simply means that the standard names of all import and export -!! fields are supplied. The NUOPC layer uses these to match fields -!! between components in the coupled system. -!! -!! @param gcomp an ESMF_GridComp object -!! @param importState an ESMF_State object for import fields -!! @param exportState an ESMF_State object for export fields -!! @param clock an ESMF_Clock object -!! @param rc return code -subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) - type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object - type(ESMF_State) :: importState, exportState !< ESMF_State object for - !! import/export fields - type(ESMF_Clock) :: clock !< ESMF_Clock object - integer, intent(out) :: rc !< return code - - ! local variables - type(ESMF_VM) :: vm - type(ESMF_Time) :: MyTime - type(ESMF_TimeInterval) :: TINT - type (ocean_public_type), pointer :: ocean_public => NULL() - type (ocean_state_type), pointer :: ocean_state => NULL() - type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() - type(ocean_internalstate_wrapper) :: ocean_internalstate - type(ocean_grid_type), pointer :: ocean_grid => NULL() - type(time_type) :: Run_len ! length of experiment - type(time_type) :: Time - type(time_type) :: Time_restart - type(time_type) :: DT - integer :: DT_OCEAN - integer :: isc,iec,jsc,jec - integer :: year=0, month=0, day=0, hour=0, minute=0, second=0 - integer :: mpi_comm_mom - integer :: i,n - character(len=256) :: stdname, shortname - character(len=32) :: starttype ! model start type - character(len=512) :: diro - character(len=512) :: logfile - character(ESMF_MAXSTR) :: cvalue - logical :: isPresent, isPresentDiro, isPresentLogfile, isSet - logical :: existflag - integer :: userRc - character(len=512) :: restartfile ! Path/Name of restart file - character(len=*), parameter :: subname='(mom_cap:InitializeAdvertise)' - character(len=32) :: calendar -!-------------------------------- - - rc = ESMF_SUCCESS - - call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - allocate(Ice_ocean_boundary) - !allocate(ocean_state) ! ocean_model_init allocate this pointer - allocate(ocean_public) - allocate(ocean_internalstate%ptr) - ocean_internalstate%ptr%ice_ocean_boundary_type_ptr => Ice_ocean_boundary - ocean_internalstate%ptr%ocean_public_type_ptr => ocean_public - ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state - - call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call fms_init(mpi_comm_mom) - call constants_init - call field_manager_init - - ! determine the calendar - if (cesm_coupled) then - call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - read(cvalue,*) calendar - select case (trim(calendar)) - case ("NO_LEAP") - call set_calendar_type (NOLEAP) - case ("GREGORIAN") - call set_calendar_type (GREGORIAN) - case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": Calendar not supported in MOM6: "//trim(calendar), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - end select - else - call set_calendar_type (NOLEAP) - endif - - else - call set_calendar_type (JULIAN) - endif - - call diag_manager_init - - ! this ocean connector will be driven at set interval - DT = set_time (DT_OCEAN, 0) - Time = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) - - ! rsd need to figure out how to get this without share code - !call shr_nuopc_get_component_instance(gcomp, inst_suffix, inst_index) - !inst_name = "OCN"//trim(inst_suffix) - - ! reset shr logging to my log file - if (is_root_pe()) then - call NUOPC_CompAttributeGet(gcomp, name="diro", & - isPresent=isPresentDiro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call NUOPC_CompAttributeGet(gcomp, name="logfile", & - isPresent=isPresentLogfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) - else - logunit = output_unit - endif - else - logunit = output_unit - endif - - starttype = "" - call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - read(cvalue,*) starttype - else - call ESMF_LogWrite('mom_cap:start_type unset - using input.nml for restart option', & - ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - runtype = "" - if (trim(starttype) == trim('startup')) then - runtype = "initial" - else if (trim(starttype) == trim('continue') ) then - runtype = "continue" - else if (trim(starttype) == trim('branch')) then - runtype = "continue" - else if (len_trim(starttype) > 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": unknown starttype - "//trim(starttype), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - - if (len_trim(runtype) > 0) then - call ESMF_LogWrite('mom_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - restartfile = "" - if (runtype == "initial") then - ! startup (new run) - 'n' is needed below if we don't specify input_filename in input.nml - restartfile = "n" - else if (runtype == "continue") then ! hybrid or branch or continuos runs - - ! optionally call into system-specific implementation to get restart file name - call ESMF_MethodExecute(gcomp, label="GetRestartFileToRead", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (existflag) then - call ESMF_LogWrite('mom_cap: called user GetRestartFileToRead', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToRead', & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - restartfile = trim(cvalue) - call ESMF_LogWrite('mom_cap: RestartFileToRead = '//trim(restartfile), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - else - call ESMF_LogWrite('mom_cap: restart requested, no RestartFileToRead attribute provided-will use input.nml',& - ESMF_LOGMSG_WARNING, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - endif - - ocean_public%is_ocean_pe = .true. - if (len_trim(restartfile) > 0) then - call ocean_model_init(ocean_public, ocean_state, Time, Time, input_restart_file=trim(restartfile)) - else - call ocean_model_init(ocean_public, ocean_state, Time, Time) - endif - - call ocean_model_init_sfc(ocean_state, ocean_public) - - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - - allocate ( Ice_ocean_boundary% u_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% v_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% t_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% q_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% salt_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% lw_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_vis_dir (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_vis_dif (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_nir_dir (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_nir_dif (isc:iec,jsc:jec), & - Ice_ocean_boundary% lprec (isc:iec,jsc:jec), & - Ice_ocean_boundary% fprec (isc:iec,jsc:jec), & - Ice_ocean_boundary% seaice_melt_heat (isc:iec,jsc:jec),& - Ice_ocean_boundary% seaice_melt (isc:iec,jsc:jec), & - Ice_ocean_boundary% mi (isc:iec,jsc:jec), & - Ice_ocean_boundary% p (isc:iec,jsc:jec), & - Ice_ocean_boundary% runoff (isc:iec,jsc:jec), & - Ice_ocean_boundary% calving (isc:iec,jsc:jec), & - Ice_ocean_boundary% runoff_hflx (isc:iec,jsc:jec), & - Ice_ocean_boundary% calving_hflx (isc:iec,jsc:jec), & - Ice_ocean_boundary% rofl_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% rofi_flux (isc:iec,jsc:jec)) - - Ice_ocean_boundary%u_flux = 0.0 - Ice_ocean_boundary%v_flux = 0.0 - Ice_ocean_boundary%t_flux = 0.0 - Ice_ocean_boundary%q_flux = 0.0 - Ice_ocean_boundary%salt_flux = 0.0 - Ice_ocean_boundary%lw_flux = 0.0 - Ice_ocean_boundary%sw_flux_vis_dir = 0.0 - Ice_ocean_boundary%sw_flux_vis_dif = 0.0 - Ice_ocean_boundary%sw_flux_nir_dir = 0.0 - Ice_ocean_boundary%sw_flux_nir_dif = 0.0 - Ice_ocean_boundary%lprec = 0.0 - Ice_ocean_boundary%fprec = 0.0 - Ice_ocean_boundary%seaice_melt = 0.0 - Ice_ocean_boundary%seaice_melt_heat= 0.0 - Ice_ocean_boundary%mi = 0.0 - Ice_ocean_boundary%p = 0.0 - Ice_ocean_boundary%runoff = 0.0 - Ice_ocean_boundary%calving = 0.0 - Ice_ocean_boundary%runoff_hflx = 0.0 - Ice_ocean_boundary%calving_hflx = 0.0 - Ice_ocean_boundary%rofl_flux = 0.0 - Ice_ocean_boundary%rofi_flux = 0.0 - - ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state - call ESMF_GridCompSetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - if (cesm_coupled) then - if (len_trim(scalar_field_name) > 0) then - call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") - endif - !call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_lamult" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_ustokes" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_vstokes" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_hstokes" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_melth" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_meltw" , "will provide") - !call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_fswpen" , "will provide") - else - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mass_of_overlying_sea_ice" , "will provide") - !call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_lev" , "will provide") - endif - - !--------- import fields ------------- - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_salt_rate" , "will provide") ! from ice - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_zonal_moment_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_merid_moment_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_sensi_heat_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_evap_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_lw_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_vis_dir_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_vis_dif_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_ir_dir_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_ir_dif_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_prec_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fprec_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "inst_pres_height_surface" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofl" , "will provide") !-> liquid runoff - call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fresh_water_to_ocean_rate", "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "net_heat_flx_to_ocn" , "will provide") - - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_rate" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_rate" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") - - !--------- export fields ------------- - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_temperature" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "s_surf" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocn_current_zonal" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocn_current_merid" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_slope_zonal" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_slope_merid" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "freezing_melting_potential" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_bldepth" , "will provide") - - do n = 1,fldsToOcn_num - call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, name=fldsToOcn(n)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - enddo - - do n = 1,fldsFrOcn_num - call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, name=fldsFrOcn(n)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - enddo - -end subroutine InitializeAdvertise - -!> Called by NUOPC to realize import and export fields. "Realizing" a field -!! means that its grid has been defined and an ESMF_Field object has been -!! created and put into the import or export State. -!! -!! @param gcomp an ESMF_GridComp object -!! @param importState an ESMF_State object for import fields -!! @param exportState an ESMF_State object for export fields -!! @param clock an ESMF_Clock object -!! @param rc return code -subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) - type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object - type(ESMF_State) :: importState, exportState !< ESMF_State object for - !! import/export fields - type(ESMF_Clock) :: clock !< ESMF_Clock object - integer, intent(out) :: rc !< return code - - ! Local Variables - type(ESMF_VM) :: vm - type(ESMF_Grid) :: gridIn, gridOut - type(ESMF_Mesh) :: Emesh, EmeshTemp - type(ESMF_DeLayout) :: delayout - type(ESMF_Distgrid) :: Distgrid - type(ESMF_DistGridConnection), allocatable :: connectionList(:) - type(ESMF_StateItem_Flag) :: itemFlag - type (ocean_public_type), pointer :: ocean_public => NULL() - type (ocean_state_type), pointer :: ocean_state => NULL() - type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() - type(ocean_grid_type) , pointer :: ocean_grid - type(ocean_internalstate_wrapper) :: ocean_internalstate - integer :: npet, ntiles - integer :: nxg, nyg, cnt - integer :: isc,iec,jsc,jec - integer, allocatable :: xb(:),xe(:),yb(:),ye(:),pe(:) - integer, allocatable :: deBlockList(:,:,:) - integer, allocatable :: petMap(:) - integer, allocatable :: deLabelList(:) - integer, allocatable :: indexList(:) - integer :: ioff, joff - integer :: i, j, n, i1, j1, n1, jlast - integer :: lbnd1,ubnd1,lbnd2,ubnd2 - integer :: lbnd3,ubnd3,lbnd4,ubnd4 - integer :: nblocks_tot - logical :: found - integer(ESMF_KIND_I4), pointer :: dataPtr_mask(:,:) - real(ESMF_KIND_R8), pointer :: dataPtr_area(:,:) - real(ESMF_KIND_R8), pointer :: dataPtr_xcen(:,:) - real(ESMF_KIND_R8), pointer :: dataPtr_ycen(:,:) - real(ESMF_KIND_R8), pointer :: dataPtr_xcor(:,:) - real(ESMF_KIND_R8), pointer :: dataPtr_ycor(:,:) - integer :: mpicom - integer :: localPet - integer :: lsize - integer :: ig,jg, ni,nj,k - integer, allocatable :: gindex(:) ! global index space - character(len=128) :: fldname - character(len=256) :: cvalue - character(len=*), parameter :: subname='(mom_cap:InitializeRealize)' - !-------------------------------- - - rc = ESMF_SUCCESS - - call shr_file_setLogUnit (logunit) - - !---------------------------------------------------------------------------- - ! Get pointers to ocean internal state - !---------------------------------------------------------------------------- - - call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr - ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr - ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr - - !---------------------------------------------------------------------------- - ! Get mpi information - !---------------------------------------------------------------------------- - - call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !--------------------------------- - ! global mom grid size - !--------------------------------- - - call mpp_get_global_domain(ocean_public%domain, xsize=nxg, ysize=nyg) - write(tmpstr,'(a,2i6)') subname//' nxg,nyg = ',nxg,nyg - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !--------------------------------- - ! number of tiles per PET, assumed to be 1, and number of pes (tiles) total - !--------------------------------- - - ntiles=mpp_get_ntile_count(ocean_public%domain) ! this is tiles on this pe - if (ntiles /= 1) then - rc = ESMF_FAILURE - call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - ntiles=mpp_get_domain_npes(ocean_public%domain) - write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - !--------------------------------- - ! get start and end indices of each tile and their PET - !--------------------------------- - - allocate(xb(ntiles),xe(ntiles),yb(ntiles),ye(ntiles),pe(ntiles)) - call mpp_get_compute_domains(ocean_public%domain, xbegin=xb, xend=xe, ybegin=yb, yend=ye) - call mpp_get_pelist(ocean_public%domain, pe) - if (debug > 0) then - do n = 1,ntiles - write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - enddo - endif - - !--------------------------------- - ! Create either a grid or a mesh - !--------------------------------- - - !Get the ocean grid and sizes of global and computational domains - call get_ocean_grid(ocean_state, ocean_grid) - - if (geomtype == ESMF_GEOMTYPE_MESH) then - - !--------------------------------- - ! Create a MOM6 mesh - !--------------------------------- - - call get_global_grid_size(ocean_grid, ni, nj) - lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) - - ! Create the global index space for the computational domain - allocate(gindex(lsize)) - k = 0 - do j = ocean_grid%jsc, ocean_grid%jec - jg = j + ocean_grid%jdg_offset - do i = ocean_grid%isc, ocean_grid%iec - ig = i + ocean_grid%idg_offset - k = k + 1 ! Increment position within gindex - gindex(k) = ni * (jg - 1) + ig - enddo - enddo - - DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - ! read in the mesh - call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - if (localPet == 0) then - write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) - endif - - ! recreate the mesh using the above distGrid - EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - ! realize the import and export fields using the mesh - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - !--------------------------------- - ! create a MOM6 grid - !--------------------------------- - - ! generate delayout and dist_grid - - allocate(deBlockList(2,2,ntiles)) - allocate(petMap(ntiles)) - allocate(deLabelList(ntiles)) - - do n = 1, ntiles - deLabelList(n) = n - deBlockList(1,1,n) = xb(n) - deBlockList(1,2,n) = xe(n) - deBlockList(2,1,n) = yb(n) - deBlockList(2,2,n) = ye(n) - petMap(n) = pe(n) - ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side - enddo - - delayout = ESMF_DELayoutCreate(petMap, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! rsd this assumes tripole grid, but sometimes in CESM a bipole - ! grid is used -- need to introduce conditional logic here - - allocate(connectionList(2)) - - ! bipolar boundary condition at top row: nyg - call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & - tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & - orientationVector=(/-1, -2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! periodic boundary condition along first dimension - call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & - tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & - ! indexflag = ESMF_INDEX_DELOCAL, & - deBlockList=deBlockList, & - ! deLabelList=deLabelList, & - delayout=delayout, & - connectionList=connectionList, & - rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - deallocate(xb,xe,yb,ye,pe) - deallocate(connectionList) - deallocate(deLabelList) - deallocate(deBlockList) - deallocate(petMap) - - call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - allocate(indexList(cnt)) - write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& - indexList(1),indexList(cnt),minval(indexList), maxval(indexList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - deallocate(IndexList) - - ! create grid - - gridIn = ESMF_GridCreate(distgrid=distgrid, & - gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & - coordSys = ESMF_COORDSYS_SPH_DEG, & - rc = rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - - call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & - staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - ! Attach area to the Grid optionally. By default the cell areas are computed. - if(grid_attach_area) then - call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & - staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - endif - - call ESMF_GridGetCoord(gridIn, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_xcen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call ESMF_GridGetCoord(gridIn, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_ycen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - - call ESMF_GridGetCoord(gridIn, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=dataPtr_xcor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call ESMF_GridGetCoord(gridIn, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=dataPtr_ycor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_mask, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - if(grid_attach_area) then - call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_area, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif - - ! load up area, mask, center and corner values - ! area, mask, and centers should be same size in mom and esmf grid - ! corner points may not be, need to offset corner points by 1 in i and j - ! retrieve these values directly from ocean_grid, which contains halo - ! values for j=0 and wrap-around in i. on tripole seam, decomposition - ! domains are 1 larger in j; to load corner values need to loop one extra row - - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - - lbnd1 = lbound(dataPtr_mask,1) - ubnd1 = ubound(dataPtr_mask,1) - lbnd2 = lbound(dataPtr_mask,2) - ubnd2 = ubound(dataPtr_mask,2) - - lbnd3 = lbound(dataPtr_xcor,1) - ubnd3 = ubound(dataPtr_xcor,1) - lbnd4 = lbound(dataPtr_xcor,2) - ubnd4 = ubound(dataPtr_xcor,2) - - write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=SUBNAME//": fld and grid do not have the same size.", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - - do j = jsc, jec - j1 = j + lbnd2 - jsc - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - ig = i + ocean_grid%isc - isc - dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) - dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) - dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) - if(grid_attach_area) then - dataPtr_area(i1,j1) = ocean_grid%areaT(ig,jg) - endif - enddo - enddo - - jlast = jec - if(jec == nyg)jlast = jec+1 - - do j = jsc, jlast - j1 = j + lbnd4 - jsc - jg = j + ocean_grid%jsc - jsc - 1 - do i = isc, iec - i1 = i + lbnd3 - isc - ig = i + ocean_grid%isc - isc - 1 - dataPtr_xcor(i1,j1) = ocean_grid%geolonBu(ig,jg) - dataPtr_ycor(i1,j1) = ocean_grid%geolatBu(ig,jg) - enddo - enddo - - write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - if(grid_attach_area) then - write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - endif - - write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - - gridOut = gridIn ! for now out same as in - - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - endif - - !--------------------------------- - ! set scalar data in export state - !--------------------------------- - - if (len_trim(scalar_field_name) > 0) then - call State_SetScalar(dble(nxg),scalar_field_idx_grid_nx, exportState, localPet, & - scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call State_SetScalar(dble(nyg),scalar_field_idx_grid_ny, exportState, localPet, & - scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - endif - - !--------------------------------- - ! Set module variable geomtype in mom_cap_methods - !--------------------------------- - call mom_set_geomtype(geomtype) - - !--------------------------------- - ! write out diagnostics - !--------------------------------- - - !call NUOPC_Write(exportState, fileNamePrefix='post_realize_field_ocn_export_', & - ! timeslice=1, relaxedFlag=.true., rc=rc) - !if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out - -end subroutine InitializeRealize - -!> TODO -!! -!! @param gcomp an ESMF_GridComp object -!! @param rc return code -subroutine DataInitialize(gcomp, rc) - type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object - integer, intent(out) :: rc !< return code - - ! local variables - type(ESMF_Clock) :: clock - type(ESMF_State) :: importState, exportState - type (ocean_public_type), pointer :: ocean_public => NULL() - type (ocean_state_type), pointer :: ocean_state => NULL() - type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() - type(ocean_internalstate_wrapper) :: ocean_internalstate - type(ocean_grid_type), pointer :: ocean_grid - character(240) :: msgString - integer :: fieldCount, n - type(ESMF_Field) :: field - character(len=64),allocatable :: fieldNameList(:) - character(len=*),parameter :: subname='(mom_cap:DataInitialize)' - !-------------------------------- - - ! query the Component for its clock, importState and exportState - call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr - ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr - ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr - call get_ocean_grid(ocean_state, ocean_grid) - - if (cesm_coupled) then - call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - - call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - allocate(fieldNameList(fieldCount)) - call ESMF_StateGet(exportState, itemNameList=fieldNameList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - do n=1, fieldCount - call ESMF_StateGet(exportState, itemName=fieldNameList(n), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - enddo - deallocate(fieldNameList) - - ! check whether all Fields in the exportState are "Updated" - if (NUOPC_IsUpdated(exportState)) then - call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) - - call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - - if(write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_init_ocn_export_', & - timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - -end subroutine DataInitialize - -!> Called by NUOPC to advance the model a single timestep. -!! -!! @param gcomp an ESMF_GridComp object -!! @param rc return code -subroutine ModelAdvance(gcomp, rc) - type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object - integer, intent(out) :: rc !< return code - - ! local variables - integer :: userRc - logical :: existflag, isPresent, isSet - logical :: do_advance = .true. - type(ESMF_Clock) :: clock!< ESMF Clock class definition - type(ESMF_Alarm) :: alarm - type(ESMF_State) :: importState, exportState - type(ESMF_Time) :: currTime - type(ESMF_TimeInterval) :: timeStep - type(ESMF_Time) :: startTime - type(ESMF_TimeInterval) :: time_elapsed - integer(ESMF_KIND_I8) :: n_interval, time_elapsed_sec - character(len=64) :: timestamp - type (ocean_public_type), pointer :: ocean_public => NULL() - type (ocean_state_type), pointer :: ocean_state => NULL() - type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() - type(ocean_internalstate_wrapper) :: ocean_internalstate - type(ocean_grid_type) , pointer :: ocean_grid - type(time_type) :: Time - type(time_type) :: Time_step_coupled - type(time_type) :: Time_restart_current - integer :: dth, dtm, dts - integer :: nc - type(ESMF_Time) :: MyTime - integer :: seconds, day, year, month, hour, minute - character(ESMF_MAXSTR) :: restartname, cvalue - character(240) :: msgString - character(len=*),parameter :: subname='(mom_cap:ModelAdvance)' - - rc = ESMF_SUCCESS - if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") - - call shr_file_setLogUnit (logunit) - - ! query the Component for its clock, importState and exportState - call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, & - exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr - ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr - ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr - - ! HERE THE MODEL ADVANCES: currTime -> currTime + timeStep - - call ESMF_ClockPrint(clock, options="currTime", & - preString="------>Advancing OCN from: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, & - timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_TimePrint(currTime + timeStep, & - preString="--------------------------------> to: ", & - unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - Time_step_coupled = esmf2fms_time(timeStep) - Time = esmf2fms_time(currTime) - - !--------------- - ! Apply ocean lag for startup runs: - !--------------- - - if (cesm_coupled) then - if (trim(runtype) == "initial") then - - ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run - if (currTime == startTime) then - call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - do_advance = .false. - else - do_advance = .true. - endif - - ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps - if (currTime == startTime + timeStep) then - call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - Time_step_coupled = 2 * esmf2fms_time(timeStep) - endif - endif - endif - - - !--------------- - ! Write diagnostics for import - !--------------- - - if(write_diagnostics) then - call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & - timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - import_slice = import_slice + 1 - endif - - !--------------- - ! Get ocean grid - !--------------- - - call get_ocean_grid(ocean_state, ocean_grid) - - !--------------- - ! Import data - !--------------- - - call shr_file_setLogUnit (logunit) - - if (cesm_coupled) then - call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, runtype=runtype, rc=rc) - else - call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - endif - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !--------------- - ! Update MOM6 - !--------------- - - if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") - if (do_advance) then - call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled) - endif - if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") - - !--------------- - ! Export Data - !--------------- - - call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call shr_file_setLogUnit (logunit) - - !--------------- - ! If restart alarm is ringing - write restart file - !--------------- - - call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_AlarmRingerOff(alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! call into system specific method to get desired restart filename - restartname = "" - call ESMF_MethodExecute(gcomp, label="GetRestartFileToWrite", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (existflag) then - call ESMF_LogWrite("mom_cap: called user GetRestartFileToWrite method", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToWrite', & - isPresent=isPresent, isSet=isSet, value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - restartname = trim(cvalue) - call ESMF_LogWrite("mom_cap: User RestartFileToWrite: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - endif - - if (len_trim(restartname) == 0) then - ! none provided, so use a default restart filename - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, & - h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & - "ocn", year, month, day, hour, minute, seconds - call ESMF_LogWrite("mom_cap: Using default restart filename: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - - ! TODO: address if this requirement is being met for the DA group - ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval - ! if (restart_interval > 0 ) then - ! time_elapsed = currTime - startTime - ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) - ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out - ! n_interval = time_elapsed_sec / restart_interval - ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then - ! time_restart_current = esmf2fms_time(currTime) - ! timestamp = date_to_string(time_restart_current) - ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) - ! write(*,*) 'calling ocean_model_restart' - ! call ocean_model_restart(ocean_state, timestamp) - ! endif - ! endif - - ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) - - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif - endif - - !--------------- - ! Write diagnostics - !--------------- - - if (write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & - timeslice=export_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - export_slice = export_slice + 1 - endif - - if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") - -end subroutine ModelAdvance - - -subroutine ModelSetRunClock(gcomp, rc) - type(ESMF_GridComp) :: gcomp - integer, intent(out) :: rc - - ! local variables - type(ESMF_Clock) :: mclock, dclock - type(ESMF_Time) :: mcurrtime, dcurrtime - type(ESMF_Time) :: mstoptime - type(ESMF_TimeInterval) :: mtimestep, dtimestep - character(len=128) :: mtimestring, dtimestring - character(len=256) :: cvalue - character(len=256) :: restart_option ! Restart option units - integer :: restart_n ! Number until restart interval - integer :: restart_ymd ! Restart date (YYYYMMDD) - type(ESMF_ALARM) :: restart_alarm - logical :: isPresent, isSet - logical :: first_time = .true. - character(len=*),parameter :: subname='mom_cap:(ModelSetRunClock) ' - !-------------------------------- - - rc = ESMF_SUCCESS - - ! query the Component for its clock, importState and exportState - call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !-------------------------------- - ! check that the current time in the model and driver are the same - !-------------------------------- - - if (mcurrtime /= dcurrtime) then - call ESMF_TimeGet(dcurrtime, timeString=dtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_TimeGet(mcurrtime, timeString=mtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & - msg=subname//": ERROR in time consistency: "//trim(dtimestring)//" != "//trim(mtimestring), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - - !-------------------------------- - ! force model clock currtime and timestep to match driver and set stoptime - !-------------------------------- - - mstoptime = mcurrtime + dtimestep - - call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - if (first_time) then - !-------------------------------- - ! set restart alarm - !-------------------------------- - - ! defaults - restart_n = 0 - restart_ymd = 0 - - call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, & - isSet=isSet, value=restart_option, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - read(cvalue,*) restart_n - endif - call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - read(cvalue,*) restart_ymd - endif - else - restart_option = "none" - endif - - call AlarmInit(mclock, & - alarm = restart_alarm, & - option = trim(restart_option), & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mcurrTime, & - alarmname = 'alarm_restart', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - first_time = .false. - - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & - ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - endif - - !-------------------------------- - ! Advance model clock to trigger alarms then reset model clock back to currtime - !-------------------------------- - - call ESMF_ClockAdvance(mclock,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - -end subroutine ModelSetRunClock - - -!=============================================================================== - -!> Called by NUOPC at the end of the run to clean up. -!! -!! @param gcomp an ESMF_GridComp object -!! @param rc return code -subroutine ocean_model_finalize(gcomp, rc) - - type(ESMF_GridComp) :: gcomp !< ESMF_GridComp object - integer, intent(out) :: rc !< return code - - ! local variables - type (ocean_public_type), pointer :: ocean_public - type (ocean_state_type), pointer :: ocean_state - type(ocean_internalstate_wrapper) :: ocean_internalstate - type(TIME_TYPE) :: Time - type(ESMF_Clock) :: clock - type(ESMF_Time) :: currTime - character(len=64) :: timestamp - character(len=*),parameter :: subname='(mom_cap:ocean_model_finalize)' - - write(*,*) 'MOM: --- finalize called ---' - rc = ESMF_SUCCESS - - call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr - ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr - - call NUOPC_ModelGet(gcomp, modelClock=clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_ClockGet(clock, currTime=currTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - Time = esmf2fms_time(currTime) - - if (cesm_coupled) then - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.false.) - else - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.true.) - endif - call field_manager_end() - - call fms_io_exit() - call fms_end() - - write(*,*) 'MOM: --- completed ---' - -end subroutine ocean_model_finalize - - -!> Set scalar data from state for a particula name -subroutine State_SetScalar(value, scalar_id, State, mytask, scalar_name, scalar_count, rc) - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(in) :: scalar_id - type(ESMF_State), intent(inout) :: State - integer, intent(in) :: mytask - character(len=*), intent(in) :: scalar_name - integer, intent(in) :: scalar_count - integer, intent(inout) :: rc !< return code - - ! local variables - type(ESMF_Field) :: field - real(ESMF_KIND_R8), pointer :: farrayptr(:,:) - character(len=*), parameter :: subname='(mom_cap:State_SetScalar)' - !-------------------------------------------------------- - - rc = ESMF_SUCCESS - - call ESMF_StateGet(State, itemName=trim(scalar_name), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - - if (mytask == 0) then - call ESMF_FieldGet(field, farrayPtr=farrayptr, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - - if (scalar_id < 0 .or. scalar_id > scalar_count) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ERROR in scalar_id", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - - farrayptr(scalar_id,1) = value - endif - -end subroutine State_SetScalar - -!> Realize the import and export fields using either a grid or a mesh. -subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) - type(ESMF_State) , intent(inout) :: state !< ESMF_State object for - !! import/export fields. - integer , intent(in) :: nfields !< Number of fields. - type(fld_list_type) , intent(inout) :: field_defs(:) !< Structure with field's - !! information. - character(len=*) , intent(in) :: tag !< Import or export. - type(ESMF_Grid) , intent(in), optional :: grid!< ESMF grid. - type(ESMF_Mesh) , intent(in), optional :: mesh!< ESMF mesh. - integer , intent(inout) :: rc !< Return code. - - ! local variables - integer :: i - type(ESMF_Field) :: field - real(ESMF_KIND_R8), pointer :: fldptr1d(:) ! for mesh - real(ESMF_KIND_R8), pointer :: fldptr2d(:,:) ! for grid - character(len=*),parameter :: subname='(mom_cap:MOM_RealizeFields)' - !-------------------------------------------------------- - - rc = ESMF_SUCCESS - - do i = 1, nfields - - if (NUOPC_IsConnected(state, fieldName=field_defs(i)%shortname)) then - - if (field_defs(i)%shortname == scalar_field_name) then - - call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) - - call SetScalarField(field, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - else - - call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) - - if (present(grid)) then - - field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & - name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! initialize fldptr to zero - call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - fldptr2d(:,:) = 0.0 - - else if (present(mesh)) then - - field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & - name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! initialize fldptr to zero - call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - fldptr1d(:) = 0.0 - - endif - - endif - - ! Realize connected field - call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - else ! field is not connected - - call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) - ! remove a not connected Field from State - call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - endif - - enddo - -contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine SetScalarField(field, rc) - - ! create a field with scalar data on the root pe - type(ESMF_Field), intent(inout) :: field - integer, intent(inout) :: rc - - ! local variables - type(ESMF_Distgrid) :: distgrid - type(ESMF_Grid) :: grid - character(len=*), parameter :: subname='(mom_cap:SetScalarField)' - - rc = ESMF_SUCCESS - - ! create a DistGrid with a single index space element, which gets mapped onto DE 0. - distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - grid = ESMF_GridCreate(distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! num of scalar values - field = ESMF_FieldCreate(name=trim(scalar_field_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & - ungriddedLBound=(/1/), ungriddedUBound=(/scalar_field_count/), gridToFieldMap=(/2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - end subroutine SetScalarField - -end subroutine MOM_RealizeFields - -!=============================================================================== - -!> Set up list of field information -subroutine fld_list_add(num, fldlist, stdname, transferOffer, shortname) - integer, intent(inout) :: num - type(fld_list_type), intent(inout) :: fldlist(:) - character(len=*), intent(in) :: stdname - character(len=*), intent(in) :: transferOffer - character(len=*), optional, intent(in) :: shortname - - ! local variables - integer :: rc - character(len=*), parameter :: subname='(mom_cap:fld_list_add)' - - ! fill in the new entry - num = num + 1 - if (num > fldsMax) then - call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & - msg=trim(subname)//": ERROR number of field exceeded fldsMax: "//trim(stdname), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - - fldlist(num)%stdname = trim(stdname) - if (present(shortname)) then - fldlist(num)%shortname = trim(shortname) - else - fldlist(num)%shortname = trim(stdname) - endif - fldlist(num)%transferOffer = trim(transferOffer) - -end subroutine fld_list_add - - -#ifndef CESMCOUPLED -subroutine shr_file_setLogUnit(nunit) - integer, intent(in) :: nunit - ! do nothing for this stub - its just here to replace - ! having cppdefs in the main program -end subroutine shr_file_setLogUnit - -subroutine shr_file_getLogUnit(nunit) - integer, intent(in) :: nunit - ! do nothing for this stub - its just here to replace - ! having cppdefs in the main program -end subroutine shr_file_getLogUnit -#endif - -end module mom_cap_mod diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 deleted file mode 100644 index e6bdbea307..0000000000 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ /dev/null @@ -1,869 +0,0 @@ -!> Contains import/export methods for both NEMS and CMEPS. -module mom_cap_methods - -use ESMF, only: ESMF_Clock, ESMF_ClockGet, ESMF_time, ESMF_TimeGet -use ESMF, only: ESMF_TimeInterval, ESMF_TimeIntervalGet -use ESMF, only: ESMF_State, ESMF_StateGet -use ESMF, only: ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate -use ESMF, only: ESMF_GridComp, ESMF_Mesh, ESMF_Grid, ESMF_GridCreate -use ESMF, only: ESMF_DistGrid, ESMF_DistGridCreate -use ESMF, only: ESMF_KIND_R8, ESMF_SUCCESS, ESMF_LogFoundError -use ESMF, only: ESMF_LOGERR_PASSTHRU, ESMF_LOGMSG_INFO, ESMF_LOGWRITE -use ESMF, only: ESMF_LogSetError, ESMF_RC_MEM_ALLOCATE -use ESMF, only: ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND -use ESMF, only: ESMF_GEOMTYPE_FLAG, ESMF_GEOMTYPE_GRID, ESMF_GEOMTYPE_MESH -use ESMF, only: ESMF_RC_VAL_OUTOFRANGE, ESMF_INDEX_DELOCAL, ESMF_MESHLOC_ELEMENT -use ESMF, only: ESMF_TYPEKIND_R8 -use ESMF, only: operator(/=), operator(==) -use MOM_ocean_model, only: ocean_public_type, ocean_state_type -use MOM_surface_forcing, only: ice_ocean_boundary_type -use MOM_grid, only: ocean_grid_type -use MOM_domains, only: pass_var -use mpp_domains_mod, only: mpp_get_compute_domain - -! By default make data private -implicit none; private - -! Public member functions -public :: mom_set_geomtype -public :: mom_import -public :: mom_export - -private :: State_getImport -private :: State_setExport - -!> Get field pointer -interface State_GetFldPtr - module procedure State_GetFldPtr_1d - module procedure State_GetFldPtr_2d -end interface - -integer :: import_cnt = 0!< used to skip using the import state - !! at the first count for cesm -type(ESMF_GeomType_Flag) :: geomtype !< SMF type describing type of - !! geometry (mesh or grid) - -contains - -!> Sets module variable geometry type -subroutine mom_set_geomtype(geomtype_in) - type(ESMF_GeomType_Flag), intent(in) :: geomtype_in !< ESMF type describing type of - !! geometry (mesh or grid) - - geomtype = geomtype_in - -end subroutine mom_set_geomtype - -!> This function has a few purposes: -!! (1) it imports surface fluxes using data from the mediator; and -!! (2) it can apply restoring in SST and SSS. -subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, runtype, rc) - type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state - type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid - type(ESMF_State) , intent(inout) :: importState !< incoming data from mediator - type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing - character(len=*), optional , intent(in) :: runtype !< For cesm only, type of run - integer , intent(inout) :: rc !< Return code - - ! Local Variables - integer :: i, j, ig, jg, n - integer :: isc, iec, jsc, jec - logical :: do_import - character(len=128) :: fldname - real(ESMF_KIND_R8), allocatable :: taux(:,:) - real(ESMF_KIND_R8), allocatable :: tauy(:,:) - character(len=*) , parameter :: subname = '(mom_import)' - - rc = ESMF_SUCCESS - - ! ------- - ! import_cnt is used to skip using the import state at the first count for cesm - ! ------- - - if (present(runtype)) then - import_cnt = import_cnt + 1 - if ((trim(runtype) == 'initial' .and. import_cnt <= 2)) then - do_import = .false. ! This will skip the first time import information is given - else - do_import = .true. - endif - else - do_import = .true. - endif - - if (do_import) then - ! The following are global indices without halos - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - - !---- - ! surface height pressure - !---- - call state_getimport(importState, 'inst_pres_height_surface', & - isc, iec, jsc, jec, ice_ocean_boundary%p, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! near-IR, direct shortwave (W/m2) - !---- - call state_getimport(importState, 'mean_net_sw_ir_dir_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_nir_dir, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! near-IR, diffuse shortwave (W/m2) - !---- - call state_getimport(importState, 'mean_net_sw_ir_dif_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_nir_dif, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! visible, direct shortwave (W/m2) - !---- - call state_getimport(importState, 'mean_net_sw_vis_dir_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_vis_dir, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! visible, diffuse shortwave (W/m2) - !---- - call state_getimport(importState, 'mean_net_sw_vis_dif_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_vis_dif, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! ------- - ! Net longwave radiation (W/m2) - ! ------- - call state_getimport(importState, 'mean_net_lw_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%lw_flux, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! zonal and meridional surface stress - !---- - allocate (taux(isc:iec,jsc:jec)) - allocate (tauy(isc:iec,jsc:jec)) - - call state_getimport(importState, 'mean_zonal_moment_flx', isc, iec, jsc, jec, taux, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call state_getimport(importState, 'mean_merid_moment_flx', isc, iec, jsc, jec, tauy, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - - ! rotate taux and tauy from true zonal/meridional to local coordinates - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - ice_ocean_boundary%u_flux(i,j) = ocean_grid%cos_rot(ig,jg)*taux(i,j) & - - ocean_grid%sin_rot(ig,jg)*tauy(i,j) - ice_ocean_boundary%v_flux(i,j) = ocean_grid%cos_rot(ig,jg)*tauy(i,j) & - + ocean_grid%sin_rot(ig,jg)*taux(i,j) - enddo - enddo - - deallocate(taux, tauy) - - !---- - ! sensible heat flux (W/m2) - !---- - call state_getimport(importState, 'mean_sensi_heat_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%t_flux, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! evaporation flux (W/m2) - !---- - call state_getimport(importState, 'mean_evap_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%q_flux, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! liquid precipitation (rain) - !---- - call state_getimport(importState, 'mean_prec_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%lprec, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! frozen precipitation (snow) - !---- - call state_getimport(importState, 'mean_fprec_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%fprec, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! runoff and heat content of runoff - !---- - ! Note - preset values to 0, if field does not exist in importState, then will simply return - ! and preset value will be used - - ! liquid runoff - ice_ocean_boundary%rofl_flux (:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'Foxx_rofl', & - isc, iec, jsc, jec, ice_ocean_boundary%rofl_flux,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! ice runoff - ice_ocean_boundary%rofi_flux (:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'Foxx_rofi', & - isc, iec, jsc, jec, ice_ocean_boundary%rofi_flux,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! total runoff - ice_ocean_boundary%runoff (:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_runoff_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%runoff, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! heat content of runoff - ice_ocean_boundary%runoff_hflx(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_runoff_heat_flux', & - isc, iec, jsc, jec, ice_ocean_boundary%runoff_hflx, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! calving rate and heat flux - !---- - ! Note - preset values to 0, if field does not exist in importState, then will simply return - ! and preset value will be used - - ice_ocean_boundary%calving(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_calving_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%calving, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ice_ocean_boundary%calving_hflx(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_calving_heat_flux', & - isc, iec, jsc, jec, ice_ocean_boundary%calving_hflx, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! salt flux from ice - !---- - ice_ocean_boundary%salt_flux(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_salt_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%salt_flux,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! !---- - ! ! snow&ice melt heat flux (W/m^2) - ! !---- - ice_ocean_boundary%seaice_melt_heat(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'net_heat_flx_to_ocn', & - isc, iec, jsc, jec, ice_ocean_boundary%seaice_melt_heat,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! !---- - ! ! snow&ice melt water flux (W/m^2) - ! !---- - ice_ocean_boundary%seaice_melt(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_fresh_water_to_ocean_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%seaice_melt,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! mass of overlying ice - !---- - ! Note - preset values to 0, if field does not exist in importState, then will simply return - ! and preset value will be used - - ice_ocean_boundary%mi(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mass_of_overlying_ice', & - isc, iec, jsc, jec, ice_ocean_boundary%mi, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - endif - -end subroutine mom_import - -!> Maps outgoing ocean data to ESMF State -subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc) - type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state - type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid - type(ocean_state_type) , pointer :: ocean_state !< Ocean state - type(ESMF_State) , intent(inout) :: exportState !< outgoing data - type(ESMF_Clock) , intent(in) :: clock !< ESMF clock - integer , intent(inout) :: rc !< Return code - - ! Local variables - integer :: i, j, ig, jg ! indices - integer :: isc, iec, jsc, jec ! indices - integer :: iloc, jloc ! indices - integer :: iglob, jglob ! indices - integer :: n - integer :: icount - real :: slp_L, slp_R, slp_C - real :: slope, u_min, u_max - integer :: day, secs - type(ESMF_TimeInterval) :: timeStep - integer :: dt_int - real :: inv_dt_int !< The inverse of coupling time interval in s-1. - type(ESMF_StateItem_Flag) :: itemFlag - real(ESMF_KIND_R8), allocatable :: omask(:,:) - real(ESMF_KIND_R8), allocatable :: melt_potential(:,:) - real(ESMF_KIND_R8), allocatable :: ocz(:,:), ocm(:,:) - real(ESMF_KIND_R8), allocatable :: ocz_rot(:,:), ocm_rot(:,:) - real(ESMF_KIND_R8), allocatable :: ssh(:,:) - real(ESMF_KIND_R8), allocatable :: dhdx(:,:), dhdy(:,:) - real(ESMF_KIND_R8), allocatable :: dhdx_rot(:,:), dhdy_rot(:,:) - character(len=*) , parameter :: subname = '(mom_export)' - - rc = ESMF_SUCCESS - - call ESMF_ClockGet( clock, timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_TimeIntervalGet( timeStep, s=dt_int, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! Use Adcroft's rule of reciprocals; it does the right thing here. - if (real(dt_int) > 0.0) then - inv_dt_int = 1.0 / real(dt_int) - else - inv_dt_int = 0.0 - endif - - !---------------- - ! Copy from ocean_public to exportstate. - !---------------- - - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - - ! ------- - ! ocean mask - ! ------- - - allocate(omask(isc:iec, jsc:jec)) - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - omask(i,j) = nint(ocean_grid%mask2dT(ig,jg)) - enddo - enddo - - call State_SetExport(exportState, 'ocean_mask', & - isc, iec, jsc, jec, omask, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - deallocate(omask) - - ! ------- - ! Sea surface temperature - ! ------- - call State_SetExport(exportState, 'sea_surface_temperature', & - isc, iec, jsc, jec, ocean_public%t_surf, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! ------- - ! Sea surface salinity - ! ------- - call State_SetExport(exportState, 's_surf', & - isc, iec, jsc, jec, ocean_public%s_surf, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! ------- - ! zonal and meridional currents - ! ------- - - ! rotate ocn current from tripolar grid back to lat/lon grid x,y => latlon (CCW) - ! "ocean_grid" has halos and uses local indexing. - - allocate(ocz(isc:iec, jsc:jec)) - allocate(ocm(isc:iec, jsc:jec)) - allocate(ocz_rot(isc:iec, jsc:jec)) - allocate(ocm_rot(isc:iec, jsc:jec)) - - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - ocz(i,j) = ocean_public%u_surf(i,j) - ocm(i,j) = ocean_public%v_surf(i,j) - ocz_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocz(i,j) + ocean_grid%sin_rot(ig,jg)*ocm(i,j) - ocm_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocm(i,j) - ocean_grid%sin_rot(ig,jg)*ocz(i,j) - enddo - enddo - - call State_SetExport(exportState, 'ocn_current_zonal', & - isc, iec, jsc, jec, ocz_rot, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call State_SetExport(exportState, 'ocn_current_merid', & - isc, iec, jsc, jec, ocm_rot, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - deallocate(ocz, ocm, ocz_rot, ocm_rot) - - ! ------- - ! Boundary layer depth - ! ------- - call ESMF_StateGet(exportState, 'So_bldepth', itemFlag, rc=rc) - if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - call State_SetExport(exportState, 'So_bldepth', & - isc, iec, jsc, jec, ocean_public%obld, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - - ! ------- - ! Freezing melting potential - ! ------- - ! melt_potential, defined positive for T>Tfreeze, so need to change sign - ! Convert from J/m^2 to W/m^2 and make sure Melt_potential is always <= 0 - - allocate(melt_potential(isc:iec, jsc:jec)) - - do j = jsc,jec - do i = isc,iec - if (ocean_public%frazil(i,j) > 0.0) then - melt_potential(i,j) = ocean_public%frazil(i,j) * inv_dt_int - else - melt_potential(i,j) = -ocean_public%melt_potential(i,j) * inv_dt_int - if (melt_potential(i,j) > 0.0) melt_potential(i,j) = 0.0 - endif - enddo - enddo - - call State_SetExport(exportState, 'freezing_melting_potential', & - isc, iec, jsc, jec, melt_potential, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - deallocate(melt_potential) - - ! ------- - ! Sea level - ! ------- - call ESMF_StateGet(exportState, 'sea_level', itemFlag, rc=rc) - if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - call State_SetExport(exportState, 'sea_level', & - isc, iec, jsc, jec, ocean_public%sea_lev, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif - - !---------------- - ! Sea-surface zonal and meridional slopes - !---------------- - - allocate(ssh(ocean_grid%isd:ocean_grid%ied,ocean_grid%jsd:ocean_grid%jed)) ! local indices with halos - allocate(dhdx(isc:iec, jsc:jec)) !global indices without halos - allocate(dhdy(isc:iec, jsc:jec)) !global indices without halos - allocate(dhdx_rot(isc:iec, jsc:jec)) !global indices without halos - allocate(dhdy_rot(isc:iec, jsc:jec)) !global indices without halos - - ssh = 0.0_ESMF_KIND_R8 - dhdx = 0.0_ESMF_KIND_R8 - dhdy = 0.0_ESMF_KIND_R8 - - ! Make a copy of ssh in order to do a halo update (ssh has local indexing with halos) - do j = ocean_grid%jsc, ocean_grid%jec - jloc = j + ocean_grid%jdg_offset - do i = ocean_grid%isc,ocean_grid%iec - iloc = i + ocean_grid%idg_offset - ssh(i,j) = ocean_public%sea_lev(iloc,jloc) - enddo - enddo - - ! Update halo of ssh so we can calculate gradients (local indexing) - call pass_var(ssh, ocean_grid%domain) - - ! d/dx ssh - ! This is a simple second-order difference - ! dhdx(i,j) = 0.5 * (ssh(i+1,j) - ssh(i-1,j)) * ocean_grid%IdxT(i,j) * ocean_grid%mask2dT(ig,jg) - - do jglob = jsc, jec - j = jglob + ocean_grid%jsc - jsc - do iglob = isc,iec - i = iglob + ocean_grid%isc - isc - ! This is a PLM slope which might be less prone to the A-grid null mode - slp_L = (ssh(I,j) - ssh(I-1,j)) * ocean_grid%mask2dCu(i-1,j) - if (ocean_grid%mask2dCu(i-1,j)==0.) slp_L = 0. - slp_R = (ssh(I+1,j) - ssh(I,j)) * ocean_grid%mask2dCu(i,j) - if (ocean_grid%mask2dCu(i+1,j)==0.) slp_R = 0. - slp_C = 0.5 * (slp_L + slp_R) - if ( (slp_L * slp_R) > 0.0 ) then - ! This limits the slope so that the edge values are bounded by the - ! two cell averages spanning the edge. - u_min = min( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) - u_max = max( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) - slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - endif - dhdx(iglob,jglob) = slope * ocean_grid%IdxT(i,j) * ocean_grid%mask2dT(i,j) - if (ocean_grid%mask2dT(i,j)==0.) dhdx(iglob,jglob) = 0.0 - enddo - enddo - - ! d/dy ssh - ! This is a simple second-order difference - ! dhdy(i,j) = 0.5 * (ssh(i,j+1) - ssh(i,j-1)) * ocean_grid%IdyT(i,j) * ocean_grid%mask2dT(ig,jg) - - do jglob = jsc, jec - j = jglob + ocean_grid%jsc - jsc - do iglob = isc,iec - i = iglob + ocean_grid%isc - isc - ! This is a PLM slope which might be less prone to the A-ocean_grid null mode - slp_L = ssh(i,J) - ssh(i,J-1) * ocean_grid%mask2dCv(i,j-1) - if (ocean_grid%mask2dCv(i,j-1)==0.) slp_L = 0. - slp_R = ssh(i,J+1) - ssh(i,J) * ocean_grid%mask2dCv(i,j) - if (ocean_grid%mask2dCv(i,j+1)==0.) slp_R = 0. - slp_C = 0.5 * (slp_L + slp_R) - if ((slp_L * slp_R) > 0.0) then - ! This limits the slope so that the edge values are bounded by the - ! two cell averages spanning the edge. - u_min = min( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) - u_max = max( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) - slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - endif - dhdy(iglob,jglob) = slope * ocean_grid%IdyT(i,j) * ocean_grid%mask2dT(i,j) - if (ocean_grid%mask2dT(i,j)==0.) dhdy(iglob,jglob) = 0.0 - enddo - enddo - - ! rotate slopes from tripolar grid back to lat/lon grid, x,y => latlon (CCW) - ! "ocean_grid" uses has halos and uses local indexing. - - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - dhdx_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdx(i,j) + ocean_grid%sin_rot(ig,jg)*dhdy(i,j) - dhdy_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdy(i,j) - ocean_grid%sin_rot(ig,jg)*dhdx(i,j) - enddo - enddo - - call State_SetExport(exportState, 'sea_surface_slope_zonal', & - isc, iec, jsc, jec, dhdx_rot, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call State_SetExport(exportState, 'sea_surface_slope_merid', & - isc, iec, jsc, jec, dhdy_rot, ocean_grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - deallocate(ssh, dhdx, dhdy, dhdx_rot, dhdy_rot) - -end subroutine mom_export - -!> Get field pointer 1D -subroutine State_GetFldPtr_1d(State, fldname, fldptr, rc) - type(ESMF_State) , intent(in) :: State !< ESMF state - character(len=*) , intent(in) :: fldname !< Field name - real(ESMF_KIND_R8), pointer , intent(in) :: fldptr(:)!< Pointer to the 1D field - integer, optional , intent(out) :: rc !< Return code - - ! local variables - type(ESMF_Field) :: lfield - integer :: lrc - character(len=*),parameter :: subname='(mom_cap:State_GetFldPtr)' - - call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=lrc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=lrc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - if (present(rc)) rc = lrc - -end subroutine State_GetFldPtr_1d - -!> Get field pointer 2D -subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) - type(ESMF_State) , intent(in) :: State !< ESMF state - character(len=*) , intent(in) :: fldname !< Field name - real(ESMF_KIND_R8), pointer , intent(in) :: fldptr(:,:)!< Pointer to the 2D field - integer, optional , intent(out) :: rc !< Return code - - ! local variables - type(ESMF_Field) :: lfield - integer :: lrc - character(len=*),parameter :: subname='(mom_cap:State_GetFldPtr)' - - call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=lrc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=lrc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - if (present(rc)) rc = lrc - -end subroutine State_GetFldPtr_2d - -!> Map import state field to output array -subroutine State_GetImport(state, fldname, isc, iec, jsc, jec, output, do_sum, rc) - type(ESMF_State) , intent(in) :: state !< ESMF state - character(len=*) , intent(in) :: fldname !< Field name - integer , intent(in) :: isc !< The start i-index of cell centers within - !! the computational domain - integer , intent(in) :: iec !< The end i-index of cell centers within the - !! computational domain - integer , intent(in) :: jsc !< The start j-index of cell centers within - !! the computational domain - integer , intent(in) :: jec !< The end j-index of cell centers within - !! the computational domain - real (ESMF_KIND_R8) , intent(inout) :: output(isc:iec,jsc:jec)!< Output 2D array - logical, optional , intent(in) :: do_sum !< If true, sums the data - integer , intent(out) :: rc !< Return code - - ! local variables - type(ESMF_StateItem_Flag) :: itemFlag - integer :: n, i, j, i1, j1 - integer :: lbnd1,lbnd2 - real(ESMF_KIND_R8), pointer :: dataPtr1d(:) - real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) - character(len=*) , parameter :: subname='(mom_cap_methods:state_getimport)' - ! ---------------------------------------------- - - rc = ESMF_SUCCESS - - call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) - if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - - if (geomtype == ESMF_GEOMTYPE_MESH) then - - ! get field pointer - call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! determine output array - n = 0 - do j = jsc,jec - do i = isc,iec - n = n + 1 - if (present(do_sum)) then - output(i,j) = output(i,j) + dataPtr1d(n) - else - output(i,j) = dataPtr1d(n) - endif - enddo - enddo - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - lbnd1 = lbound(dataPtr2d,1) - lbnd2 = lbound(dataPtr2d,2) - - do j = jsc, jec - j1 = j + lbnd2 - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - if (present(do_sum)) then - output(i,j) = output(i,j) + dataPtr2d(i1,j1) - else - output(i,j) = dataPtr2d(i1,j1) - endif - enddo - enddo - - endif - - endif - -end subroutine State_GetImport - -!> Map input array to export state -subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid, rc) - type(ESMF_State) , intent(inout) :: state !< ESMF state - character(len=*) , intent(in) :: fldname !< Field name - integer , intent(in) :: isc !< The start i-index of cell centers within - !! the computational domain - integer , intent(in) :: iec !< The end i-index of cell centers within the - !! computational domain - integer , intent(in) :: jsc !< The start j-index of cell centers within - !! the computational domain - integer , intent(in) :: jec !< The end j-index of cell centers within - !! the computational domain - real (ESMF_KIND_R8) , intent(in) :: input(isc:iec,jsc:jec)!< Input 2D array - type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean horizontal grid - integer , intent(out) :: rc !< Return code - - ! local variables - type(ESMF_StateItem_Flag) :: itemFlag - integer :: n, i, j, i1, j1, ig,jg - integer :: lbnd1,lbnd2 - real(ESMF_KIND_R8), pointer :: dataPtr1d(:) - real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) - character(len=*) , parameter :: subname='(mom_cap_methods:state_setexport)' - ! ---------------------------------------------- - - rc = ESMF_SUCCESS - - ! Indexing notes: - ! input array from "ocean_public" uses local indexing without halos - ! mask from "ocean_grid" uses local indexing with halos - - call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) - if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - - if (geomtype == ESMF_GEOMTYPE_MESH) then - - call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - n = 0 - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - n = n+1 - dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) - enddo - enddo - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - lbnd1 = lbound(dataPtr2d,1) - lbnd2 = lbound(dataPtr2d,2) - - do j = jsc, jec - j1 = j + lbnd2 - jsc - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - ig = i + ocean_grid%isc - isc - dataPtr2d(i1,j1) = input(i,j) * ocean_grid%mask2dT(ig,jg) - enddo - enddo - - endif - - endif - -end subroutine State_SetExport - -end module mom_cap_methods diff --git a/config_src/nuopc_driver/mom_cap_time.F90 b/config_src/nuopc_driver/mom_cap_time.F90 deleted file mode 100644 index 3f36a131f9..0000000000 --- a/config_src/nuopc_driver/mom_cap_time.F90 +++ /dev/null @@ -1,408 +0,0 @@ -!> This was originally share code in CIME, but required CIME as a -!! dependency to build the MOM cap. The options here for setting -!! a restart alarm are useful for all caps, so a second step is to -!! determine if/how these could be offered more generally in a -!! shared library. For now we really want the MOM cap to only -!! depend on MOM and ESMF/NUOPC. -module mom_cap_time - -! !USES: -use ESMF , only : ESMF_Time, ESMF_Clock, ESMF_Calendar, ESMF_Alarm -use ESMF , only : ESMF_TimeGet, ESMF_TimeSet -use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalSet -use ESMF , only : ESMF_ClockGet, ESMF_AlarmCreate -use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO -use ESMF , only : ESMF_LogSetError, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU -use ESMF , only : ESMF_RC_ARG_BAD -use ESMF , only : operator(<), operator(/=), operator(+), operator(-), operator(*) , operator(>=) -use ESMF , only : operator(<=), operator(>), operator(==) - -implicit none; private - -public :: AlarmInit ! initialize an alarm - -private :: TimeInit -private :: date2ymd - -! Clock and alarm options -character(len=*), private, parameter :: & - optNONE = "none" , & - optNever = "never" , & - optNSteps = "nsteps" , & - optNStep = "nstep" , & - optNSeconds = "nseconds" , & - optNSecond = "nsecond" , & - optNMinutes = "nminutes" , & - optNMinute = "nminute" , & - optNHours = "nhours" , & - optNHour = "nhour" , & - optNDays = "ndays" , & - optNDay = "nday" , & - optNMonths = "nmonths" , & - optNMonth = "nmonth" , & - optNYears = "nyears" , & - optNYear = "nyear" , & - optMonthly = "monthly" , & - optYearly = "yearly" , & - optDate = "date" , & - optIfdays0 = "ifdays0" , & - optGLCCouplingPeriod = "glc_coupling_period" - -! Module data -integer, parameter :: SecPerDay = 86400 ! Seconds per day -character(len=*), parameter :: u_FILE_u = & - __FILE__ - -contains - -!> Setup an alarm in a clock. The ringtime sent to AlarmCreate -!! MUST be the next alarm time. If you send an arbitrary but -!! proper ringtime from the past and the ring interval, the alarm -!! will always go off on the next clock advance and this will cause -!! serious problems. Even if it makes sense to initialize an alarm -!! with some reference time and the alarm interval, that reference -!! time has to be advance forward to be >= the current time. -!! In the logic below we set an appropriate "NextAlarm" and then -!! we make sure to advance it properly based on the ring interval. -subroutine AlarmInit( clock, alarm, option, & - opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) - type(ESMF_Clock) , intent(inout) :: clock !< ESMF clock - type(ESMF_Alarm) , intent(inout) :: alarm !< ESMF alarm - character(len=*) , intent(in) :: option !< alarm option - integer , optional , intent(in) :: opt_n !< alarm freq - integer , optional , intent(in) :: opt_ymd !< alarm ymd - integer , optional , intent(in) :: opt_tod !< alarm tod (sec) - type(ESMF_Time) , optional , intent(in) :: RefTime !< ref time - character(len=*) , optional , intent(in) :: alarmname !< alarm name - integer , intent(inout) :: rc !< Return code - - ! local variables - type(ESMF_Calendar) :: cal ! calendar - integer :: lymd ! local ymd - integer :: ltod ! local tod - integer :: cyy,cmm,cdd,csec ! time info - integer :: nyy,nmm,ndd,nsec ! time info - character(len=64) :: lalarmname ! local alarm name - logical :: update_nextalarm ! update next alarm - type(ESMF_Time) :: CurrTime ! Current Time - type(ESMF_Time) :: NextAlarm ! Next restart alarm time - type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval - character(len=*), parameter :: subname = '(AlarmInit): ' - !------------------------------------------------------------------------------- - - rc = ESMF_SUCCESS - - lalarmname = 'alarm_unknown' - if (present(alarmname)) lalarmname = trim(alarmname) - ltod = 0 - if (present(opt_tod)) ltod = opt_tod - lymd = -1 - if (present(opt_ymd)) lymd = opt_ymd - - ! verify parameters - if (trim(option) == optNSteps .or. trim(option) == optNStep .or. & - trim(option) == optNSeconds .or. trim(option) == optNSecond .or. & - trim(option) == optNMinutes .or. trim(option) == optNMinute .or. & - trim(option) == optNHours .or. trim(option) == optNHour .or. & - trim(option) == optNDays .or. trim(option) == optNDay .or. & - trim(option) == optNMonths .or. trim(option) == optNMonth .or. & - trim(option) == optNYears .or. trim(option) == optNYear .or. & - trim(option) == optIfdays0) then - if (.not. present(opt_n)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_n', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - if (opt_n <= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' invalid opt_n', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - endif - - call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call ESMF_TimeGet(CurrTime, yy=cyy, mm=cmm, dd=cdd, s=csec, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - call ESMF_TimeGet(CurrTime, yy=nyy, mm=nmm, dd=ndd, s=nsec, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - ! initial guess of next alarm, this will be updated below - if (present(RefTime)) then - NextAlarm = RefTime - else - NextAlarm = CurrTime - endif - - ! Determine calendar - call ESMF_ClockGet(clock, calendar=cal, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - - ! Determine inputs for call to create alarm - selectcase (trim(option)) - - case (optNONE, optNever) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - update_nextalarm = .false. - - case (optDate) - if (.not. present(opt_ymd)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_ymd', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - if (lymd < 0 .or. ltod < 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//'opt_ymd, opt_tod invalid', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - update_nextalarm = .false. - - case (optIfdays0) - if (.not. present(opt_ymd)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_ymd', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - update_nextalarm = .true. - - case (optNSteps, optNStep) - call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNSeconds, optNSecond) - call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNMinutes, optNMinute) - call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNHours, optNHour) - call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNDays, optNDay) - call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optNMonths, optNMonth) - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optMonthly) - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - update_nextalarm = .true. - - case (optNYears, optNYear) - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. - - case (optYearly) - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - update_nextalarm = .true. - - case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//' unknown option: '//trim(option), & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - - end select - - ! -------------------------------------------------------------------------------- - ! --- AlarmInterval and NextAlarm should be set --- - ! -------------------------------------------------------------------------------- - - ! --- advance Next Alarm so it won't ring on first timestep for - ! --- most options above. go back one alarminterval just to be careful - - if (update_nextalarm) then - NextAlarm = NextAlarm - AlarmInterval - do while (NextAlarm <= CurrTime) - NextAlarm = NextAlarm + AlarmInterval - enddo - endif - - alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, ringInterval=AlarmInterval, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - -end subroutine AlarmInit - -!> Creates the ESMF_Time object corresponding to the given input time, -!! given in YMD (Year Month Day) and TOD (Time-of-day) format. Sets -!! the time by an integer as YYYYMMDD and integer seconds in the day. -subroutine TimeInit( Time, ymd, cal, tod, desc, logunit, rc) - type(ESMF_Time) , intent(inout) :: Time !< ESMF time - integer , intent(in) :: ymd !< year, month, day YYYYMMDD - type(ESMF_Calendar) , intent(in) :: cal !< ESMF calendar - integer , intent(in), optional :: tod !< time of day in [sec] - character(len=*) , intent(in), optional :: desc !< description of time to set - integer , intent(in), optional :: logunit!< Unit for stdout output - integer , intent(out), optional :: rc !< Return code - - ! local varaibles - integer :: yr, mon, day ! Year, month, day as integers - integer :: ltod ! local tod - character(len=256) :: ldesc ! local desc - character(len=*), parameter :: subname = '(TimeInit) ' - !------------------------------------------------------------------------------- - - ltod = 0 - if (present(tod)) ltod = tod - ldesc = '' - if (present(desc)) ldesc = desc - - if ( (ymd < 0) .or. (ltod < 0) .or. (ltod > SecPerDay) )then - if (present(logunit)) then - write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & - 'time-of-day out of bounds', ymd, ltod - endif - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//' yymmdd is negative or time-of-day out of bounds ', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - - call date2ymd (ymd,yr,mon,day) - - call ESMF_TimeSet( Time, yy=yr, mm=mon, dd=day, s=ltod, calendar=cal, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - -end subroutine TimeInit - -!> Converts a coded-date (yyyymmdd) into calendar year,month,day. -subroutine date2ymd (date, year, month, day) - integer, intent(in) :: date !< coded-date (yyyymmdd) - integer, intent(out) :: year,month,day !< calendar year,month,day - - ! local variables - integer :: tdate ! temporary date - character(*),parameter :: subName = "(date2ymd)" - !------------------------------------------------------------------------------- - - tdate = abs(date) - year = int(tdate/10000) - if (date < 0) then - year = -year - endif - month = int( mod(tdate,10000)/ 100) - day = mod(tdate, 100) - -end subroutine date2ymd - -end module diff --git a/config_src/nuopc_driver/ocn_comp_nuopc.F90 b/config_src/nuopc_driver/ocn_comp_nuopc.F90 deleted file mode 100644 index 51b8a85c26..0000000000 --- a/config_src/nuopc_driver/ocn_comp_nuopc.F90 +++ /dev/null @@ -1,3 +0,0 @@ -module ocn_comp_nuopc - use mom_cap_mod -end module ocn_comp_nuopc diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 deleted file mode 100644 index be29466e14..0000000000 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ /dev/null @@ -1,271 +0,0 @@ -!> Wind and buoyancy forcing for the Neverland configurations -module Neverland_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data, slasher -use MOM_time_manager, only : time_type, operator(+), operator(/) -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface - -implicit none ; private - -public Neverland_wind_forcing -public Neverland_buoyancy_forcing -public Neverland_surface_forcing_init - -!> This control structure should be used to store any run-time variables -!! associated with the Neverland forcing. -!! -!! It can be readily modified for a specific case, and because it is private there -!! will be no changes needed in other code (although they will have to be recompiled). -type, public :: Neverland_surface_forcing_CS ; private - - logical :: use_temperature !< If true, use temperature and salinity. - logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. - real :: Rho0 !< The density used in the Boussinesq - !! approximation [kg m-3]. - real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: flux_const !< The restoring rate at the surface [m s-1]. - real, dimension(:,:), pointer :: & - buoy_restore(:,:) => NULL() !< The pattern to restore buoyancy to. - character(len=200) :: inputdir !< The directory where NetCDF input files are. - type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the - !! timing of diagnostic output. - logical :: first_call = .true. !< True until Neverland_buoyancy_forcing has been called -end type Neverland_surface_forcing_CS - -contains - -!> Sets the surface wind stresses, forces%taux and forces%tauy for the -!! Neverland forcing configuration. -subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(inout) :: G !< Grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. - - ! Local variables - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: x, y - real :: PI - real :: tau_max, off - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true.) - - ! Set the surface wind stresses, in units of Pa. A positive taux - ! accelerates the ocean to the (pseudo-)east. - - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - PI = 4.0*atan(1.0) - forces%taux(:,:) = 0.0 - tau_max = 0.2 - off = 0.02 - do j=js,je ; do I=is-1,Ieq -! x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon - y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat -! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 - - if (y <= 0.29) then - forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) - endif - if ((y > 0.29) .and. (y <= (0.8-off))) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) - endif - if ((y > (0.8-off)) .and. (y <= (1-off))) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) - endif - enddo ; enddo - - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity, in units of m s-1. ustar - ! is always positive. -! if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie -! ! This expression can be changed if desired, but need not be. -! forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & -! sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & -! 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) -! enddo ; enddo ; endif - -end subroutine Neverland_wind_forcing - -!> Returns the value of a cosine-bell function evaluated at x/L -real function cosbell(x,L) - - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) - - PI = 4.0*atan(1.0) - cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) -end function cosbell - -!> Returns the value of a sin-spike function evaluated at x/L -real function spike(x,L) - - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) - - PI = 4.0*atan(1.0) - spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) -end function spike - - -!> Surface fluxes of buoyancy for the Neverland configurations. -subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< Forcing fields. - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< Forcing time step (s). - type(ocean_grid_type), intent(inout) :: G !< Grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. - ! Local variables - real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. - real :: density_restore ! De - integer :: i, j, is, ie, js, je - integer :: isd, ied, jsd, jed - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - - ! Allocate and zero out the forcing arrays, as necessary. This portion is - ! usually not changed. - if (CS%use_temperature) then - call MOM_error(FATAL, "Neverland_buoyancy_forcing: " // & - "Temperature and salinity mode not coded!" ) - else - ! This is the buoyancy only mode. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - endif - - - ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. - if (CS%restorebuoy .and. CS%first_call) then - call safe_alloc_ptr(CS%buoy_restore, isd, ied, jsd, jed) - CS%first_call = .false. - ! Set CS%buoy_restore(i,j) here - endif - - if ( CS%use_temperature ) then - call MOM_error(FATAL, "Neverland_buoyancy_surface_forcing: " // & - "Temperature/salinity restoring not coded!" ) - else ! This is the buoyancy only mode. - do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean [L2 T-3 ~> m2 s-3]. A positive - ! buoyancy flux is of the same sign as heating the ocean. - fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - call MOM_error(FATAL, "Neverland_buoyancy_surface_forcing: " // & - "Temperature/salinity restoring not coded!" ) - else - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - - ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 - do j=js,je ; do i=is,ie - ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 - - fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) - enddo ; enddo - endif - endif ! end RESTOREBUOY - -end subroutine Neverland_buoyancy_forcing - -!> Initializes the Neverland control structure. -subroutine Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse for - !! model parameter values. - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(Neverland_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure - !! for this module - ! This include declares and sets the variable "version". -#include "version_variable.h" - ! Local variables - character(len=40) :: mdl = "Neverland_surface_forcing" ! This module's name. - - if (associated(CS)) then - call MOM_error(WARNING, "Neverland_surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - CS%diag => diag - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - - call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) -! call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & -! "The background gustiness in the winds.", units="Pa", & -! default=0.02) - - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - ! Convert CS%flux_const from m day-1 to m s-1. - CS%flux_const = CS%flux_const / 86400.0 - endif - -end subroutine Neverland_surface_forcing_init - -end module Neverland_surface_forcing diff --git a/docs/.gitignore b/docs/.gitignore index de2f06d096..e8b6a0513b 100644 --- a/docs/.gitignore +++ b/docs/.gitignore @@ -2,8 +2,17 @@ doxygen doxygen.log APIs +MOM6.tags +details/tutorial + + # Ignore sphinx-build output _build api src xml + + +# Citation output +bib*.aux +citelist.doc* diff --git a/docs/Doxyfile_nortd b/docs/Doxyfile_nortd index e07ce4f0b6..4a81c20bd7 100644 --- a/docs/Doxyfile_nortd +++ b/docs/Doxyfile_nortd @@ -1,4 +1,4 @@ -# Doxyfile 1.8.15 +# Doxyfile 1.8.19 # This file describes the settings to be used by the documentation system # doxygen (www.doxygen.org) for a project. @@ -58,7 +58,7 @@ PROJECT_LOGO = # entered, it will be relative to the location where doxygen was started. If # left blank the current directory will be used. -OUTPUT_DIRECTORY = +OUTPUT_DIRECTORY = . # If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- # directories (in 2 levels) under the output directory of each output format and @@ -187,6 +187,16 @@ SHORT_NAMES = NO JAVADOC_AUTOBRIEF = NO +# If the JAVADOC_BANNER tag is set to YES then doxygen will interpret a line +# such as +# /*************** +# as being the beginning of a Javadoc-style comment "banner". If set to NO, the +# Javadoc-style will behave just like regular comments and it will not be +# interpreted by doxygen. +# The default value is: NO. + +JAVADOC_BANNER = NO + # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # line (until the first dot) of a Qt-style comment as the brief description. If # set to NO, the Qt-style will behave just like regular Qt-style comments (thus @@ -236,15 +246,45 @@ TAB_SIZE = 2 # "Side Effects:". You can put \n's in the value part of an alias to insert # newlines (in the resulting output). You can put ^^ in the value part of an # alias to insert a newline as if a physical newline was in the original file. - -ALIASES = +# When you need a literal { or } or , in the value part of an alias you have to +# escape them by means of a backslash (\), this can lead to conflicts with the +# commands \{ and \} for these it is advised to use the version @{ and @} or use +# a double escape (\\{ and \\}) + +# Reference: https://git.ligo.org/lscsoft/lalsuite-archive/commit/e6e2dae8a73a73979a64854bbf697b077803697a +#ALIASES = "eqref{1}= Eq. \\eqref{\1}" \ +# "figref{1}= Fig. [\ref \1]" \ +# "tableref{1}= Table [\ref \1]" \ +# "figure{4}= \anchor \1 \image html \1.png \"Fig. [\1]: \4\"" + +# This allows doxygen passthrough of \eqref to html for mathjax +# Single reference within a math block +ALIASES += eqref{1}="\latexonly\ref{\1}\endlatexonly\htmlonly \eqref{\1}\endhtmlonly\xmlonly \\eqref{\1}\endxmlonly" + +# Large math block with multiple references +# TODO: We should be able to overload functions but recursion is happening? For now, the +# second command creates a \eqref2 that is passed to sphinx for processing. This breaks +# the html generation for doxygen +# Doxygen 1.8.13 requires extra help via xmlonly +# See python sphinxcontrib-autodoc_doxygen module autodoc_doxygen/xmlutils.py +# \eqref{eq:ale-thickness-equation,ale-equations,thickness} +ALIASES += eqref{3}="\latexonly\ref{\1}\endlatexonly\htmlonly \eqref2{\2,\3}\endhtmlonly\xmlonly \\eqref4{\1}\\eqref2{\2,\3}\endxmlonly" + +# Reference: https://stackoverflow.com/questions/25290453/how-do-i-add-a-footnote-in-doxygen +# TODO: Use this simple js library to create actual footnotes in html +# Reference: https://github.com/jheftmann/footnoted +ALIASES += footnote{1}="\latexonly\footnote\{\1\}\endlatexonly\htmlonly[*]\endhtmlonly\xmlonly[*]\endxmlonly" + +# \image latex does the wrong things to support equations in captions, this recreates +# what it does and just passes through the string uninterpreted. +# The image also needs to be added to LATEX_EXTRA_FILES. +# Default 3rd argument: \includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true] +ALIASES += imagelatex{3}="\latexonly\begin{DoxyImage}\3{\1}\doxyfigcaption{\2}\end{DoxyImage}\endlatexonly\xmlonly\2\endxmlonly" # This tag can be used to specify a number of word-keyword mappings (TCL only). # A mapping has the form "name=value". For example adding "class=itcl::class" # will allow you to use the command class in the itcl::class meaning. -TCL_SUBST = - # Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources # only. Doxygen will then generate output that is more tailored for C. For # instance, some of the names that are used will be different. The list of all @@ -273,17 +313,26 @@ OPTIMIZE_FOR_FORTRAN = YES OPTIMIZE_OUTPUT_VHDL = NO +# Set the OPTIMIZE_OUTPUT_SLICE tag to YES if your project consists of Slice +# sources only. Doxygen will then generate output that is more tailored for that +# language. For instance, namespaces will be presented as modules, types will be +# separated into more groups, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_SLICE = NO + # Doxygen selects the parser to use depending on the extension of the files it # parses. With this tag you can assign which parser to use for a given # extension. Doxygen has a built-in mapping, but you can override or extend it # using this tag. The format is ext=language, where ext is a file extension, and -# language is one of the parsers supported by doxygen: IDL, Java, Javascript, -# C#, C, C++, D, PHP, Objective-C, Python, Fortran (fixed format Fortran: -# FortranFixed, free formatted Fortran: FortranFree, unknown formatted Fortran: -# Fortran. In the later case the parser tries to guess whether the code is fixed -# or free formatted code, this is the default for Fortran type files), VHDL. For -# instance to make doxygen treat .inc files as Fortran files (default is PHP), -# and .f files as C (default is Fortran), use: inc=Fortran f=C. +# language is one of the parsers supported by doxygen: IDL, Java, JavaScript, +# Csharp (C#), C, C++, D, PHP, md (Markdown), Objective-C, Python, Slice, VHDL, +# Fortran (fixed format Fortran: FortranFixed, free formatted Fortran: +# FortranFree, unknown formatted Fortran: Fortran. In the later case the parser +# tries to guess whether the code is fixed or free formatted code, this is the +# default for Fortran type files). For instance to make doxygen treat .inc files +# as Fortran files (default is PHP), and .f files as C (default is Fortran), +# use: inc=Fortran f=C. # # Note: For files without extension you can use no_extension as a placeholder. # @@ -294,7 +343,7 @@ EXTENSION_MAPPING = # If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments # according to the Markdown format, which allows for more readable -# documentation. See http://daringfireball.net/projects/markdown/ for details. +# documentation. See https://daringfireball.net/projects/markdown/ for details. # The output of markdown processing is further processed by doxygen, so you can # mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in # case of backward compatibilities issues. @@ -306,7 +355,7 @@ MARKDOWN_SUPPORT = YES # to that level are automatically included in the table of contents, even if # they do not have an id attribute. # Note: This feature currently applies only to Markdown headings. -# Minimum value: 0, maximum value: 99, default value: 0. +# Minimum value: 0, maximum value: 99, default value: 5. # This tag requires that the tag MARKDOWN_SUPPORT is set to YES. TOC_INCLUDE_HEADINGS = 0 @@ -422,6 +471,19 @@ TYPEDEF_HIDES_STRUCT = NO LOOKUP_CACHE_SIZE = 0 +# The NUM_PROC_THREADS specifies the number threads doxygen is allowed to use +# during processing. When set to 0 doxygen will based this on the number of +# cores available in the system. You can set it explicitly to a value larger +# than 0 to get more control over the balance between CPU load and processing +# speed. At this moment only the input processing can be done using multiple +# threads. Since this is still an experimental feature the default is set to 1, +# which efficively disables parallel processing. Please report any issues you +# encounter. Generating dot graphs in parallel is controlled by the +# DOT_NUM_THREADS setting. +# Minimum value: 0, maximum value: 32, default value: 1. + +NUM_PROC_THREADS = 1 + #--------------------------------------------------------------------------- # Build related configuration options #--------------------------------------------------------------------------- @@ -442,6 +504,12 @@ EXTRACT_ALL = NO EXTRACT_PRIVATE = YES +# If the EXTRACT_PRIV_VIRTUAL tag is set to YES, documented private virtual +# methods of a class will be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIV_VIRTUAL = NO + # If the EXTRACT_PACKAGE tag is set to YES, all members with package or internal # scope will be included in the documentation. # The default value is: NO. @@ -496,8 +564,8 @@ HIDE_UNDOC_MEMBERS = NO HIDE_UNDOC_CLASSES = NO # If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend -# (class|struct|union) declarations. If set to NO, these declarations will be -# included in the documentation. +# declarations. If set to NO, these declarations will be included in the +# documentation. # The default value is: NO. HIDE_FRIEND_COMPOUNDS = NO @@ -520,7 +588,7 @@ INTERNAL_DOCS = YES # names in lower-case letters. If set to YES, upper-case letters are also # allowed. This is useful if you have classes or files whose names only differ # in case and if your file system supports case sensitive file names. Windows -# and Mac users are advised to set this option to NO. +# (including Cygwin) and Mac users are advised to set this option to NO. # The default value is: system dependent. CASE_SENSE_NAMES = YES @@ -712,7 +780,7 @@ LAYOUT_FILE = layout.xml # LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the # search path. See also \cite for info how to create references. -CITE_BIB_FILES = +CITE_BIB_FILES = ocean.bib references.bib zotero.bib #--------------------------------------------------------------------------- # Configuration options related to warning and progress messages @@ -778,7 +846,7 @@ WARN_FORMAT = "$file:$line: $text" # messages should be written. If left blank the output is written to standard # error (stderr). -WARN_LOGFILE = doxygen.log +WARN_LOGFILE = _build/doxygen_warn_nortd_log.txt #--------------------------------------------------------------------------- # Configuration options related to the input files @@ -792,9 +860,10 @@ WARN_LOGFILE = doxygen.log INPUT = ../src \ front_page.md \ - ../config_src/solo_driver \ - ../config_src/dynamic_symmetric - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/drivers/solo_driver \ + ../config_src/memory/dynamic_symmetric \ + ../config_src/external \ + ../config_src/drivers/FMS_cap # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses @@ -816,28 +885,58 @@ INPUT_ENCODING = UTF-8 # If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, # *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, # *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, -# *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, -# *.f, *.for, *.tcl, *.vhd, *.vhdl, *.ucf and *.qsf. +# *.m, *.markdown, *.md, *.mm, *.dox (to be provided as doxygen C comment), +# *.doc (to be provided as doxygen C comment), *.txt (to be provided as doxygen +# C comment), *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, *.f18, *.f, *.for, *.vhd, +# *.vhdl, *.ucf, *.qsf and *.ice. FILE_PATTERNS = *.c \ *.cc \ *.cxx \ *.cpp \ *.c++ \ + *.java \ + *.ii \ + *.ixx \ + *.ipp \ + *.i++ \ + *.inl \ + *.idl \ + *.ddl \ + *.odl \ *.h \ *.hh \ *.hxx \ *.hpp \ *.h++ \ + *.cs \ + *.d \ + *.php \ + *.php4 \ + *.php5 \ + *.phtml \ *.inc \ *.m \ *.markdown \ *.md \ *.mm \ *.dox \ + *.doc \ + *.txt \ + *.py \ + *.pyw \ *.f90 \ + *.f95 \ + *.f03 \ + *.f08 \ + *.f18 \ *.f \ *.for \ + *.vhd \ + *.vhdl \ + *.ucf \ + *.qsf \ + *.ice \ *.F90 # The RECURSIVE tag can be used to specify whether or not subdirectories should @@ -1094,7 +1193,7 @@ GENERATE_HTML = YES # The default directory is: html. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_OUTPUT = APIs +HTML_OUTPUT = _build/APIs # The HTML_FILE_EXTENSION tag can be used to specify the file extension for each # generated HTML page (for example: .htm, .php, .asp). @@ -1209,9 +1308,9 @@ HTML_TIMESTAMP = NO # If the HTML_DYNAMIC_MENUS tag is set to YES then the generated HTML # documentation will contain a main index with vertical navigation menus that -# are dynamically created via Javascript. If disabled, the navigation index will +# are dynamically created via JavaScript. If disabled, the navigation index will # consists of multiple levels of tabs that are statically embedded in every HTML -# page. Disable this option to support browsers that do not have Javascript, +# page. Disable this option to support browsers that do not have JavaScript, # like the Qt help browser. # The default value is: YES. # This tag requires that the tag GENERATE_HTML is set to YES. @@ -1241,13 +1340,13 @@ HTML_INDEX_NUM_ENTRIES = 900 # If the GENERATE_DOCSET tag is set to YES, additional index files will be # generated that can be used as input for Apple's Xcode 3 integrated development -# environment (see: https://developer.apple.com/tools/xcode/), introduced with -# OSX 10.5 (Leopard). To create a documentation set, doxygen will generate a +# environment (see: https://developer.apple.com/xcode/), introduced with OSX +# 10.5 (Leopard). To create a documentation set, doxygen will generate a # Makefile in the HTML output directory. Running make will produce the docset in # that directory and running make install will install the docset in # ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at -# startup. See https://developer.apple.com/tools/creatingdocsetswithdoxygen.html -# for more information. +# startup. See https://developer.apple.com/library/archive/featuredarticles/Doxy +# genXcode/_index.html for more information. # The default value is: NO. # This tag requires that the tag GENERATE_HTML is set to YES. @@ -1286,7 +1385,7 @@ DOCSET_PUBLISHER_NAME = Publisher # If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three # additional HTML index files: index.hhp, index.hhc, and index.hhk. The # index.hhp is a project file that can be read by Microsoft's HTML Help Workshop -# (see: http://www.microsoft.com/en-us/download/details.aspx?id=21138) on +# (see: https://www.microsoft.com/en-us/download/details.aspx?id=21138) on # Windows. # # The HTML Help Workshop contains a compiler that can convert all HTML output @@ -1317,7 +1416,7 @@ CHM_FILE = HHC_LOCATION = # The GENERATE_CHI flag controls if a separate .chi index file is generated -# (YES) or that it should be included in the master .chm file (NO). +# (YES) or that it should be included in the main .chm file (NO). # The default value is: NO. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. @@ -1362,7 +1461,7 @@ QCH_FILE = # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help # Project output. For more information please see Qt Help Project / Namespace -# (see: http://doc.qt.io/qt-4.8/qthelpproject.html#namespace). +# (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). # The default value is: org.doxygen.Project. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1370,7 +1469,8 @@ QHP_NAMESPACE = org.doxygen.Project # The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt # Help Project output. For more information please see Qt Help Project / Virtual -# Folders (see: http://doc.qt.io/qt-4.8/qthelpproject.html#virtual-folders). +# Folders (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual- +# folders). # The default value is: doc. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1378,21 +1478,23 @@ QHP_VIRTUAL_FOLDER = doc # If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom # filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://doc.qt.io/qt-4.8/qthelpproject.html#custom-filters). +# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_NAME = # The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the # custom filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://doc.qt.io/qt-4.8/qthelpproject.html#custom-filters). +# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_ATTRS = # The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this # project's filter section matches. Qt Help Project / Filter Attributes (see: -# http://doc.qt.io/qt-4.8/qthelpproject.html#filter-attributes). +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#filter-attributes). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_SECT_FILTER_ATTRS = @@ -1476,6 +1578,17 @@ TREEVIEW_WIDTH = 250 EXT_LINKS_IN_WINDOW = NO +# If the HTML_FORMULA_FORMAT option is set to svg, doxygen will use the pdf2svg +# tool (see https://github.com/dawbarton/pdf2svg) or inkscape (see +# https://inkscape.org) to generate formulas as SVG images instead of PNGs for +# the HTML output. These images will generally look nicer at scaled resolutions. +# Possible values are: png (the default) and svg (looks nicer but requires the +# pdf2svg or inkscape tool). +# The default value is: png. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FORMULA_FORMAT = svg + # Use this tag to change the font size of LaTeX formulas included as images in # the HTML documentation. When you change the font size after a successful # doxygen run you need to manually remove any form_*.png images from the HTML @@ -1496,8 +1609,14 @@ FORMULA_FONTSIZE = 10 FORMULA_TRANSPARENT = YES +# The FORMULA_MACROFILE can contain LaTeX \newcommand and \renewcommand commands +# to create new LaTeX commands to be used in formulas as building blocks. See +# the section "Including formulas" for details. + +FORMULA_MACROFILE = + # Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see -# https://www.mathjax.org) which uses client side Javascript for the rendering +# https://www.mathjax.org) which uses client side JavaScript for the rendering # instead of using pre-rendered bitmaps. Use this if you do not have LaTeX # installed or if you want to formulas look prettier in the HTML output. When # enabled you may also need to install MathJax separately and configure the path @@ -1525,10 +1644,10 @@ MATHJAX_FORMAT = HTML-CSS # Content Delivery Network so you can quickly see the result without installing # MathJax. However, it is strongly recommended to install a local copy of # MathJax from https://www.mathjax.org before deployment. -# The default value is: https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/. +# The default value is: https://cdn.jsdelivr.net/npm/mathjax@2. # This tag requires that the tag USE_MATHJAX is set to YES. -MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest +MATHJAX_RELPATH = https://cdn.jsdelivr.net/npm/mathjax@2 # The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax # extension names that should be enabled during MathJax rendering. For example @@ -1567,7 +1686,7 @@ MATHJAX_CODEFILE = SEARCHENGINE = YES # When the SERVER_BASED_SEARCH tag is enabled the search engine will be -# implemented using a web server instead of a web client using Javascript. There +# implemented using a web server instead of a web client using JavaScript. There # are two flavors of web server based searching depending on the EXTERNAL_SEARCH # setting. When disabled, doxygen will generate a PHP script for searching and # an index file used by the script. When EXTERNAL_SEARCH is enabled the indexing @@ -1662,11 +1781,24 @@ LATEX_CMD_NAME = latex # The MAKEINDEX_CMD_NAME tag can be used to specify the command name to generate # index for LaTeX. +# Note: This tag is used in the Makefile / make.bat. +# See also: LATEX_MAKEINDEX_CMD for the part in the generated output file +# (.tex). # The default file is: makeindex. # This tag requires that the tag GENERATE_LATEX is set to YES. MAKEINDEX_CMD_NAME = makeindex +# The LATEX_MAKEINDEX_CMD tag can be used to specify the command name to +# generate index for LaTeX. In case there is no backslash (\) as first character +# it will be automatically added in the LaTeX code. +# Note: This tag is used in the generated output file (.tex). +# See also: MAKEINDEX_CMD_NAME for the part in the Makefile / make.bat. +# The default value is: makeindex. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_MAKEINDEX_CMD = makeindex + # If the COMPACT_LATEX tag is set to YES, doxygen generates more compact LaTeX # documents. This may be useful for small projects and may help to save some # trees in general. @@ -1694,7 +1826,7 @@ PAPER_TYPE = a4 # If left blank no extra packages will be included. # This tag requires that the tag GENERATE_LATEX is set to YES. -EXTRA_PACKAGES = +EXTRA_PACKAGES =amsmath amstext # The LATEX_HEADER tag can be used to specify a personal LaTeX header for the # generated LaTeX document. The header should contain everything until the first @@ -1740,7 +1872,15 @@ LATEX_EXTRA_STYLESHEET = # markers available. # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_EXTRA_FILES = +# Graphics that have math or equations in the caption need to be listed below. +LATEX_EXTRA_FILES = \ + images/cell_3d.png \ + images/Grid_metrics.png \ + images/h_PPM.png \ + images/Newton_PPM.png \ + images/PG_loop.png \ + images/shao3.png \ + images/shao4.png # If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated is # prepared for conversion to PDF (using ps2pdf or pdflatex). The PDF file will @@ -1751,9 +1891,11 @@ LATEX_EXTRA_FILES = PDF_HYPERLINKS = YES -# If the USE_PDFLATEX tag is set to YES, doxygen will use pdflatex to generate -# the PDF file directly from the LaTeX files. Set this option to YES, to get a -# higher quality PDF documentation. +# If the USE_PDFLATEX tag is set to YES, doxygen will use the engine as +# specified with LATEX_CMD_NAME to generate the PDF file directly from the LaTeX +# files. Set this option to YES, to get a higher quality PDF documentation. +# +# See also section LATEX_CMD_NAME for selecting the engine. # The default value is: YES. # This tag requires that the tag GENERATE_LATEX is set to YES. @@ -1801,6 +1943,14 @@ LATEX_BIB_STYLE = plain LATEX_TIMESTAMP = NO +# The LATEX_EMOJI_DIRECTORY tag is used to specify the (relative or absolute) +# path from which the emoji images will be read. If a relative path is entered, +# it will be relative to the LATEX_OUTPUT directory. If left blank the +# LATEX_OUTPUT directory will be used. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_EMOJI_DIRECTORY = + #--------------------------------------------------------------------------- # Configuration options related to the RTF output #--------------------------------------------------------------------------- @@ -1938,6 +2088,13 @@ XML_OUTPUT = xml XML_PROGRAMLISTING = YES +# If the XML_NS_MEMB_FILE_SCOPE tag is set to YES, doxygen will include +# namespace members in file scope as well, matching the HTML output. +# The default value is: NO. +# This tag requires that the tag GENERATE_XML is set to YES. + +XML_NS_MEMB_FILE_SCOPE = NO + #--------------------------------------------------------------------------- # Configuration options related to the DOCBOOK output #--------------------------------------------------------------------------- @@ -2055,7 +2212,7 @@ SEARCH_INCLUDES = YES # This tag requires that the tag SEARCH_INCLUDES is set to YES. INCLUDE_PATH = ../src/framework \ - ../config_src/dynamic_symmetric + ../config_src/memory/dynamic_symmetric # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the @@ -2117,7 +2274,7 @@ TAGFILES = # tag file that is based on the input files it reads. See section "Linking to # external documentation" for more information about the usage of tag files. -GENERATE_TAGFILE = +GENERATE_TAGFILE = MOM6.tags # If the ALLEXTERNALS tag is set to YES, all external class will be listed in # the class index. If set to NO, only the inherited external classes will be @@ -2140,12 +2297,6 @@ EXTERNAL_GROUPS = YES EXTERNAL_PAGES = YES -# The PERL_PATH should be the absolute path and name of the perl script -# interpreter (i.e. the result of 'which perl'). -# The default file (with absolute path) is: /usr/bin/perl. - -PERL_PATH = /usr/bin/perl - #--------------------------------------------------------------------------- # Configuration options related to the dot tool #--------------------------------------------------------------------------- @@ -2159,15 +2310,6 @@ PERL_PATH = /usr/bin/perl CLASS_DIAGRAMS = YES -# You can define message sequence charts within doxygen comments using the \msc -# command. Doxygen will then run the mscgen tool (see: -# http://www.mcternan.me.uk/mscgen/)) to produce the chart and insert it in the -# documentation. The MSCGEN_PATH tag allows you to specify the directory where -# the mscgen tool resides. If left empty the tool is assumed to be found in the -# default search path. - -MSCGEN_PATH = - # You can include diagrams made with dia in doxygen documentation. Doxygen will # then run dia to produce the diagram and insert it in the documentation. The # DIA_PATH tag allows you to specify the directory where the dia binary resides. diff --git a/docs/Doxyfile_nortd_latex b/docs/Doxyfile_nortd_latex new file mode 100644 index 0000000000..207e645195 --- /dev/null +++ b/docs/Doxyfile_nortd_latex @@ -0,0 +1,2608 @@ +# Doxyfile 1.8.19 + +# This file describes the settings to be used by the documentation system +# doxygen (www.doxygen.org) for a project. +# +# All text after a double hash (##) is considered a comment and is placed in +# front of the TAG it is preceding. +# +# All text after a single hash (#) is considered a comment and will be ignored. +# The format is: +# TAG = value [value, ...] +# For lists, items can also be appended using: +# TAG += value [value, ...] +# Values that contain spaces should be placed between quotes (\" \"). + +#--------------------------------------------------------------------------- +# Project related configuration options +#--------------------------------------------------------------------------- + +# This tag specifies the encoding used for all characters in the configuration +# file that follow. The default is UTF-8 which is also the encoding used for all +# text before the first occurrence of this tag. Doxygen uses libiconv (or the +# iconv built into libc) for the transcoding. See +# https://www.gnu.org/software/libiconv/ for the list of possible encodings. +# The default value is: UTF-8. + +DOXYFILE_ENCODING = UTF-8 + +# The PROJECT_NAME tag is a single word (or a sequence of words surrounded by +# double-quotes, unless you are using Doxywizard) that should identify the +# project for which the documentation is generated. This name is used in the +# title of most generated pages and in a few other places. +# The default value is: My Project. + +PROJECT_NAME = "MOM6" + +# The PROJECT_NUMBER tag can be used to enter a project or revision number. This +# could be handy for archiving the generated documentation or if some version +# control system is used. + +PROJECT_NUMBER = + +# Using the PROJECT_BRIEF tag one can provide an optional one line description +# for a project that appears at the top of each page and should give viewer a +# quick idea about the purpose of the project. Keep the description short. + +PROJECT_BRIEF = + +# With the PROJECT_LOGO tag one can specify a logo or an icon that is included +# in the documentation. The maximum height of the logo should not exceed 55 +# pixels and the maximum width should not exceed 200 pixels. Doxygen will copy +# the logo to the output directory. + +PROJECT_LOGO = + +# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path +# into which the generated documentation will be written. If a relative path is +# entered, it will be relative to the location where doxygen was started. If +# left blank the current directory will be used. + +OUTPUT_DIRECTORY = . + +# If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- +# directories (in 2 levels) under the output directory of each output format and +# will distribute the generated files over these directories. Enabling this +# option can be useful when feeding doxygen a huge amount of source files, where +# putting all generated files in the same directory would otherwise causes +# performance problems for the file system. +# The default value is: NO. + +CREATE_SUBDIRS = NO + +# If the ALLOW_UNICODE_NAMES tag is set to YES, doxygen will allow non-ASCII +# characters to appear in the names of generated files. If set to NO, non-ASCII +# characters will be escaped, for example _xE3_x81_x84 will be used for Unicode +# U+3044. +# The default value is: NO. + +ALLOW_UNICODE_NAMES = NO + +# The OUTPUT_LANGUAGE tag is used to specify the language in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all constant output in the proper language. +# Possible values are: Afrikaans, Arabic, Armenian, Brazilian, Catalan, Chinese, +# Chinese-Traditional, Croatian, Czech, Danish, Dutch, English (United States), +# Esperanto, Farsi (Persian), Finnish, French, German, Greek, Hungarian, +# Indonesian, Italian, Japanese, Japanese-en (Japanese with English messages), +# Korean, Korean-en (Korean with English messages), Latvian, Lithuanian, +# Macedonian, Norwegian, Persian (Farsi), Polish, Portuguese, Romanian, Russian, +# Serbian, Serbian-Cyrillic, Slovak, Slovene, Spanish, Swedish, Turkish, +# Ukrainian and Vietnamese. +# The default value is: English. + +OUTPUT_LANGUAGE = English + +# The OUTPUT_TEXT_DIRECTION tag is used to specify the direction in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all generated output in the proper direction. +# Possible values are: None, LTR, RTL and Context. +# The default value is: None. + +OUTPUT_TEXT_DIRECTION = None + +# If the BRIEF_MEMBER_DESC tag is set to YES, doxygen will include brief member +# descriptions after the members that are listed in the file and class +# documentation (similar to Javadoc). Set to NO to disable this. +# The default value is: YES. + +BRIEF_MEMBER_DESC = YES + +# If the REPEAT_BRIEF tag is set to YES, doxygen will prepend the brief +# description of a member or function before the detailed description +# +# Note: If both HIDE_UNDOC_MEMBERS and BRIEF_MEMBER_DESC are set to NO, the +# brief descriptions will be completely suppressed. +# The default value is: YES. + +REPEAT_BRIEF = YES + +# This tag implements a quasi-intelligent brief description abbreviator that is +# used to form the text in various listings. Each string in this list, if found +# as the leading text of the brief description, will be stripped from the text +# and the result, after processing the whole list, is used as the annotated +# text. Otherwise, the brief description is used as-is. If left blank, the +# following values are used ($name is automatically replaced with the name of +# the entity):The $name class, The $name widget, The $name file, is, provides, +# specifies, contains, represents, a, an and the. + +ABBREVIATE_BRIEF = + +# If the ALWAYS_DETAILED_SEC and REPEAT_BRIEF tags are both set to YES then +# doxygen will generate a detailed section even if there is only a brief +# description. +# The default value is: NO. + +ALWAYS_DETAILED_SEC = NO + +# If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all +# inherited members of a class in the documentation of that class as if those +# members were ordinary class members. Constructors, destructors and assignment +# operators of the base classes will not be shown. +# The default value is: NO. + +INLINE_INHERITED_MEMB = NO + +# If the FULL_PATH_NAMES tag is set to YES, doxygen will prepend the full path +# before files name in the file list and in the header files. If set to NO the +# shortest path that makes the file name unique will be used +# The default value is: YES. + +FULL_PATH_NAMES = YES + +# The STRIP_FROM_PATH tag can be used to strip a user-defined part of the path. +# Stripping is only done if one of the specified strings matches the left-hand +# part of the path. The tag can be used to show relative paths in the file list. +# If left blank the directory from which doxygen is run is used as the path to +# strip. +# +# Note that you can specify absolute paths here, but also relative paths, which +# will be relative from the directory where doxygen is started. +# This tag requires that the tag FULL_PATH_NAMES is set to YES. + +STRIP_FROM_PATH = + +# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the +# path mentioned in the documentation of a class, which tells the reader which +# header file to include in order to use a class. If left blank only the name of +# the header file containing the class definition is used. Otherwise one should +# specify the list of include paths that are normally passed to the compiler +# using the -I flag. + +STRIP_FROM_INC_PATH = + +# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but +# less readable) file names. This can be useful is your file systems doesn't +# support long names like on DOS, Mac, or CD-ROM. +# The default value is: NO. + +SHORT_NAMES = NO + +# If the JAVADOC_AUTOBRIEF tag is set to YES then doxygen will interpret the +# first line (until the first dot) of a Javadoc-style comment as the brief +# description. If set to NO, the Javadoc-style will behave just like regular Qt- +# style comments (thus requiring an explicit @brief command for a brief +# description.) +# The default value is: NO. + +JAVADOC_AUTOBRIEF = NO + +# If the JAVADOC_BANNER tag is set to YES then doxygen will interpret a line +# such as +# /*************** +# as being the beginning of a Javadoc-style comment "banner". If set to NO, the +# Javadoc-style will behave just like regular comments and it will not be +# interpreted by doxygen. +# The default value is: NO. + +JAVADOC_BANNER = NO + +# If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first +# line (until the first dot) of a Qt-style comment as the brief description. If +# set to NO, the Qt-style will behave just like regular Qt-style comments (thus +# requiring an explicit \brief command for a brief description.) +# The default value is: NO. + +QT_AUTOBRIEF = NO + +# The MULTILINE_CPP_IS_BRIEF tag can be set to YES to make doxygen treat a +# multi-line C++ special comment block (i.e. a block of //! or /// comments) as +# a brief description. This used to be the default behavior. The new default is +# to treat a multi-line C++ comment block as a detailed description. Set this +# tag to YES if you prefer the old behavior instead. +# +# Note that setting this tag to YES also means that rational rose comments are +# not recognized any more. +# The default value is: NO. + +MULTILINE_CPP_IS_BRIEF = NO + +# If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the +# documentation from any documented member that it re-implements. +# The default value is: YES. + +INHERIT_DOCS = YES + +# If the SEPARATE_MEMBER_PAGES tag is set to YES then doxygen will produce a new +# page for each member. If set to NO, the documentation of a member will be part +# of the file/class/namespace that contains it. +# The default value is: NO. + +SEPARATE_MEMBER_PAGES = NO + +# The TAB_SIZE tag can be used to set the number of spaces in a tab. Doxygen +# uses this value to replace tabs by spaces in code fragments. +# Minimum value: 1, maximum value: 16, default value: 4. + +TAB_SIZE = 2 + +# This tag can be used to specify a number of aliases that act as commands in +# the documentation. An alias has the form: +# name=value +# For example adding +# "sideeffect=@par Side Effects:\n" +# will allow you to put the command \sideeffect (or @sideeffect) in the +# documentation, which will result in a user-defined paragraph with heading +# "Side Effects:". You can put \n's in the value part of an alias to insert +# newlines (in the resulting output). You can put ^^ in the value part of an +# alias to insert a newline as if a physical newline was in the original file. +# When you need a literal { or } or , in the value part of an alias you have to +# escape them by means of a backslash (\), this can lead to conflicts with the +# commands \{ and \} for these it is advised to use the version @{ and @} or use +# a double escape (\\{ and \\}) + +# Reference: https://git.ligo.org/lscsoft/lalsuite-archive/commit/e6e2dae8a73a73979a64854bbf697b077803697a +#ALIASES = "eqref{1}= Eq. \\eqref{\1}" \ +# "figref{1}= Fig. [\ref \1]" \ +# "tableref{1}= Table [\ref \1]" \ +# "figure{4}= \anchor \1 \image html \1.png \"Fig. [\1]: \4\"" + +# This allows doxygen passthrough of \eqref to html for mathjax +# Single reference within a math block +ALIASES += eqref{1}="\latexonly\ref{\1}\endlatexonly\htmlonly \eqref{\1}\endhtmlonly\xmlonly \\eqref{\1}\endxmlonly" + +# Large math block with multiple references +# TODO: We should be able to overload functions but recursion is happening? For now, the +# second command creates a \eqref2 that is passed to sphinx for processing. This breaks +# the html generation for doxygen +# Doxygen 1.8.13 requires extra help via xmlonly +# See python sphinxcontrib-autodoc_doxygen module autodoc_doxygen/xmlutils.py +# \eqref{eq:ale-thickness-equation,ale-equations,thickness} +ALIASES += eqref{3}="\latexonly\ref{\1}\endlatexonly\htmlonly \eqref2{\2,\3}\endhtmlonly\xmlonly \\eqref4{\1}\\eqref2{\2,\3}\endxmlonly" + +# Reference: https://stackoverflow.com/questions/25290453/how-do-i-add-a-footnote-in-doxygen +# TODO: Use this simple js library to create actual footnotes in html +# Reference: https://github.com/jheftmann/footnoted +ALIASES += footnote{1}="\latexonly\footnote\{\1\}\endlatexonly\htmlonly[*]\endhtmlonly\xmlonly[*]\endxmlonly" + +# \image latex does the wrong things to support equations in captions, this recreates +# what it does and just passes through the string uninterpreted. +# The image also needs to be added to LATEX_EXTRA_FILES. +# Default 3rd argument: \includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true] +ALIASES += imagelatex{3}="\latexonly\begin{DoxyImage}\3{\1}\doxyfigcaption{\2}\end{DoxyImage}\endlatexonly\xmlonly\2\endxmlonly" + +# This tag can be used to specify a number of word-keyword mappings (TCL only). +# A mapping has the form "name=value". For example adding "class=itcl::class" +# will allow you to use the command class in the itcl::class meaning. + +# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources +# only. Doxygen will then generate output that is more tailored for C. For +# instance, some of the names that are used will be different. The list of all +# members will be omitted, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_FOR_C = NO + +# Set the OPTIMIZE_OUTPUT_JAVA tag to YES if your project consists of Java or +# Python sources only. Doxygen will then generate output that is more tailored +# for that language. For instance, namespaces will be presented as packages, +# qualified scopes will look different, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_JAVA = NO + +# Set the OPTIMIZE_FOR_FORTRAN tag to YES if your project consists of Fortran +# sources. Doxygen will then generate output that is tailored for Fortran. +# The default value is: NO. + +OPTIMIZE_FOR_FORTRAN = YES + +# Set the OPTIMIZE_OUTPUT_VHDL tag to YES if your project consists of VHDL +# sources. Doxygen will then generate output that is tailored for VHDL. +# The default value is: NO. + +OPTIMIZE_OUTPUT_VHDL = NO + +# Set the OPTIMIZE_OUTPUT_SLICE tag to YES if your project consists of Slice +# sources only. Doxygen will then generate output that is more tailored for that +# language. For instance, namespaces will be presented as modules, types will be +# separated into more groups, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_SLICE = NO + +# Doxygen selects the parser to use depending on the extension of the files it +# parses. With this tag you can assign which parser to use for a given +# extension. Doxygen has a built-in mapping, but you can override or extend it +# using this tag. The format is ext=language, where ext is a file extension, and +# language is one of the parsers supported by doxygen: IDL, Java, JavaScript, +# Csharp (C#), C, C++, D, PHP, md (Markdown), Objective-C, Python, Slice, VHDL, +# Fortran (fixed format Fortran: FortranFixed, free formatted Fortran: +# FortranFree, unknown formatted Fortran: Fortran. In the later case the parser +# tries to guess whether the code is fixed or free formatted code, this is the +# default for Fortran type files). For instance to make doxygen treat .inc files +# as Fortran files (default is PHP), and .f files as C (default is Fortran), +# use: inc=Fortran f=C. +# +# Note: For files without extension you can use no_extension as a placeholder. +# +# Note that for custom extensions you also need to set FILE_PATTERNS otherwise +# the files are not read by doxygen. + +EXTENSION_MAPPING = + +# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments +# according to the Markdown format, which allows for more readable +# documentation. See https://daringfireball.net/projects/markdown/ for details. +# The output of markdown processing is further processed by doxygen, so you can +# mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in +# case of backward compatibilities issues. +# The default value is: YES. + +MARKDOWN_SUPPORT = YES + +# When the TOC_INCLUDE_HEADINGS tag is set to a non-zero value, all headings up +# to that level are automatically included in the table of contents, even if +# they do not have an id attribute. +# Note: This feature currently applies only to Markdown headings. +# Minimum value: 0, maximum value: 99, default value: 5. +# This tag requires that the tag MARKDOWN_SUPPORT is set to YES. + +TOC_INCLUDE_HEADINGS = 0 + +# When enabled doxygen tries to link words that correspond to documented +# classes, or namespaces to their corresponding documentation. Such a link can +# be prevented in individual cases by putting a % sign in front of the word or +# globally by setting AUTOLINK_SUPPORT to NO. +# The default value is: YES. + +AUTOLINK_SUPPORT = YES + +# If you use STL classes (i.e. std::string, std::vector, etc.) but do not want +# to include (a tag file for) the STL sources as input, then you should set this +# tag to YES in order to let doxygen match functions declarations and +# definitions whose arguments contain STL classes (e.g. func(std::string); +# versus func(std::string) {}). This also make the inheritance and collaboration +# diagrams that involve STL classes more complete and accurate. +# The default value is: NO. + +BUILTIN_STL_SUPPORT = NO + +# If you use Microsoft's C++/CLI language, you should set this option to YES to +# enable parsing support. +# The default value is: NO. + +CPP_CLI_SUPPORT = NO + +# Set the SIP_SUPPORT tag to YES if your project consists of sip (see: +# https://www.riverbankcomputing.com/software/sip/intro) sources only. Doxygen +# will parse them like normal C++ but will assume all classes use public instead +# of private inheritance when no explicit protection keyword is present. +# The default value is: NO. + +SIP_SUPPORT = NO + +# For Microsoft's IDL there are propget and propput attributes to indicate +# getter and setter methods for a property. Setting this option to YES will make +# doxygen to replace the get and set methods by a property in the documentation. +# This will only work if the methods are indeed getting or setting a simple +# type. If this is not the case, or you want to show the methods anyway, you +# should set this option to NO. +# The default value is: YES. + +IDL_PROPERTY_SUPPORT = YES + +# If member grouping is used in the documentation and the DISTRIBUTE_GROUP_DOC +# tag is set to YES then doxygen will reuse the documentation of the first +# member in the group (if any) for the other members of the group. By default +# all members of a group must be documented explicitly. +# The default value is: NO. + +DISTRIBUTE_GROUP_DOC = YES + +# If one adds a struct or class to a group and this option is enabled, then also +# any nested class or struct is added to the same group. By default this option +# is disabled and one has to add nested compounds explicitly via \ingroup. +# The default value is: NO. + +GROUP_NESTED_COMPOUNDS = NO + +# Set the SUBGROUPING tag to YES to allow class member groups of the same type +# (for instance a group of public functions) to be put as a subgroup of that +# type (e.g. under the Public Functions section). Set it to NO to prevent +# subgrouping. Alternatively, this can be done per class using the +# \nosubgrouping command. +# The default value is: YES. + +SUBGROUPING = YES + +# When the INLINE_GROUPED_CLASSES tag is set to YES, classes, structs and unions +# are shown inside the group in which they are included (e.g. using \ingroup) +# instead of on a separate page (for HTML and Man pages) or section (for LaTeX +# and RTF). +# +# Note that this feature does not work in combination with +# SEPARATE_MEMBER_PAGES. +# The default value is: NO. + +INLINE_GROUPED_CLASSES = NO + +# When the INLINE_SIMPLE_STRUCTS tag is set to YES, structs, classes, and unions +# with only public data fields or simple typedef fields will be shown inline in +# the documentation of the scope in which they are defined (i.e. file, +# namespace, or group documentation), provided this scope is documented. If set +# to NO, structs, classes, and unions are shown on a separate page (for HTML and +# Man pages) or section (for LaTeX and RTF). +# The default value is: NO. + +INLINE_SIMPLE_STRUCTS = NO + +# When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or +# enum is documented as struct, union, or enum with the name of the typedef. So +# typedef struct TypeS {} TypeT, will appear in the documentation as a struct +# with name TypeT. When disabled the typedef will appear as a member of a file, +# namespace, or class. And the struct will be named TypeS. This can typically be +# useful for C code in case the coding convention dictates that all compound +# types are typedef'ed and only the typedef is referenced, never the tag name. +# The default value is: NO. + +TYPEDEF_HIDES_STRUCT = NO + +# The size of the symbol lookup cache can be set using LOOKUP_CACHE_SIZE. This +# cache is used to resolve symbols given their name and scope. Since this can be +# an expensive process and often the same symbol appears multiple times in the +# code, doxygen keeps a cache of pre-resolved symbols. If the cache is too small +# doxygen will become slower. If the cache is too large, memory is wasted. The +# cache size is given by this formula: 2^(16+LOOKUP_CACHE_SIZE). The valid range +# is 0..9, the default is 0, corresponding to a cache size of 2^16=65536 +# symbols. At the end of a run doxygen will report the cache usage and suggest +# the optimal cache size from a speed point of view. +# Minimum value: 0, maximum value: 9, default value: 0. + +LOOKUP_CACHE_SIZE = 0 + +# The NUM_PROC_THREADS specifies the number threads doxygen is allowed to use +# during processing. When set to 0 doxygen will based this on the number of +# cores available in the system. You can set it explicitly to a value larger +# than 0 to get more control over the balance between CPU load and processing +# speed. At this moment only the input processing can be done using multiple +# threads. Since this is still an experimental feature the default is set to 1, +# which efficively disables parallel processing. Please report any issues you +# encounter. Generating dot graphs in parallel is controlled by the +# DOT_NUM_THREADS setting. +# Minimum value: 0, maximum value: 32, default value: 1. + +NUM_PROC_THREADS = 1 + +#--------------------------------------------------------------------------- +# Build related configuration options +#--------------------------------------------------------------------------- + +# If the EXTRACT_ALL tag is set to YES, doxygen will assume all entities in +# documentation are documented, even if no documentation was available. Private +# class members and static file members will be hidden unless the +# EXTRACT_PRIVATE respectively EXTRACT_STATIC tags are set to YES. +# Note: This will also disable the warnings about undocumented members that are +# normally produced when WARNINGS is set to YES. +# The default value is: NO. + +EXTRACT_ALL = NO + +# If the EXTRACT_PRIVATE tag is set to YES, all private members of a class will +# be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIVATE = YES + +# If the EXTRACT_PRIV_VIRTUAL tag is set to YES, documented private virtual +# methods of a class will be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIV_VIRTUAL = NO + +# If the EXTRACT_PACKAGE tag is set to YES, all members with package or internal +# scope will be included in the documentation. +# The default value is: NO. + +EXTRACT_PACKAGE = YES + +# If the EXTRACT_STATIC tag is set to YES, all static members of a file will be +# included in the documentation. +# The default value is: NO. + +EXTRACT_STATIC = YES + +# If the EXTRACT_LOCAL_CLASSES tag is set to YES, classes (and structs) defined +# locally in source files will be included in the documentation. If set to NO, +# only classes defined in header files are included. Does not have any effect +# for Java sources. +# The default value is: YES. + +EXTRACT_LOCAL_CLASSES = YES + +# This flag is only useful for Objective-C code. If set to YES, local methods, +# which are defined in the implementation section but not in the interface are +# included in the documentation. If set to NO, only methods in the interface are +# included. +# The default value is: NO. + +EXTRACT_LOCAL_METHODS = YES + +# If this flag is set to YES, the members of anonymous namespaces will be +# extracted and appear in the documentation as a namespace called +# 'anonymous_namespace{file}', where file will be replaced with the base name of +# the file that contains the anonymous namespace. By default anonymous namespace +# are hidden. +# The default value is: NO. + +EXTRACT_ANON_NSPACES = YES + +# If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all +# undocumented members inside documented classes or files. If set to NO these +# members will be included in the various overviews, but no documentation +# section is generated. This option has no effect if EXTRACT_ALL is enabled. +# The default value is: NO. + +HIDE_UNDOC_MEMBERS = NO + +# If the HIDE_UNDOC_CLASSES tag is set to YES, doxygen will hide all +# undocumented classes that are normally visible in the class hierarchy. If set +# to NO, these classes will be included in the various overviews. This option +# has no effect if EXTRACT_ALL is enabled. +# The default value is: NO. + +HIDE_UNDOC_CLASSES = NO + +# If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend +# declarations. If set to NO, these declarations will be included in the +# documentation. +# The default value is: NO. + +HIDE_FRIEND_COMPOUNDS = NO + +# If the HIDE_IN_BODY_DOCS tag is set to YES, doxygen will hide any +# documentation blocks found inside the body of a function. If set to NO, these +# blocks will be appended to the function's detailed documentation block. +# The default value is: NO. + +HIDE_IN_BODY_DOCS = NO + +# The INTERNAL_DOCS tag determines if documentation that is typed after a +# \internal command is included. If the tag is set to NO then the documentation +# will be excluded. Set it to YES to include the internal documentation. +# The default value is: NO. + +INTERNAL_DOCS = YES + +# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file +# names in lower-case letters. If set to YES, upper-case letters are also +# allowed. This is useful if you have classes or files whose names only differ +# in case and if your file system supports case sensitive file names. Windows +# (including Cygwin) and Mac users are advised to set this option to NO. +# The default value is: system dependent. + +CASE_SENSE_NAMES = YES + +# If the HIDE_SCOPE_NAMES tag is set to NO then doxygen will show members with +# their full class and namespace scopes in the documentation. If set to YES, the +# scope will be hidden. +# The default value is: NO. + +HIDE_SCOPE_NAMES = NO + +# If the HIDE_COMPOUND_REFERENCE tag is set to NO (default) then doxygen will +# append additional text to a page's title, such as Class Reference. If set to +# YES the compound reference will be hidden. +# The default value is: NO. + +HIDE_COMPOUND_REFERENCE= NO + +# If the SHOW_INCLUDE_FILES tag is set to YES then doxygen will put a list of +# the files that are included by a file in the documentation of that file. +# The default value is: YES. + +SHOW_INCLUDE_FILES = YES + +# If the SHOW_GROUPED_MEMB_INC tag is set to YES then Doxygen will add for each +# grouped member an include statement to the documentation, telling the reader +# which file to include in order to use the member. +# The default value is: NO. + +SHOW_GROUPED_MEMB_INC = NO + +# If the FORCE_LOCAL_INCLUDES tag is set to YES then doxygen will list include +# files with double quotes in the documentation rather than with sharp brackets. +# The default value is: NO. + +FORCE_LOCAL_INCLUDES = NO + +# If the INLINE_INFO tag is set to YES then a tag [inline] is inserted in the +# documentation for inline members. +# The default value is: YES. + +INLINE_INFO = YES + +# If the SORT_MEMBER_DOCS tag is set to YES then doxygen will sort the +# (detailed) documentation of file and class members alphabetically by member +# name. If set to NO, the members will appear in declaration order. +# The default value is: YES. + +SORT_MEMBER_DOCS = YES + +# If the SORT_BRIEF_DOCS tag is set to YES then doxygen will sort the brief +# descriptions of file, namespace and class members alphabetically by member +# name. If set to NO, the members will appear in declaration order. Note that +# this will also influence the order of the classes in the class list. +# The default value is: NO. + +SORT_BRIEF_DOCS = NO + +# If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the +# (brief and detailed) documentation of class members so that constructors and +# destructors are listed first. If set to NO the constructors will appear in the +# respective orders defined by SORT_BRIEF_DOCS and SORT_MEMBER_DOCS. +# Note: If SORT_BRIEF_DOCS is set to NO this option is ignored for sorting brief +# member documentation. +# Note: If SORT_MEMBER_DOCS is set to NO this option is ignored for sorting +# detailed member documentation. +# The default value is: NO. + +SORT_MEMBERS_CTORS_1ST = NO + +# If the SORT_GROUP_NAMES tag is set to YES then doxygen will sort the hierarchy +# of group names into alphabetical order. If set to NO the group names will +# appear in their defined order. +# The default value is: NO. + +SORT_GROUP_NAMES = NO + +# If the SORT_BY_SCOPE_NAME tag is set to YES, the class list will be sorted by +# fully-qualified names, including namespaces. If set to NO, the class list will +# be sorted only by class name, not including the namespace part. +# Note: This option is not very useful if HIDE_SCOPE_NAMES is set to YES. +# Note: This option applies only to the class list, not to the alphabetical +# list. +# The default value is: NO. + +SORT_BY_SCOPE_NAME = NO + +# If the STRICT_PROTO_MATCHING option is enabled and doxygen fails to do proper +# type resolution of all parameters of a function it will reject a match between +# the prototype and the implementation of a member function even if there is +# only one candidate or it is obvious which candidate to choose by doing a +# simple string match. By disabling STRICT_PROTO_MATCHING doxygen will still +# accept a match between prototype and implementation in such cases. +# The default value is: NO. + +STRICT_PROTO_MATCHING = NO + +# The GENERATE_TODOLIST tag can be used to enable (YES) or disable (NO) the todo +# list. This list is created by putting \todo commands in the documentation. +# The default value is: YES. + +GENERATE_TODOLIST = YES + +# The GENERATE_TESTLIST tag can be used to enable (YES) or disable (NO) the test +# list. This list is created by putting \test commands in the documentation. +# The default value is: YES. + +GENERATE_TESTLIST = YES + +# The GENERATE_BUGLIST tag can be used to enable (YES) or disable (NO) the bug +# list. This list is created by putting \bug commands in the documentation. +# The default value is: YES. + +GENERATE_BUGLIST = YES + +# The GENERATE_DEPRECATEDLIST tag can be used to enable (YES) or disable (NO) +# the deprecated list. This list is created by putting \deprecated commands in +# the documentation. +# The default value is: YES. + +GENERATE_DEPRECATEDLIST= YES + +# The ENABLED_SECTIONS tag can be used to enable conditional documentation +# sections, marked by \if ... \endif and \cond +# ... \endcond blocks. + +ENABLED_SECTIONS = + +# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the +# initial value of a variable or macro / define can have for it to appear in the +# documentation. If the initializer consists of more lines than specified here +# it will be hidden. Use a value of 0 to hide initializers completely. The +# appearance of the value of individual variables and macros / defines can be +# controlled using \showinitializer or \hideinitializer command in the +# documentation regardless of this setting. +# Minimum value: 0, maximum value: 10000, default value: 30. + +MAX_INITIALIZER_LINES = 30 + +# Set the SHOW_USED_FILES tag to NO to disable the list of files generated at +# the bottom of the documentation of classes and structs. If set to YES, the +# list will mention the files that were used to generate the documentation. +# The default value is: YES. + +SHOW_USED_FILES = YES + +# Set the SHOW_FILES tag to NO to disable the generation of the Files page. This +# will remove the Files entry from the Quick Index and from the Folder Tree View +# (if specified). +# The default value is: YES. + +SHOW_FILES = YES + +# Set the SHOW_NAMESPACES tag to NO to disable the generation of the Namespaces +# page. This will remove the Namespaces entry from the Quick Index and from the +# Folder Tree View (if specified). +# The default value is: YES. + +SHOW_NAMESPACES = YES + +# The FILE_VERSION_FILTER tag can be used to specify a program or script that +# doxygen should invoke to get the current version for each file (typically from +# the version control system). Doxygen will invoke the program by executing (via +# popen()) the command command input-file, where command is the value of the +# FILE_VERSION_FILTER tag, and input-file is the name of an input file provided +# by doxygen. Whatever the program writes to standard output is used as the file +# version. For an example see the documentation. + +FILE_VERSION_FILTER = + +# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed +# by doxygen. The layout file controls the global structure of the generated +# output files in an output format independent way. To create the layout file +# that represents doxygen's defaults, run doxygen with the -l option. You can +# optionally specify a file name after the option, if omitted DoxygenLayout.xml +# will be used as the name of the layout file. +# +# Note that if you run doxygen from a directory containing a file called +# DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE +# tag is left empty. + +LAYOUT_FILE = layout.xml + +# The CITE_BIB_FILES tag can be used to specify one or more bib files containing +# the reference definitions. This must be a list of .bib files. The .bib +# extension is automatically appended if omitted. This requires the bibtex tool +# to be installed. See also https://en.wikipedia.org/wiki/BibTeX for more info. +# For LaTeX the style of the bibliography can be controlled using +# LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the +# search path. See also \cite for info how to create references. + +CITE_BIB_FILES = ocean.bib references.bib zotero.bib + +#--------------------------------------------------------------------------- +# Configuration options related to warning and progress messages +#--------------------------------------------------------------------------- + +# The QUIET tag can be used to turn on/off the messages that are generated to +# standard output by doxygen. If QUIET is set to YES this implies that the +# messages are off. +# The default value is: NO. + +QUIET = NO + +# The WARNINGS tag can be used to turn on/off the warning messages that are +# generated to standard error (stderr) by doxygen. If WARNINGS is set to YES +# this implies that the warnings are on. +# +# Tip: Turn warnings on while writing the documentation. +# The default value is: YES. + +WARNINGS = YES + +# If the WARN_IF_UNDOCUMENTED tag is set to YES then doxygen will generate +# warnings for undocumented members. If EXTRACT_ALL is set to YES then this flag +# will automatically be disabled. +# The default value is: YES. + +WARN_IF_UNDOCUMENTED = YES + +# If the WARN_IF_DOC_ERROR tag is set to YES, doxygen will generate warnings for +# potential errors in the documentation, such as not documenting some parameters +# in a documented function, or documenting parameters that don't exist or using +# markup commands wrongly. +# The default value is: YES. + +WARN_IF_DOC_ERROR = YES + +# This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that +# are documented, but have no documentation for their parameters or return +# value. If set to NO, doxygen will only warn about wrong or incomplete +# parameter documentation, but not about the absence of documentation. If +# EXTRACT_ALL is set to YES then this flag will automatically be disabled. +# The default value is: NO. + +WARN_NO_PARAMDOC = NO + +# If the WARN_AS_ERROR tag is set to YES then doxygen will immediately stop when +# a warning is encountered. +# The default value is: NO. + +WARN_AS_ERROR = NO + +# The WARN_FORMAT tag determines the format of the warning messages that doxygen +# can produce. The string should contain the $file, $line, and $text tags, which +# will be replaced by the file and line number from which the warning originated +# and the warning text. Optionally the format may contain $version, which will +# be replaced by the version of the file (if it could be obtained via +# FILE_VERSION_FILTER) +# The default value is: $file:$line: $text. + +WARN_FORMAT = "$file:$line: $text" + +# The WARN_LOGFILE tag can be used to specify a file to which warning and error +# messages should be written. If left blank the output is written to standard +# error (stderr). + +WARN_LOGFILE = _build/doxygen_warn_nortd_latex_log.txt + +#--------------------------------------------------------------------------- +# Configuration options related to the input files +#--------------------------------------------------------------------------- + +# The INPUT tag is used to specify the files and/or directories that contain +# documented source files. You may enter file names like myfile.cpp or +# directories like /usr/src/myproject. Separate the files or directories with +# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING +# Note: If this tag is empty the current directory is searched. + +INPUT = ../src \ + front_page.md \ + ../config_src/drivers/solo_driver \ + ../config_src/memory/dynamic_symmetric \ + ../config_src/external \ + ../config_src/drivers/FMS_cap + +# This tag can be used to specify the character encoding of the source files +# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses +# libiconv (or the iconv built into libc) for the transcoding. See the libiconv +# documentation (see: https://www.gnu.org/software/libiconv/) for the list of +# possible encodings. +# The default value is: UTF-8. + +INPUT_ENCODING = UTF-8 + +# If the value of the INPUT tag contains directories, you can use the +# FILE_PATTERNS tag to specify one or more wildcard patterns (like *.cpp and +# *.h) to filter out the source-files in the directories. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# read by doxygen. +# +# If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, +# *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, +# *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, +# *.m, *.markdown, *.md, *.mm, *.dox (to be provided as doxygen C comment), +# *.doc (to be provided as doxygen C comment), *.txt (to be provided as doxygen +# C comment), *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, *.f18, *.f, *.for, *.vhd, +# *.vhdl, *.ucf, *.qsf and *.ice. + +FILE_PATTERNS = *.c \ + *.cc \ + *.cxx \ + *.cpp \ + *.c++ \ + *.java \ + *.ii \ + *.ixx \ + *.ipp \ + *.i++ \ + *.inl \ + *.idl \ + *.ddl \ + *.odl \ + *.h \ + *.hh \ + *.hxx \ + *.hpp \ + *.h++ \ + *.cs \ + *.d \ + *.php \ + *.php4 \ + *.php5 \ + *.phtml \ + *.inc \ + *.m \ + *.markdown \ + *.md \ + *.mm \ + *.dox \ + *.doc \ + *.txt \ + *.py \ + *.pyw \ + *.f90 \ + *.f95 \ + *.f03 \ + *.f08 \ + *.f18 \ + *.f \ + *.for \ + *.vhd \ + *.vhdl \ + *.ucf \ + *.qsf \ + *.ice \ + *.F90 + +# The RECURSIVE tag can be used to specify whether or not subdirectories should +# be searched for input files as well. +# The default value is: NO. + +RECURSIVE = YES + +# The EXCLUDE tag can be used to specify files and/or directories that should be +# excluded from the INPUT source files. This way you can easily exclude a +# subdirectory from a directory tree whose root is specified with the INPUT tag. +# +# Note that relative paths are relative to the directory from which doxygen is +# run. + +EXCLUDE = ../src/equation_of_state/TEOS10 + +# 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 +# from the input. +# The default value is: NO. + +EXCLUDE_SYMLINKS = NO + +# If the value of the INPUT tag contains directories, you can use the +# EXCLUDE_PATTERNS tag to specify one or more wildcard patterns to exclude +# certain files from those directories. +# +# Note that the wildcards are matched against the file with absolute path, so to +# exclude all test directories for example use the pattern */test/* + +EXCLUDE_PATTERNS = makedep.py \ + Makefile \ + INSTALL + +# The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names +# (namespaces, classes, functions, etc.) that should be excluded from the +# output. The symbol name can be a fully qualified name, a word, or if the +# wildcard * is used, a substring. Examples: ANamespace, AClass, +# AClass::ANamespace, ANamespace::*Test +# +# Note that the wildcards are matched against the file with absolute path, so to +# exclude all test directories use the pattern */test/* + +EXCLUDE_SYMBOLS = + +# The EXAMPLE_PATH tag can be used to specify one or more files or directories +# that contain example code fragments that are included (see the \include +# command). + +EXAMPLE_PATH = ../src + +# If the value of the EXAMPLE_PATH tag contains directories, you can use the +# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and +# *.h) to filter out the source-files in the directories. If left blank all +# files are included. + +EXAMPLE_PATTERNS = * + +# If the EXAMPLE_RECURSIVE tag is set to YES then subdirectories will be +# searched for input files to be used with the \include or \dontinclude commands +# irrespective of the value of the RECURSIVE tag. +# The default value is: NO. + +EXAMPLE_RECURSIVE = NO + +# The IMAGE_PATH tag can be used to specify one or more files or directories +# that contain images that are to be included in the documentation (see the +# \image command). + +IMAGE_PATH = images \ + ../src + +# The INPUT_FILTER tag can be used to specify a program that doxygen should +# invoke to filter for each input file. Doxygen will invoke the filter program +# by executing (via popen()) the command: +# +# +# +# where is the value of the INPUT_FILTER tag, and is the +# name of an input file. Doxygen will then use the output that the filter +# program writes to standard output. If FILTER_PATTERNS is specified, this tag +# will be ignored. +# +# Note that the filter must not add or remove lines; it is applied before the +# code is scanned, but not when the output code is generated. If lines are added +# or removed, the anchors will not be placed correctly. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. + +INPUT_FILTER = + +# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern +# basis. Doxygen will compare the file name with each pattern and apply the +# filter if there is a match. The filters are a list of the form: pattern=filter +# (like *.cpp=my_cpp_filter). See INPUT_FILTER for further information on how +# filters are used. If the FILTER_PATTERNS tag is empty or if none of the +# patterns match the file name, INPUT_FILTER is applied. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. + +FILTER_PATTERNS = + +# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using +# INPUT_FILTER) will also be used to filter the input files that are used for +# producing the source files to browse (i.e. when SOURCE_BROWSER is set to YES). +# The default value is: NO. + +FILTER_SOURCE_FILES = NO + +# The FILTER_SOURCE_PATTERNS tag can be used to specify source filters per file +# pattern. A pattern will override the setting for FILTER_PATTERN (if any) and +# it is also possible to disable source filtering for a specific pattern using +# *.ext= (so without naming a filter). +# This tag requires that the tag FILTER_SOURCE_FILES is set to YES. + +FILTER_SOURCE_PATTERNS = + +# If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that +# is part of the input, its contents will be placed on the main page +# (index.html). This can be useful if you have a project on for instance GitHub +# and want to reuse the introduction page also for the doxygen output. + +USE_MDFILE_AS_MAINPAGE = front_page.md + +#--------------------------------------------------------------------------- +# Configuration options related to source browsing +#--------------------------------------------------------------------------- + +# If the SOURCE_BROWSER tag is set to YES then a list of source files will be +# generated. Documented entities will be cross-referenced with these sources. +# +# Note: To get rid of all source code in the generated output, make sure that +# also VERBATIM_HEADERS is set to NO. +# The default value is: NO. + +SOURCE_BROWSER = YES + +# Setting the INLINE_SOURCES tag to YES will include the body of functions, +# classes and enums directly into the documentation. +# The default value is: NO. + +INLINE_SOURCES = YES + +# Setting the STRIP_CODE_COMMENTS tag to YES will instruct doxygen to hide any +# special comment blocks from generated source code fragments. Normal C, C++ and +# Fortran comments will always remain visible. +# The default value is: YES. + +STRIP_CODE_COMMENTS = NO + +# If the REFERENCED_BY_RELATION tag is set to YES then for each documented +# entity all documented functions referencing it will be listed. +# The default value is: NO. + +REFERENCED_BY_RELATION = YES + +# If the REFERENCES_RELATION tag is set to YES then for each documented function +# all documented entities called/used by that function will be listed. +# The default value is: NO. + +REFERENCES_RELATION = YES + +# If the REFERENCES_LINK_SOURCE tag is set to YES and SOURCE_BROWSER tag is set +# to YES then the hyperlinks from functions in REFERENCES_RELATION and +# REFERENCED_BY_RELATION lists will link to the source code. Otherwise they will +# link to the documentation. +# The default value is: YES. + +REFERENCES_LINK_SOURCE = YES + +# If SOURCE_TOOLTIPS is enabled (the default) then hovering a hyperlink in the +# source code will show a tooltip with additional information such as prototype, +# brief description and links to the definition and documentation. Since this +# will make the HTML file larger and loading of large files a bit slower, you +# can opt to disable this feature. +# The default value is: YES. +# This tag requires that the tag SOURCE_BROWSER is set to YES. + +SOURCE_TOOLTIPS = YES + +# If the USE_HTAGS tag is set to YES then the references to source code will +# point to the HTML generated by the htags(1) tool instead of doxygen built-in +# source browser. The htags tool is part of GNU's global source tagging system +# (see https://www.gnu.org/software/global/global.html). You will need version +# 4.8.6 or higher. +# +# To use it do the following: +# - Install the latest version of global +# - Enable SOURCE_BROWSER and USE_HTAGS in the configuration file +# - Make sure the INPUT points to the root of the source tree +# - Run doxygen as normal +# +# Doxygen will invoke htags (and that will in turn invoke gtags), so these +# tools must be available from the command line (i.e. in the search path). +# +# The result: instead of the source browser generated by doxygen, the links to +# source code will now point to the output of htags. +# The default value is: NO. +# This tag requires that the tag SOURCE_BROWSER is set to YES. + +USE_HTAGS = NO + +# If the VERBATIM_HEADERS tag is set the YES then doxygen will generate a +# verbatim copy of the header file for each class for which an include is +# specified. Set to NO to disable this. +# See also: Section \class. +# The default value is: YES. + +VERBATIM_HEADERS = YES + +#--------------------------------------------------------------------------- +# Configuration options related to the alphabetical class index +#--------------------------------------------------------------------------- + +# If the ALPHABETICAL_INDEX tag is set to YES, an alphabetical index of all +# compounds will be generated. Enable this if the project contains a lot of +# classes, structs, unions or interfaces. +# The default value is: YES. + +ALPHABETICAL_INDEX = YES + +# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in +# which the alphabetical index list will be split. +# Minimum value: 1, maximum value: 20, default value: 5. +# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. + +COLS_IN_ALPHA_INDEX = 1 + +# In case all classes in a project start with a common prefix, all classes will +# be put under the same header in the alphabetical index. The IGNORE_PREFIX tag +# can be used to specify a prefix (or a list of prefixes) that should be ignored +# while generating the index headers. +# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. + +IGNORE_PREFIX = + +#--------------------------------------------------------------------------- +# Configuration options related to the HTML output +#--------------------------------------------------------------------------- + +# If the GENERATE_HTML tag is set to YES, doxygen will generate HTML output +# The default value is: YES. + +GENERATE_HTML = YES + +# The HTML_OUTPUT tag is used to specify where the HTML docs will be put. If a +# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of +# it. +# The default directory is: html. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_OUTPUT = _build/APIs + +# The HTML_FILE_EXTENSION tag can be used to specify the file extension for each +# generated HTML page (for example: .htm, .php, .asp). +# The default value is: .html. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FILE_EXTENSION = .html + +# The HTML_HEADER tag can be used to specify a user-defined HTML header file for +# each generated HTML page. If the tag is left blank doxygen will generate a +# standard header. +# +# To get valid HTML the header file that includes any scripts and style sheets +# that doxygen needs, which is dependent on the configuration options used (e.g. +# the setting GENERATE_TREEVIEW). It is highly recommended to start with a +# default header using +# doxygen -w html new_header.html new_footer.html new_stylesheet.css +# YourConfigFile +# and then modify the file new_header.html. See also section "Doxygen usage" +# for information on how to generate the default header that doxygen normally +# uses. +# Note: The header is subject to change so you typically have to regenerate the +# default header when upgrading to a newer version of doxygen. For a description +# of the possible markers and block names see the documentation. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_HEADER = + +# The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each +# generated HTML page. If the tag is left blank doxygen will generate a standard +# footer. See HTML_HEADER for more information on how to generate a default +# footer and what special commands can be used inside the footer. See also +# section "Doxygen usage" for information on how to generate the default footer +# that doxygen normally uses. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FOOTER = + +# The HTML_STYLESHEET tag can be used to specify a user-defined cascading style +# sheet that is used by each HTML page. It can be used to fine-tune the look of +# the HTML output. If left blank doxygen will generate a default style sheet. +# See also section "Doxygen usage" for information on how to generate the style +# sheet that doxygen normally uses. +# Note: It is recommended to use HTML_EXTRA_STYLESHEET instead of this tag, as +# it is more robust and this tag (HTML_STYLESHEET) will in the future become +# obsolete. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_STYLESHEET = + +# The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined +# cascading style sheets that are included after the standard style sheets +# created by doxygen. Using this option one can overrule certain style aspects. +# This is preferred over using HTML_STYLESHEET since it does not replace the +# standard style sheet and is therefore more robust against future updates. +# Doxygen will copy the style sheet files to the output directory. +# Note: The order of the extra style sheet files is of importance (e.g. the last +# style sheet in the list overrules the setting of the previous ones in the +# list). For an example see the documentation. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_EXTRA_STYLESHEET = + +# The HTML_EXTRA_FILES tag can be used to specify one or more extra images or +# other source files which should be copied to the HTML output directory. Note +# that these files will be copied to the base HTML output directory. Use the +# $relpath^ marker in the HTML_HEADER and/or HTML_FOOTER files to load these +# files. In the HTML_STYLESHEET file, use the file name only. Also note that the +# files will be copied as-is; there are no commands or markers available. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_EXTRA_FILES = + +# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen +# will adjust the colors in the style sheet and background images according to +# this color. Hue is specified as an angle on a colorwheel, see +# https://en.wikipedia.org/wiki/Hue for more information. For instance the value +# 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300 +# purple, and 360 is red again. +# Minimum value: 0, maximum value: 359, default value: 220. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_HUE = 220 + +# The HTML_COLORSTYLE_SAT tag controls the purity (or saturation) of the colors +# in the HTML output. For a value of 0 the output will use grayscales only. A +# value of 255 will produce the most vivid colors. +# Minimum value: 0, maximum value: 255, default value: 100. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_SAT = 100 + +# The HTML_COLORSTYLE_GAMMA tag controls the gamma correction applied to the +# luminance component of the colors in the HTML output. Values below 100 +# gradually make the output lighter, whereas values above 100 make the output +# darker. The value divided by 100 is the actual gamma applied, so 80 represents +# a gamma of 0.8, The value 220 represents a gamma of 2.2, and 100 does not +# change the gamma. +# Minimum value: 40, maximum value: 240, default value: 80. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_GAMMA = 80 + +# If the HTML_TIMESTAMP tag is set to YES then the footer of each generated HTML +# page will contain the date and time when the page was generated. Setting this +# to YES can help to show when doxygen was last run and thus if the +# documentation is up to date. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_TIMESTAMP = NO + +# If the HTML_DYNAMIC_MENUS tag is set to YES then the generated HTML +# documentation will contain a main index with vertical navigation menus that +# are dynamically created via JavaScript. If disabled, the navigation index will +# consists of multiple levels of tabs that are statically embedded in every HTML +# page. Disable this option to support browsers that do not have JavaScript, +# like the Qt help browser. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_MENUS = YES + +# If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML +# documentation will contain sections that can be hidden and shown after the +# page has loaded. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_SECTIONS = NO + +# With HTML_INDEX_NUM_ENTRIES one can control the preferred number of entries +# shown in the various tree structured indices initially; the user can expand +# and collapse entries dynamically later on. Doxygen will expand the tree to +# such a level that at most the specified number of entries are visible (unless +# a fully collapsed tree already exceeds this amount). So setting the number of +# entries 1 will produce a full collapsed tree by default. 0 is a special value +# representing an infinite number of entries and will result in a full expanded +# tree by default. +# Minimum value: 0, maximum value: 9999, default value: 100. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_INDEX_NUM_ENTRIES = 900 + +# If the GENERATE_DOCSET tag is set to YES, additional index files will be +# generated that can be used as input for Apple's Xcode 3 integrated development +# environment (see: https://developer.apple.com/xcode/), introduced with OSX +# 10.5 (Leopard). To create a documentation set, doxygen will generate a +# Makefile in the HTML output directory. Running make will produce the docset in +# that directory and running make install will install the docset in +# ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at +# startup. See https://developer.apple.com/library/archive/featuredarticles/Doxy +# genXcode/_index.html for more information. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_DOCSET = NO + +# This tag determines the name of the docset feed. A documentation feed provides +# an umbrella under which multiple documentation sets from a single provider +# (such as a company or product suite) can be grouped. +# The default value is: Doxygen generated docs. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_FEEDNAME = "Doxygen generated docs" + +# This tag specifies a string that should uniquely identify the documentation +# set bundle. This should be a reverse domain-name style string, e.g. +# com.mycompany.MyDocSet. Doxygen will append .docset to the name. +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_BUNDLE_ID = org.doxygen.Project + +# The DOCSET_PUBLISHER_ID tag specifies a string that should uniquely identify +# the documentation publisher. This should be a reverse domain-name style +# string, e.g. com.mycompany.MyDocSet.documentation. +# The default value is: org.doxygen.Publisher. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_PUBLISHER_ID = org.doxygen.Publisher + +# The DOCSET_PUBLISHER_NAME tag identifies the documentation publisher. +# The default value is: Publisher. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_PUBLISHER_NAME = Publisher + +# If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three +# additional HTML index files: index.hhp, index.hhc, and index.hhk. The +# index.hhp is a project file that can be read by Microsoft's HTML Help Workshop +# (see: https://www.microsoft.com/en-us/download/details.aspx?id=21138) on +# Windows. +# +# The HTML Help Workshop contains a compiler that can convert all HTML output +# generated by doxygen into a single compiled HTML file (.chm). Compiled HTML +# files are now used as the Windows 98 help format, and will replace the old +# Windows help format (.hlp) on all Windows platforms in the future. Compressed +# HTML files also contain an index, a table of contents, and you can search for +# words in the documentation. The HTML workshop also contains a viewer for +# compressed HTML files. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_HTMLHELP = NO + +# The CHM_FILE tag can be used to specify the file name of the resulting .chm +# file. You can add a path in front of the file if the result should not be +# written to the html output directory. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +CHM_FILE = + +# The HHC_LOCATION tag can be used to specify the location (absolute path +# including file name) of the HTML help compiler (hhc.exe). If non-empty, +# doxygen will try to run the HTML help compiler on the generated index.hhp. +# The file has to be specified with full path. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +HHC_LOCATION = + +# The GENERATE_CHI flag controls if a separate .chi index file is generated +# (YES) or that it should be included in the main .chm file (NO). +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +GENERATE_CHI = NO + +# The CHM_INDEX_ENCODING is used to encode HtmlHelp index (hhk), content (hhc) +# and project file content. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +CHM_INDEX_ENCODING = + +# The BINARY_TOC flag controls whether a binary table of contents is generated +# (YES) or a normal table of contents (NO) in the .chm file. Furthermore it +# enables the Previous and Next buttons. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +BINARY_TOC = NO + +# The TOC_EXPAND flag can be set to YES to add extra items for group members to +# the table of contents of the HTML help documentation and to the tree view. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +TOC_EXPAND = NO + +# If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and +# QHP_VIRTUAL_FOLDER are set, an additional index file will be generated that +# can be used as input for Qt's qhelpgenerator to generate a Qt Compressed Help +# (.qch) of the generated HTML documentation. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_QHP = NO + +# If the QHG_LOCATION tag is specified, the QCH_FILE tag can be used to specify +# the file name of the resulting .qch file. The path specified is relative to +# the HTML output folder. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QCH_FILE = + +# The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help +# Project output. For more information please see Qt Help Project / Namespace +# (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_NAMESPACE = org.doxygen.Project + +# The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt +# Help Project output. For more information please see Qt Help Project / Virtual +# Folders (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual- +# folders). +# The default value is: doc. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_VIRTUAL_FOLDER = doc + +# If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom +# filter to add. For more information please see Qt Help Project / Custom +# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_CUST_FILTER_NAME = + +# The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the +# custom filter to add. For more information please see Qt Help Project / Custom +# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_CUST_FILTER_ATTRS = + +# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this +# project's filter section matches. Qt Help Project / Filter Attributes (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#filter-attributes). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_SECT_FILTER_ATTRS = + +# The QHG_LOCATION tag can be used to specify the location of Qt's +# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the +# generated .qhp file. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHG_LOCATION = + +# If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be +# generated, together with the HTML files, they form an Eclipse help plugin. To +# install this plugin and make it available under the help contents menu in +# Eclipse, the contents of the directory containing the HTML and XML files needs +# to be copied into the plugins directory of eclipse. The name of the directory +# within the plugins directory should be the same as the ECLIPSE_DOC_ID value. +# After copying Eclipse needs to be restarted before the help appears. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_ECLIPSEHELP = NO + +# A unique identifier for the Eclipse help plugin. When installing the plugin +# the directory name containing the HTML and XML files should also have this +# name. Each documentation set should have its own identifier. +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_ECLIPSEHELP is set to YES. + +ECLIPSE_DOC_ID = org.doxygen.Project + +# If you want full control over the layout of the generated HTML pages it might +# be necessary to disable the index and replace it with your own. The +# DISABLE_INDEX tag can be used to turn on/off the condensed index (tabs) at top +# of each HTML page. A value of NO enables the index and the value YES disables +# it. Since the tabs in the index contain the same information as the navigation +# tree, you can set this option to YES if you also set GENERATE_TREEVIEW to YES. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +DISABLE_INDEX = NO + +# The GENERATE_TREEVIEW tag is used to specify whether a tree-like index +# structure should be generated to display hierarchical information. If the tag +# value is set to YES, a side panel will be generated containing a tree-like +# index structure (just like the one that is generated for HTML Help). For this +# to work a browser that supports JavaScript, DHTML, CSS and frames is required +# (i.e. any modern browser). Windows users are probably better off using the +# HTML help feature. Via custom style sheets (see HTML_EXTRA_STYLESHEET) one can +# further fine-tune the look of the index. As an example, the default style +# sheet generated by doxygen has an example that shows how to put an image at +# the root of the tree instead of the PROJECT_NAME. Since the tree basically has +# the same information as the tab index, you could consider setting +# DISABLE_INDEX to YES when enabling this option. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_TREEVIEW = YES + +# The ENUM_VALUES_PER_LINE tag can be used to set the number of enum values that +# doxygen will group on one line in the generated HTML documentation. +# +# Note that a value of 0 will completely suppress the enum values from appearing +# in the overview section. +# Minimum value: 0, maximum value: 20, default value: 4. +# This tag requires that the tag GENERATE_HTML is set to YES. + +ENUM_VALUES_PER_LINE = 4 + +# If the treeview is enabled (see GENERATE_TREEVIEW) then this tag can be used +# to set the initial width (in pixels) of the frame in which the tree is shown. +# Minimum value: 0, maximum value: 1500, default value: 250. +# This tag requires that the tag GENERATE_HTML is set to YES. + +TREEVIEW_WIDTH = 250 + +# If the EXT_LINKS_IN_WINDOW option is set to YES, doxygen will open links to +# external symbols imported via tag files in a separate window. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +EXT_LINKS_IN_WINDOW = NO + +# If the HTML_FORMULA_FORMAT option is set to svg, doxygen will use the pdf2svg +# tool (see https://github.com/dawbarton/pdf2svg) or inkscape (see +# https://inkscape.org) to generate formulas as SVG images instead of PNGs for +# the HTML output. These images will generally look nicer at scaled resolutions. +# Possible values are: png (the default) and svg (looks nicer but requires the +# pdf2svg or inkscape tool). +# The default value is: png. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FORMULA_FORMAT = svg + +# Use this tag to change the font size of LaTeX formulas included as images in +# the HTML documentation. When you change the font size after a successful +# doxygen run you need to manually remove any form_*.png images from the HTML +# output directory to force them to be regenerated. +# Minimum value: 8, maximum value: 50, default value: 10. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FORMULA_FONTSIZE = 10 + +# Use the FORMULA_TRANSPARENT tag to determine whether or not the images +# generated for formulas are transparent PNGs. Transparent PNGs are not +# supported properly for IE 6.0, but are supported on all modern browsers. +# +# Note that when changing this option you need to delete any form_*.png files in +# the HTML output directory before the changes have effect. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FORMULA_TRANSPARENT = YES + +# The FORMULA_MACROFILE can contain LaTeX \newcommand and \renewcommand commands +# to create new LaTeX commands to be used in formulas as building blocks. See +# the section "Including formulas" for details. + +FORMULA_MACROFILE = + +# Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see +# https://www.mathjax.org) which uses client side JavaScript for the rendering +# instead of using pre-rendered bitmaps. Use this if you do not have LaTeX +# installed or if you want to formulas look prettier in the HTML output. When +# enabled you may also need to install MathJax separately and configure the path +# to it using the MATHJAX_RELPATH option. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +USE_MATHJAX = YES + +# When MathJax is enabled you can set the default output format to be used for +# the MathJax output. See the MathJax site (see: +# http://docs.mathjax.org/en/latest/output.html) for more details. +# Possible values are: HTML-CSS (which is slower, but has the best +# compatibility), NativeMML (i.e. MathML) and SVG. +# The default value is: HTML-CSS. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_FORMAT = HTML-CSS + +# When MathJax is enabled you need to specify the location relative to the HTML +# output directory using the MATHJAX_RELPATH option. The destination directory +# should contain the MathJax.js script. For instance, if the mathjax directory +# is located at the same level as the HTML output directory, then +# MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax +# Content Delivery Network so you can quickly see the result without installing +# MathJax. However, it is strongly recommended to install a local copy of +# MathJax from https://www.mathjax.org before deployment. +# The default value is: https://cdn.jsdelivr.net/npm/mathjax@2. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_RELPATH = https://cdn.jsdelivr.net/npm/mathjax@2 + +# The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax +# extension names that should be enabled during MathJax rendering. For example +# MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_EXTENSIONS = + +# The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces +# of code that will be used on startup of the MathJax code. See the MathJax site +# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an +# example see the documentation. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_CODEFILE = + +# When the SEARCHENGINE tag is enabled doxygen will generate a search box for +# the HTML output. The underlying search engine uses javascript and DHTML and +# should work on any modern browser. Note that when using HTML help +# (GENERATE_HTMLHELP), Qt help (GENERATE_QHP), or docsets (GENERATE_DOCSET) +# there is already a search function so this one should typically be disabled. +# For large projects the javascript based search engine can be slow, then +# enabling SERVER_BASED_SEARCH may provide a better solution. It is possible to +# search using the keyboard; to jump to the search box use + S +# (what the is depends on the OS and browser, but it is typically +# , /